From 5336b12bd523006bea27c9066bcad95922c5dee2 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 22 Jan 2025 05:20:38 +1100 Subject: [PATCH] table and interactive documentation fixes --- src/bootsupport/modules/overtype-1.6.5.tm | 27 +- src/bootsupport/modules/punk-0.1.tm | 15 +- src/bootsupport/modules/punk/ansi-0.1.1.tm | 145 ++- src/bootsupport/modules/punk/args-0.1.0.tm | 1114 ++++++++++++----- .../punk/cap/handlers/templates-0.1.0.tm | 15 +- src/bootsupport/modules/punk/config-0.1.tm | 12 +- src/bootsupport/modules/punk/console-0.1.1.tm | 8 +- src/bootsupport/modules/punk/du-0.1.0.tm | 6 +- .../modules/punk/fileline-0.1.0.tm | 8 +- src/bootsupport/modules/punk/lib-0.1.1.tm | 26 +- .../modules/punk/mix/commandset/doc-0.1.0.tm | 3 +- .../punk/mix/commandset/layout-0.1.0.tm | 6 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 18 +- .../punk/mix/commandset/module-0.1.0.tm | 13 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 8 +- src/bootsupport/modules/punk/nav/fs-0.1.0.tm | 34 +- src/bootsupport/modules/punk/ns-0.1.0.tm | 421 +++++-- src/bootsupport/modules/punk/path-0.1.0.tm | 6 +- src/bootsupport/modules/punk/repo-0.1.1.tm | 84 +- src/bootsupport/modules/punk/zip-0.1.1.tm | 19 +- src/bootsupport/modules/textblock-0.1.2.tm | 139 +- src/modules/argparsingtest-999999.0a1.0.tm | 46 +- src/modules/patternpunk-1.1.tm | 15 +- src/modules/poshinfo-999999.0a1.0.tm | 20 +- src/modules/punk-0.1.tm | 13 +- src/modules/punk/ansi-999999.0a1.0.tm | 145 ++- src/modules/punk/args-999999.0a1.0.tm | 1114 ++++++++++++----- src/modules/punk/args/tclcore-999999.0a1.0.tm | 494 ++++++-- src/modules/punk/blockletter-999999.0a1.0.tm | 18 +- .../cap/handlers/templates-999999.0a1.0.tm | 15 +- src/modules/punk/config-0.1.tm | 12 +- src/modules/punk/console-999999.0a1.0.tm | 8 +- src/modules/punk/du-999999.0a1.0.tm | 6 +- src/modules/punk/fileline-999999.0a1.0.tm | 8 +- src/modules/punk/lib-999999.0a1.0.tm | 26 +- .../punk/mix/commandset/doc-999999.0a1.0.tm | 3 +- .../mix/commandset/layout-999999.0a1.0.tm | 6 +- .../mix/commandset/loadedlib-999999.0a1.0.tm | 13 +- .../mix/commandset/module-999999.0a1.0.tm | 13 +- .../mix/commandset/scriptwrap-999999.0a1.0.tm | 8 +- src/modules/punk/nav/fs-999999.0a1.0.tm | 34 +- src/modules/punk/ns-999999.0a1.0.tm | 421 +++++-- src/modules/punk/path-999999.0a1.0.tm | 6 +- src/modules/punk/repo-999999.0a1.0.tm | 84 +- src/modules/punk/safe-999999.0a1.0.tm | 28 +- src/modules/punk/sixel-999999.0a1.0.tm | 8 +- src/modules/punk/zip-999999.0a1.0.tm | 19 +- src/modules/textblock-999999.0a1.0.tm | 139 +- .../src/bootsupport/modules/overtype-1.6.5.tm | 27 +- .../src/bootsupport/modules/punk-0.1.tm | 15 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 145 ++- .../bootsupport/modules/punk/args-0.1.0.tm | 1114 ++++++++++++----- .../punk/cap/handlers/templates-0.1.0.tm | 15 +- .../bootsupport/modules/punk/config-0.1.tm | 12 +- .../bootsupport/modules/punk/console-0.1.1.tm | 8 +- .../src/bootsupport/modules/punk/du-0.1.0.tm | 6 +- .../modules/punk/fileline-0.1.0.tm | 8 +- .../src/bootsupport/modules/punk/lib-0.1.1.tm | 26 +- .../modules/punk/mix/commandset/doc-0.1.0.tm | 3 +- .../punk/mix/commandset/layout-0.1.0.tm | 6 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 18 +- .../punk/mix/commandset/module-0.1.0.tm | 13 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 8 +- .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 34 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 421 +++++-- .../bootsupport/modules/punk/path-0.1.0.tm | 6 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 84 +- .../src/bootsupport/modules/punk/zip-0.1.1.tm | 19 +- .../bootsupport/modules/textblock-0.1.2.tm | 139 +- .../src/bootsupport/modules/overtype-1.6.5.tm | 27 +- .../src/bootsupport/modules/punk-0.1.tm | 15 +- .../bootsupport/modules/punk/ansi-0.1.1.tm | 145 ++- .../bootsupport/modules/punk/args-0.1.0.tm | 1114 ++++++++++++----- .../punk/cap/handlers/templates-0.1.0.tm | 15 +- .../bootsupport/modules/punk/config-0.1.tm | 12 +- .../bootsupport/modules/punk/console-0.1.1.tm | 8 +- .../src/bootsupport/modules/punk/du-0.1.0.tm | 6 +- .../modules/punk/fileline-0.1.0.tm | 8 +- .../src/bootsupport/modules/punk/lib-0.1.1.tm | 26 +- .../modules/punk/mix/commandset/doc-0.1.0.tm | 3 +- .../punk/mix/commandset/layout-0.1.0.tm | 6 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 18 +- .../punk/mix/commandset/module-0.1.0.tm | 13 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 8 +- .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 34 +- .../src/bootsupport/modules/punk/ns-0.1.0.tm | 421 +++++-- .../bootsupport/modules/punk/path-0.1.0.tm | 6 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 84 +- .../src/bootsupport/modules/punk/zip-0.1.1.tm | 19 +- .../bootsupport/modules/textblock-0.1.2.tm | 139 +- src/vendormodules/overtype-1.6.5.tm | 27 +- .../modules/argparsingtest-0.1.0.tm | 46 +- .../_vfscommon.vfs/modules/overtype-1.6.5.tm | 27 +- .../_vfscommon.vfs/modules/patternpunk-1.1.tm | 15 +- .../_vfscommon.vfs/modules/poshinfo-0.1.0.tm | 20 +- src/vfs/_vfscommon.vfs/modules/punk-0.1.tm | 15 +- .../_vfscommon.vfs/modules/punk/ansi-0.1.1.tm | 145 ++- .../_vfscommon.vfs/modules/punk/args-0.1.0.tm | 1114 ++++++++++++----- .../modules/punk/args/tclcore-0.1.0.tm | 494 ++++++-- .../modules/punk/blockletter-0.1.0.tm | 18 +- .../punk/cap/handlers/templates-0.1.0.tm | 15 +- .../_vfscommon.vfs/modules/punk/config-0.1.tm | 12 +- .../modules/punk/console-0.1.1.tm | 8 +- .../_vfscommon.vfs/modules/punk/du-0.1.0.tm | 6 +- .../modules/punk/fileline-0.1.0.tm | 8 +- .../_vfscommon.vfs/modules/punk/lib-0.1.1.tm | 26 +- .../modules/punk/mix/commandset/doc-0.1.0.tm | 3 +- .../punk/mix/commandset/layout-0.1.0.tm | 6 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 18 +- .../punk/mix/commandset/module-0.1.0.tm | 13 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 8 +- .../modules/punk/nav/fs-0.1.0.tm | 34 +- .../_vfscommon.vfs/modules/punk/ns-0.1.0.tm | 421 +++++-- .../_vfscommon.vfs/modules/punk/path-0.1.0.tm | 6 +- .../_vfscommon.vfs/modules/punk/repo-0.1.1.tm | 84 +- .../_vfscommon.vfs/modules/punk/safe-0.1.0.tm | 28 +- .../modules/punk/sixel-0.1.0.tm | 8 +- .../_vfscommon.vfs/modules/punk/zip-0.1.1.tm | 19 +- .../_vfscommon.vfs/modules/textblock-0.1.2.tm | 139 +- 119 files changed, 8289 insertions(+), 3597 deletions(-) diff --git a/src/bootsupport/modules/overtype-1.6.5.tm b/src/bootsupport/modules/overtype-1.6.5.tm index f0e34919..0d9cd0bc 100644 --- a/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/bootsupport/modules/overtype-1.6.5.tm @@ -402,7 +402,10 @@ tcl::namespace::eval overtype { set looplimit [expr {[tcl::string::length $overblock] + 10}] } - set scheme 3 + #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height + #lassign [blocksize $overblock] _w overblock_width _h overblock_height + + set scheme 4 switch -- $scheme { 0 { #one big chunk @@ -443,11 +446,18 @@ tcl::namespace::eval overtype { set inputchunks [lindex [list $lflines [unset lflines]] 0] } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks [string cat $ln \n] + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + } + } } - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height set replay_codes_underlay [tcl::dict::create 1 ""] @@ -495,7 +505,7 @@ tcl::namespace::eval overtype { } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderargs [list -experimental $opt_experimental\ + set renderopts [list -experimental $opt_experimental\ -cp437 $opt_cp437\ -info 1\ -crm_mode [tcl::dict::get $vtstate crm_mode]\ @@ -510,11 +520,8 @@ tcl::namespace::eval overtype { -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ - $undertext\ - $overtext\ ] - set LASTCALL $renderargs - set rinfo [renderline {*}$renderargs] + set rinfo [renderline {*}$renderopts $undertext $overtext] set instruction [tcl::dict::get $rinfo instruction] tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] @@ -1237,8 +1244,8 @@ tcl::namespace::eval overtype { append debugmsg "looplimit $looplimit reached\n" append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $LASTCALL -cursor_column]\n" + append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" + append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" tcl::dict::for {k v} $rinfo { append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n } diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index 9440ae9c..1a9ab766 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/modules/punk-0.1.tm @@ -306,10 +306,11 @@ namespace eval punk { #get last command result that was run through the repl proc ::punk::get_runchunk {args} { set argd [punk::args::get_dict { - *opts + @id -id ::punk::get_runchunk + @opts -1 -optional 1 -type none -2 -optional 1 -type none - *values -min 0 -max 0 + @values -min 0 -max 0 } $args] #todo - make this command run without truncating previous runchunks set runchunks [tsv::array names repl runchunks-*] @@ -7152,8 +7153,8 @@ namespace eval punk { } punk::args::definition { - *id punk::inspect - *proc -name punk::inspect -help\ + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. The raw value arguments (not options) are always returned to pass forward in the pipeline. @@ -7227,9 +7228,9 @@ namespace eval punk { Does not affect return value." -- -type none -help\ "End of options marker. - It is advisable to use this, as data in a pipeline may often being with -" + It is advisable to use this, as data in a pipeline may often begin with -" - *values -min 0 -max -1 + @values -min 0 -max -1 arg -type string -optional 1 -multiple 1 -help\ "value to display" } @@ -7261,7 +7262,7 @@ namespace eval punk { foreach {k v} $flags { if {$k ni [dict keys $defaults]} { #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" - punk::args::get_by_id punk::inspect $args + punk::args::get_by_id ::punk::inspect $args } } set opts [dict merge $defaults $flags] diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index 452092e7..a3f9c0b5 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -134,27 +134,27 @@ tcl::namespace::eval punk::ansi::class { } lappend ::punk::ansi::class::PUNKARGS [list { - *id "punk::ansi::class::class_ansi render_to_input_line" - *proc -name "punk::ansi::class::class_ansi render_to_input_line" -help\ + @id -id "::punk::ansi::class::class_ansi render_to_input_line" + @cmd -name "punk::ansi::class::class_ansi render_to_input_line" -help\ "render string from line 0 to line (experimental/debug)" -dimensions -type string -help\ "WxH where W is integer width >= 1 and H is integer heigth >= 1" -minus -type integer -help\ "number of chars to exclude from end" - *values -min 1 -max 1 + @values -min 1 -max 1 line -type indexexpression }] method render_to_input_line {args} { if {[llength $args] < 1} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set opts [tcl::dict::create\ -dimensions 80x24\ @@ -167,7 +167,7 @@ tcl::namespace::eval punk::ansi::class { } default { puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } } } @@ -588,20 +588,20 @@ tcl::namespace::eval punk::ansi { } lappend PUNKARGS [list -dynamic 1 { - *id punk::ansi::example - *proc -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console + @id -id ::punk::ansi::example + @cmd -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console " -colwidth -default 82 -help "Width of each column - default of 82 will fit a standard 80wide ansi image (when framed) You can specify a narrower width to truncate images on the right side" -folder -default "${[punk::ansi::Get_ansifolder]}" -help "Base folder for files if relative paths are used. Defaults to /src/testansi - where projectbase is determined from current directory. " - *values -min 0 -max -1 + @values -min 0 -max -1 files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help "List of filenames - leave empty to display 4 defaults" } ""] proc example {args} { - set argd [punk::args::get_by_id punk::ansi::example $args] + set argd [punk::args::get_by_id ::punk::ansi::example $args] set colwidth [dict get $argd opts -colwidth] set ansifolder [file normalize [dict get $argd opts -folder]] set fnames [dict get $argd values files] @@ -2355,21 +2355,21 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #sgr_cache clear called by punk::console::ansi when set to off #punk::args depends on punk::ansi - REVIEW + lappend PUNKARGS [list { + @id -id ::punk::ansi::sgr_cache + @cmd -name punk::ansi::sgr_cache -help\ + "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) + " + -action -default "" -choices "clear" -help\ + "-action clear will unset the keys in the punk::ansi::sgr_cache dict + This is called automatically when setting 'colour false' in the console" + + -pretty -default 1 -type boolean -help\ + "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" + @values -min 0 -max 0 + }] proc sgr_cache {args} { - set argdef { - *id punk::ansi::sgr_cache - *proc -name punk::ansi::sgr_cache -help\ - "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) - " - -action -default "" -choices "clear" -help\ - "-action clear will unset the keys in the punk::ansi::sgr_cache dict - This is called automatically when setting 'colour false' in the console" - - -pretty -default 1 -type boolean -help\ - "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" - *values -min 0 -max 0 - } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::get_by_id ::punk::ansi::sgr_cache $args] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] @@ -2412,34 +2412,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return [join $lines \n] } - lappend PUNKARGS [list { - *id punk::ansi::a+ - *proc -name "punk::ansi::a+" -help\ - "Returns an ANSI sgr escape sequence based on the list of supplied codes. - Unlike punk::ansi::a - it is not prefixed with an ANSI reset. - " - *values -min 0 -max -1 - } [string map [list [dict keys $SGR_map]] { - code -type string -optional 1 -multiple 1 -choices {} -choiceprefix 0 -choicerestricted 0 -help\ - "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. - A leading capital letter indicates a codename applies to the background colour. - Other accepted codes are: - term- Term- foreground/background where int is 0-255 terminal color - term- Term- foreground/background - rgb--- Rgb--- foreground/background where are the - 0-255 int values for red, green and blue. - rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 - web- Web- - - The acceptable values for and can be queried using - punk::ansi::a? term - and - punk::ansi::a? web - - Example to set foreground red and background cyan followed by a reset: - set str \"[a+ red Cyan]sample text[a]\" - " - }]] + #PUNKARGS doc performed below, after we create the proc proc a+ {args} { #*** !doctools #[call [fun a+] [opt {ansicode...}]] @@ -2907,6 +2880,41 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $result } + set SGR_samples [dict create] + foreach k [dict keys $SGR_map] { + dict set SGR_samples $k "[punk::ansi::a+ $k]sample\x1b\[m" + } + lappend PUNKARGS [list { + @id -id ::punk::ansi::a+ + @cmd -name "punk::ansi::a+" -help\ + "Returns an ANSI sgr escape sequence based on the list of supplied codes. + Unlike punk::ansi::a - it is not prefixed with an ANSI reset. + " + @values -min 0 -max -1 + } [string map [list [dict keys $SGR_map] $SGR_samples] { + code -type string -optional 1 -multiple 1 -choices {}\ + -choicelabels {}\ + -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ + "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. + A leading capital letter indicates a codename applies to the background colour. + Other accepted codes are: + term- Term- foreground/background where int is 0-255 terminal color + term- Term- foreground/background + rgb--- Rgb--- foreground/background where are the + 0-255 int values for red, green and blue. + rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 + web- Web- + + The acceptable values for and can be queried using + punk::ansi::a? term + and + punk::ansi::a? web + + Example to set foreground red and background cyan followed by a reset: + set str \"[a+ red Cyan]sample text[a]\" + " + }]] + proc a {args} { #*** !doctools #[call [fun a] [opt {ansicode...}]] @@ -4281,6 +4289,7 @@ tcl::namespace::eval punk::ansi { } 4 { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines + #e.g hyper on windows if {[llength $paramsplit] == 1} { tcl::dict::set codestate underline 4 } else { @@ -4634,6 +4643,8 @@ tcl::namespace::eval punk::ansi::ta { #[list_begin definitions] tcl::namespace::path ::punk::ansi + variable PUNKARGS + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position @@ -4706,15 +4717,31 @@ tcl::namespace::eval punk::ansi::ta { #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::ansi::ta::detect + @cmd -name punk::ansi::ta::detect -help\ + "Return a boolean indicating whether Ansi codes were detected in text. + Important caveat: + When text is a tcl list made from splitting (or lappending) some ansi string + - individual elements may be braced or have certain chars escaped. + (one example is if a list element contains an unbalanced brace) + This can cause square brackets that form part of the ansi to be backslash escaped + - and the function can fail to match it as an Ansi code. + " + @values -min 1 + text -type string + } ] + + #*** !doctools + #[call [fun detect] [arg text]] + #[para]Return a boolean indicating whether Ansi codes were detected in text + #[para]Important caveat: + #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) + #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match + #detect any ansi escapes #review - only detect 'complete' codes - or just use the opening escapes for performance? proc detect {text} [string map [list [list $re_ansi_detect]] { - #*** !doctools - #[call [fun detect] [arg text]] - #[para]Return a boolean indicating whether Ansi codes were detected in text - #[para]Important caveat: - #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) - #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match regexp $text }] @@ -7405,7 +7432,7 @@ if {![info exists ::punk::args::register::NAMESPACES]} { set NAMESPACES [list] } } -lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class +lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class ::punk::ansi::ta # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.0.tm index 5a589fe3..2c9c77fa 100644 --- a/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/bootsupport/modules/punk/args-0.1.0.tm @@ -50,14 +50,14 @@ #[example { # proc dofilestuff {args} { # lassign [dict values [punk::args::get_dict { -# *proc -help "do some stuff with files e.g dofilestuff " -# *opts -type string +# @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 +# @values -min 1 -max -1 # } $args]] leaders opts values # # puts "translation is [dict get $opts -translation]" @@ -67,8 +67,8 @@ # } #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for *values -#[para]valid * lines being with *proc *leaders *opts *values +#[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: @@ -81,7 +81,7 @@ # -directory -default "" # -translation -default binary # -nocomplain -type none -# *values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 # } $args]] leaders opts values @@ -89,7 +89,7 @@ # 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]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 @@ -279,11 +279,140 @@ tcl::namespace::eval punk::args { #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 - lappend PUNKARGS [list { - *id punk::args::definition - *proc -name punk::args::definition -help\ + 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::definition + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::definition -help\ "Accepts a line-based definition of command arguments. - The definition should usually contain a line of the form: *id someid + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + options: -id + %B%@cmd%N% ?opt val...? + options -name -help + %B%@leaders%N% ?opt val...? + options -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + options -any + %B%@values%N% ?opt val...? + options -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + options -header (text for header row of table) + -body (text to replace entirety of autogenerated docs) + %B%@doc%N% ?opt val...? + options -name -url + + 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 + 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 value or option. + + 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 options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + -default + -multiple (for leaders & values defines whether + subsequent received values are stored agains the same + argument name - only applies to final leader or value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - no necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -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\} @@ -292,20 +421,20 @@ tcl::namespace::eval punk::args { 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 not usually significant, perhaps on the order of a few hundred uS, - but -dynamic true might be less desirable if the command is used in inner - loops in more performance-sensitive code. + 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 + @values -min 1 -max -1 text -type string -multiple 1 -help\ "Block(s) of text representing the argument specification 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. - e.g + e.g the following definition passes 2 blocks as text arguments definition { - *id myns::myfunc - *proc -name myns::myfunc -help\\ + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ \"Description of command\" #The following option defines an option-value pair @@ -314,13 +443,13 @@ tcl::namespace::eval punk::args { -flag1 -default 0 -type none -help\\ \"Info about flag1\" - *values -min 1 -max -1 + @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 definition {args} { variable argdata_cache variable argdefcache_by_id @@ -482,6 +611,7 @@ tcl::namespace::eval punk::args { 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]} { @@ -522,9 +652,10 @@ tcl::namespace::eval punk::args { set linebuild "" } } - set proc_info {} + set cmd_info {} set id_info {} ;#e.g -children ?? set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table set parser_info {} set leader_min "" #set leader_min 0 @@ -543,27 +674,50 @@ tcl::namespace::eval punk::args { "" - # {continue} } set linespecs [lassign $trimln argname] - if {$argname ne "*id" && [llength $linespecs] % 2} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs'" + if {[llength $linespecs] % 2 != 0} { + error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" } set firstchar [tcl::string::index $argname 0] set secondchar [tcl::string::index $argname 1] - if {$firstchar eq "*" && $secondchar ne "*"} { - set starspecs $linespecs + if {$firstchar eq "@" && $secondchar ne "@"} { + set at_specs $linespecs + switch -- [tcl::string::range $argname 1 end] { id { - #id line must have single entry - a unique id assigned by the user - an id will be allocated if no id line present or the value is "auto" - if {[llength $starspecs] == 0} { - error "punk::args::definition - *id line must have at least a single entry following *id." - } + #id An id will be allocated if no id line present or the -id value is "auto" if {$spec_id ne ""} { - #disallow duplicate *id line - error "punk::args::definition - *id already set. Existing value $spec_id" + #disallow duplicate @id line + error "punk::args::definition - @id already set. Existing value $spec_id" } - set spec_id [lindex $starspecs 0] - set id_info [lrange $starspecs 1 end] - if {[llength $id_info] %2} { - error "punk::args::definition - bad *id line. Remaining items on line after *id must be in paired option-value format - received '$linespecs'" + if {[dict exists $at_specs -id]} { + set spec_id [dict get $at_specs -id] + } else { + set spec_id auto + } + set id_info $at_specs + } + default { + #copy from an identified set of defaults (another argspec id) can be multiple + if {[dict exists $at_specs -id]} { + set copyfrom [get_def [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] + } + 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??? + } } } parser { @@ -596,27 +750,32 @@ tcl::namespace::eval punk::args { # 1 anykeys {0 info} # } #todo - set parser_info $starspecs + set parser_info $at_specs } - proc { + cmd { #allow arbitrary - review - set proc_info $starspecs + set cmd_info [dict merge $cmd_info $at_specs] } doc { - set doc_info $starspecs + 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 { if {$argspace eq "values"} { - error "punk::args::definition - *opts declaration must come before *values - received '$linespecs'" + error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" } set argspace "options" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -any - -anyopts { set opt_any $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } @@ -662,26 +821,26 @@ tcl::namespace::eval punk::args { tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *opts line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } } } leaders { if {$argspace in [list options values]} { - error "punk::args::definition - *leaders declaration must come before all options and values" + error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" } - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" } set leader_min $v #if {$leader_max == 0} { @@ -691,15 +850,16 @@ tcl::namespace::eval punk::args { -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" } set leader_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set leaderspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset leaderspec_defaults $k2 @@ -741,12 +901,12 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *leaders line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } } @@ -754,27 +914,28 @@ tcl::namespace::eval punk::args { } values { set argspace "values" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" } set val_min $v } -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" } set val_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset valspec_defaults $k2 @@ -816,19 +977,19 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *values line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } } } default { - error "punk::args::definition - unrecognised * line in '$ln'. Expected *proc *leaders *opts or *values - use **name if paramname needs to be *name" + error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" } } continue @@ -836,15 +997,15 @@ tcl::namespace::eval punk::args { if {$argspace eq "leaders"} { set argspace "options" } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before *values" + error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" } set argspecs $linespecs tcl::dict::set argspecs -ARGTYPE option lappend opt_names $argname set is_opt 1 } else { - if {$firstchar eq "*"} { - #allow basic ** escaping for literal argname that begins with * + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } set argspecs $linespecs @@ -898,7 +1059,7 @@ tcl::namespace::eval punk::args { lappend opt_solos $argname } else { #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname'" + error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } } any - anything { @@ -916,18 +1077,18 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choiceprefix - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -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 + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines #review -solo 1 vs -type none ? conflicting values? tcl::dict::set spec_merged $spec $specval } -validationtransform { #string is dict only 8.7/9+ if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary" + error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" } dict for {tk tv} $specval { switch -- $tk { @@ -935,18 +1096,18 @@ tcl::namespace::eval punk::args { } default { set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys" + error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" } } } } default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choiceprefix -choicerestricted\ + set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" + error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" } } } @@ -983,6 +1144,11 @@ tcl::namespace::eval punk::args { } } + if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + variable id_counter + set spec_id "autoid_[incr id_counter]" + } + # REVIEW #if {[llength $val_names] || $val_min > 0} { # #some values are specified @@ -995,23 +1161,19 @@ tcl::namespace::eval punk::args { #no values specified - we can allow last leader to be multiple foreach leadername [lrange $leader_names 0 end-1] { if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple" + error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" } } #} #confirm any valnames before last don't have -multiple key foreach valname [lrange $val_names 0 end-1] { if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple" + error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" } } - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { - variable id_counter - set spec_id "autoid_[incr id_counter]" - } - #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) + #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) set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize @@ -1043,8 +1205,9 @@ tcl::namespace::eval punk::args { val_max $val_max\ valspec_defaults $valspec_defaults\ val_checks_defaults $val_checks_defaults\ - proc_info $proc_info\ + cmd_info $cmd_info\ doc_info $doc_info\ + argdisplay_info $argdisplay_info\ id_info $id_info\ ] tcl::dict::set argdata_cache $cache_key $argdata_dict @@ -1081,7 +1244,6 @@ tcl::namespace::eval punk::args { return $result } } - return } proc get_spec_values {id {patternlist *}} { variable argdefcache_by_id @@ -1098,6 +1260,7 @@ tcl::namespace::eval punk::args { set def [dict remove $def -ARGTYPE] append result \n "$v $def" } + return $result } else { foreach pat $patternlist { set matches [dict keys $arg_info $pat] @@ -1111,19 +1274,28 @@ tcl::namespace::eval punk::args { return $result } } - return } #proc get_spec_leaders ?? #proc get_spec_opts ?? + proc get_def {id} { + if {[id_exists $id]} { + return [definition {*}[get_spec $id]] + } + } + proc is_dynamic {id} { + set spec [get_spec $id] + return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ] + } + variable aliases set aliases [dict create] lappend PUNKARGS [list { - *id punk::args::get_ids - *proc -name punk::args::get_ids -help\ + @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 + @values -min 0 -max 1 match -default * -help\ "exact id or glob pattern for ids" }] @@ -1182,23 +1354,37 @@ tcl::namespace::eval punk::args { set loaded_packages [list] proc update_definitions {} { + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - get's 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 variable loaded_packages upvar ::punk::args::register::NAMESPACES pkgs if {[llength $loaded_packages] == [llength $pkgs]} { #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. return {} } + # -- --- --- --- --- --- + set unloaded [punklib_ldiff $pkgs $loaded_packages] set newloaded [list] foreach pkgns $unloaded { + #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { foreach deflist [set ${pkgns}::PUNKARGS] { namespace eval $pkgns [list punk::args::definition {*}$deflist] } } + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } } errMsg]} { - lappend loaded_pkgs $pkgns + lappend loaded_packages $pkgns lappend newloaded $pkgns } else { puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" @@ -1273,7 +1459,8 @@ tcl::namespace::eval punk::args { set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error dict for {k v} $args { - switch -- $k { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + switch -- $fullk { -badarg { set badarg $v } @@ -1285,7 +1472,7 @@ tcl::namespace::eval punk::args { set as_error $v } -return { - if {$v ni {string table tableobject}} { + 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" } @@ -1293,7 +1480,7 @@ tcl::namespace::eval punk::args { } default { set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return" + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" } } } @@ -1328,14 +1515,22 @@ tcl::namespace::eval punk::args { append errmsg \n } } - set procname [Dict_getdef $spec_dict proc_info -name ""] - set prochelp [Dict_getdef $spec_dict proc_info -help ""] + set procname [Dict_getdef $spec_dict cmd_info -name ""] + set prochelp [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 ""] + set blank_header_col [list] if {$procname ne ""} { lappend blank_header_col "" set procname_display [a+ brightwhite]$procname[a] @@ -1344,7 +1539,8 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { lappend blank_header_col "" - set prochelp_display [a+ brightwhite]$prochelp[a] + #set prochelp_display [a+ brightwhite]$prochelp[a] + set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] } else { set prochelp_display "" } @@ -1354,18 +1550,32 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } if {$use_table} { set t [textblock::class::table new [a+ brightyellow]Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $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 {$procname ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] } else { lappend errlines "PROC/METHOD: $procname_display" } @@ -1373,7 +1583,7 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] } else { lappend errlines "Description: $prochelp_display" } @@ -1384,225 +1594,352 @@ tcl::namespace::eval punk::args { set docurl [punk::ansi::hyperlink $docurl] } if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display] + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] } else { lappend errlines "$docname $docurl_display" } incr h } if {$use_table} { - $t configure_header $h -values {Arg Type Default Multi Help} + 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-- " } - - set RST [a] - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + 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_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] - $trie destroy - foreach c [dict get $spec_dict opt_names] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } + + set RST [a] + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG [a+ brightred] + set greencheck [a+ brightgreen]\u2713[a] ;#green tick + set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX [a+ green] ;#use a+ so colour off can apply + if {$A_PREFIX eq ""} { + 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 opt_names [dict get $spec_dict opt_names] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict opt_names]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } } else { - set default "" + set opt_names [dict get $spec_dict opt_names] + set opt_names_display $opt_names } - set help [Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" + } + set leading_val_names [dict get $spec_dict leader_names] + set trailing_val_names [dict get $spec_dict val_names] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { - set casemsg " (case sensitive)" + set default "" } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices } else { - set prefixmsg "" + set choicegroups [dict merge [dict create "" $choices] $choicegroups] } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [list] - append help " Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } } - lappend formattedchoices $cdisplay + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] } } else { - set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - set prefix $c - set tail "" + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] + set formattedchoices $choicegroups } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + + } + } + 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 [a+ cyan]$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + #bold as well as brightcolour in case colour off. + append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + } else { + append help \n + } + append help \n [join $formatted \n] } - lappend formattedchoices $cdisplay - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + } 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 "" " [a+ red](no choices defined for main group)[a]" + } else { + dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + } + } else { + if {$groupname eq ""} { + append help \n " " [a+ red](no choices defined)[a] + } else { + append help \n " " [a+ red](no choices defined for group $groupname)[a] } - lappend formattedchoices $cdisplay } + } + } + 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]} { + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" } else { - set formattedchoices [dict get $arginfo -choices] + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" } - } } - set numcols 4 ;#todo - dynamic? - if {[llength $formattedchoices] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formattedchoices] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices] - append help \n[textblock::join -- " " $choicetable] - } else { - append help \n [join $formattedchoices \n] - } + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck } 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. - append help \n " " [a+ red](no choices defined)[a] + set multiple "" } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - 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]} { + 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 {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - 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 + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow[a] TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - lappend errlines "$argshow TYPE:$typeshow DEFAULT:$default MULTI:$multiple HELP:$help\n" } } - } + } ;#end is_custom_argdisplay if {$use_table} { $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] $t configure -maxwidth 80 ;#review - append errmsg [$t print] if {$returntype ne "tableobject"} { + append errmsg [$t print] #returntype of table means just the text of the table $t destroy } @@ -1640,19 +1977,26 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::usage - *proc -name punk::args::usage -help\ - "return usage information as a string - in table form." + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command. + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and not have an id. + 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 this as necessary. + " -return -default table -choices {string table tableobject} - *values -min 0 -max 1 + @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::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] set speclist [get_spec $id] if {[llength $speclist] == 0} { @@ -1662,9 +2006,9 @@ tcl::namespace::eval punk::args { } lappend PUNKARGS [list { - *id punk::args::get_by_id - *proc -name punk::args::get_by_id - *values -min 1 + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 id arglist -default "" -type list -help\ "list containing arguments to be parsed as per the @@ -1703,8 +2047,8 @@ tcl::namespace::eval punk::args { #[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 *proc *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. + #[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. @@ -1713,12 +2057,12 @@ tcl::namespace::eval punk::args { #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { - # *opts + # @opts # -opt1 -default {} # -opt2 -default { # etc # } - # *values -multiple 1 + # @values -multiple 1 #} $args #if {[llength $args] == 0} { @@ -2014,7 +2358,7 @@ tcl::namespace::eval punk::args { } if {$opt_any} { set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $opt_checks_defaults if {[tcl::dict::get $arg_info $a -type] ne "none"} { @@ -2023,7 +2367,6 @@ tcl::namespace::eval punk::args { } else { tcl::dict::set opts $a $newval } - lappend flagsreceived $a ;#adhoc flag as supplied if {[incr i] > $maxidx} { arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a } @@ -2041,11 +2384,12 @@ tcl::namespace::eval punk::args { } incr vals_remaining_possible -1 } + lappend flagsreceived $a ;#adhoc flag as supplied } else { if {[llength $opt_names]} { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while *opts -any 0" + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } arg_error $errmsg $argspecs -badarg $fullopt } @@ -2096,6 +2440,7 @@ tcl::namespace::eval punk::args { } 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 arg_info $positionalidx $leaderspec_defaults @@ -2132,7 +2477,8 @@ tcl::namespace::eval punk::args { } else { if {$in_multiple ne ""} { tcl::dict::lappend values_dict $in_multiple $val - #name already seen + #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 arg_info $positionalidx $valspec_defaults @@ -2228,7 +2574,7 @@ tcl::namespace::eval punk::args { set defaultval [tcl::dict::get $thisarg -default] } set type [tcl::dict::get $thisarg -type] - set has_choices [tcl::dict::exists $thisarg -choices] + 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] @@ -2259,10 +2605,22 @@ tcl::namespace::eval punk::args { if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set nocase [tcl::dict::get $thisarg -nocase] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + 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 clist} $choicegroups { + lappend allchoices {*}$clist + } + } + #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 @@ -2275,7 +2633,7 @@ tcl::namespace::eval punk::args { } } set idx 0 ;# - #opts/values_dict $argname membmer has been populated with the actual entered choices - which might be prefixes + #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] @@ -2283,44 +2641,95 @@ tcl::namespace::eval punk::args { foreach e $vlist e_check $vlist_check { if {$nocase} { set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $choices] + 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 $e_check] } else { set casemsg " (case sensitive)" set v_test $e_check - set choices_test $choices + set choices_test $allchoices } set choice_in_list 0 set matches_default [expr {$has_default && $e eq $defaultval}] if {!$matches_default} { if {$choiceprefix} { - set chosen [tcl::prefix::match -error "" $choices_test $v_test] - if {$chosen ne ""} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$e_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $e_check set choice_in_list 1 - #can we handle empty string as a choice? It should just work - REVIEW/test - #must use exact in case glob chars present e.g * ? [] (also ansi has square brackets) - set choice [lsearch -exact -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + set chosen $v_test + 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] $e_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + set choice_in_list [expr {$chosen ne ""}] + #we + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $e_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 "" + } + } + + if {$choice_in_list && !$choice_exact_match} { if {$is_multiple} { set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $choice + lset existing $idx $chosen tcl::dict::set $dname $argname $existing } else { - tcl::dict::set $dname $argname $choice + tcl::dict::set $dname $argname $chosen } } } 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 - } + #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 $e lappend vlist_check_validate $e_check } else { @@ -2330,13 +2739,13 @@ tcl::namespace::eval punk::args { } else { set prefixmsg "" } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname } } 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 + #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 } @@ -2354,7 +2763,7 @@ tcl::namespace::eval punk::args { 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 + #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 @@ -2376,7 +2785,7 @@ tcl::namespace::eval punk::args { #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 + #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 { @@ -2690,6 +3099,10 @@ tcl::namespace::eval punk::args { } 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] } @@ -2702,12 +3115,12 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::TEST - *opts -optional 0 + @id -id ::punk::args::TEST + @opts -optional 0 -o1 -default 111 -help "opt 1 mandatory" - *opts -optional 1 + @opts -optional 1 -o2 -default 222 -help "opt 2 optional" - *values -min 0 -max 1 + @values -min 0 -max 1 v -help\ "v1 optional" }] @@ -2762,16 +3175,18 @@ tcl::namespace::eval punk::args::lib { #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 punk::args::lib::tstr - *proc -name punk::args::lib::tstr -help\ + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ "A rough equivalent of js template literals" -allowcommands -default 0 -type none -help\ - "if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "if -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" -return -default list -choices {dict list string args}\ -choicelabels { dict\ "Return a dict with keys - 'template' and 'params'" + 'template', 'params' and + 'errors'" string\ "Return a single result being the string with @@ -2791,7 +3206,7 @@ tcl::namespace::eval punk::args::lib { args\ "Return a list where the first element is a list of template - plaintext secions as per the + plaintext sections as per the 'list' return mechanism, but the placeholder items are individual items in the returned list. @@ -2808,7 +3223,7 @@ tcl::namespace::eval punk::args::lib { contained variables in that case should be braced, 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 + @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 @@ -2820,7 +3235,7 @@ tcl::namespace::eval punk::args::lib { 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 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] @@ -2838,7 +3253,12 @@ tcl::namespace::eval punk::args::lib { dict set opts -allowcommands 1 } if {[llength $arglist] % 2 != 0} { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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 -return -eval} $k] @@ -2847,12 +3267,20 @@ tcl::namespace::eval punk::args::lib { dict set opts $fullk $v } default { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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_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] @@ -2871,6 +3299,7 @@ tcl::namespace::eval punk::args::lib { #set expressions [list] set params [list] set idx 0 + set errors [dict create] foreach {pt expression} $parts { lappend textchunks $pt incr idx ;#pt incr @@ -2881,17 +3310,32 @@ tcl::namespace::eval punk::args::lib { } #lappend expressions $expression if {$opt_eval} { - lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] } else { lappend params $expression } incr idx ;#expression incr } - switch -- $opt_return { - dict { - return [dict create template $textchunks params $params] + + 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 } + puts stderr "tstr errors:\n$einfo\n]" + } + + switch -- $opt_return { list { return [list $textchunks $params] } @@ -2906,20 +3350,18 @@ tcl::namespace::eval punk::args::lib { } return $out } - default { - } } } #test single placeholder tstr args where single placeholder must be an int proc tstr_test_one {args} { set argd [punk::args::get_dict { - *proc -name tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + @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 + @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" 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 eacc6619..5624ec58 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 @@ -254,8 +254,9 @@ namespace eval punk::cap::handlers::templates { } method folders {args} { set argd [punk::args::get_dict { + @id -id "::punk::cap::handlers::templates::class::api folders" -startdir -default "" - *values -max 0 + @values -max 0 } $args] set opts [dict get $argd opts] @@ -471,10 +472,11 @@ namespace eval punk::cap::handlers::templates { } method get_itemdict_projectlayouts {args} { set argd [punk::args::get_dict { - *opts -anyopts 1 + @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 + @values -maxvalues -1 } $args] set opt_startdir [dict get $argd opts -startdir] @@ -648,14 +650,15 @@ namespace eval punk::cap::handlers::templates { #and a name determining command -command_get_item_name method _get_itemdict {args} { set argd [punk::args::get_dict { - *proc -name _get_itemdict - *opts -anyopts 0 + @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 + @values -maxvalues -1 globsearches -default * -multiple 1 } $args] set opts [dict get $argd opts] diff --git a/src/bootsupport/modules/punk/config-0.1.tm b/src/bootsupport/modules/punk/config-0.1.tm index 493ea5aa..fbce0905 100644 --- a/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/bootsupport/modules/punk/config-0.1.tm @@ -362,10 +362,10 @@ tcl::namespace::eval punk::config { proc configure {args} { set argdef { - *id punk::config::configure - *proc -name punk::config::configure -help\ + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ "UNIMPLEMENTED" - *values -min 1 -max 1 + @values -min 1 -max 1 whichconfig -type string -choices {startup running stop} } set argd [punk::args::get_dict $argdef $args] @@ -388,15 +388,15 @@ tcl::namespace::eval punk::config { #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration proc copy {args} { set argdef { - *id punk::config::copy - *proc -name punk::config::copy -help\ + @id -id ::punk::config::copy + @cmd -name punk::config::copy -help\ "Copy a partial or full configuration from one config to another If a target config has additional settings, then the source config can be considered to be partial with regards to the target. " -type -default "" -choices {replace merge} -help\ "Defaults to merge when target is running-config Defaults to replace when source is running-config" - *values -min 2 -max 2 + @values -min 2 -max 2 fromconfig -help\ "running or startup or file name (not fully implemented)" toconfig -help\ diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index c27503c3..d2c08e8b 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -875,7 +875,7 @@ namespace eval punk::console { } } - punk::args::set_alias punk::console::code_a+ punk::ansi::a+ + punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ proc code_a+ {args} { variable ansi_wanted if {$ansi_wanted <= 0} { @@ -1187,14 +1187,14 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::definition { - *id punk::console::cell_size + @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list - *values -min 0 -max 1 + @values -min 0 -max 1 newsize -default "" -help\ "character cell pixel dimensions WxH" } proc cell_size {args} { - set argd [punk::args::get_by_id punk::console::cell_size $args] + set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] set newsize [dict get $argd values newsize] diff --git a/src/bootsupport/modules/punk/du-0.1.0.tm b/src/bootsupport/modules/punk/du-0.1.0.tm index 9f74d2d5..adb47eff 100644 --- a/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/bootsupport/modules/punk/du-0.1.0.tm @@ -563,9 +563,10 @@ namespace eval punk::du { variable win_reparse_tags_by_int set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" } $args] set opts [dict get $argd opts] @@ -621,10 +622,11 @@ namespace eval punk::du { proc attributes_twapi {args} { set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" } $args] set opts [dict get $argd opts] diff --git a/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/bootsupport/modules/punk/fileline-0.1.0.tm index 04f3487b..6de20bff 100644 --- a/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -1252,14 +1252,14 @@ namespace eval punk::fileline { #[list_begin definitions] punk::args::definition { - *id punk::fileline::get_textinfo - *proc -name punk::fileline::get_textinfo -help\ + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" -file -default {} -type existingfile -translation -default iso8859-1 -encoding -default "\uFFFF" -includebom -default 0 - *values -min 0 -max 1 + @values -min 0 -max 1 } proc get_textinfo {args} { #*** !doctools @@ -1276,7 +1276,7 @@ namespace eval punk::fileline { #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. - lassign [dict values [punk::args::get_by_id punk::fileline::get_textinfo $args]] opts values + lassign [dict values [punk::args::get_by_id ::punk::fileline::get_textinfo $args]] opts values # -- --- --- --- set opt_file [dict get $opts -file] set opt_translation [dict get $opts -translation] diff --git a/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/bootsupport/modules/punk/lib-0.1.1.tm index 6fabbba7..353d1f65 100644 --- a/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -1009,13 +1009,13 @@ namespace eval punk::lib { set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " } set argspec [string map [list %sep% $sep] { - *id punk::lib::pdict - *proc -name pdict -help\ + @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 + @opts -any 1 #default separator to provide similarity to tcl's parray function -separator -default "%sep%" @@ -1023,7 +1023,7 @@ namespace eval punk::lib { -substructure -default {} -channel -default stdout -help "existing channel - or 'none' to return as string" - *values -min 1 -max -1 + @values -min 1 -max -1 dictvar -type string -help "name of variable. Can be a dict, list or array" @@ -1095,14 +1095,16 @@ namespace eval punk::lib { package require textblock set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { - *id punk::lib::showdict - *proc -name punk::lib::showdict -help "display dictionary keys and values" + @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 - " + -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" @@ -1114,7 +1116,7 @@ namespace eval punk::lib { -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 + @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" }] $args] @@ -2816,7 +2818,7 @@ namespace eval punk::lib { #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 { -joinchar -default \n - *values -min 1 -max 1 + @values -min 1 -max 1 } $args]] leaders opts values puts "opts:$opts" puts "values:$values" @@ -2857,7 +2859,7 @@ namespace eval punk::lib { #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 { - *opts -any 1 + @opts -any 1 -block -default {} } $args]] leaderdict opts valuedict tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] 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 8d68b28a..6b1923b1 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 @@ -168,9 +168,10 @@ namespace eval punk::mix::commandset::doc { } proc validate {args} { set argd [punk::args::get_dict { + @id -id ::punk::mix::commandset::doc::validate -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 - *values -min 0 -max -1 + @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 } $args] set opt_individual [tcl::dict::get $argd opts -individual] 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 a31da91a..47c75d33 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 @@ -34,7 +34,8 @@ namespace eval punk::mix::commandset::layout { #per layout functions proc files {{layout ""}} { set argd [punk::args::get_dict { - *values -min 1 -max 1 + @id -id ::punk::mix::commandset::layout::files + @values -min 1 -max 1 layout -type string -minsize 1 } [list $layout]] @@ -88,7 +89,8 @@ namespace eval punk::mix::commandset::layout { proc _default {args} { punk::args::get_dict [subst { - *proc -name ::punk::mix::commandset::layout::collection::_default + @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 diff --git a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index f5a5491e..f427f29f 100644 --- a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -27,20 +27,24 @@ namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs punk::args::definition { - *id punk::mix::commandset::loadedlib::search - *proc -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" + @id -id ::punk::mix::commandset::loadedlib::search + @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} -present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\ - "(unimplemented) Display only those that are 0:absent 1:present 2:both" - -highlight -type boolean -default 1 -help "Highlight which version is present with ansi underline and colour" + "(unimplemented) Display only those that are 0:absent 1:present 2:either" + -highlight -type boolean -default 1 -help\ + "Highlight which version is present with ansi underline and colour" -refresh -default 0 -type boolean -help "Re-scan the tm and library folders" searchstrings -default * -multiple 1 -help\ "Names to search for, may contain glob chars (* ?) e.g *lib* If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. - eg name -> *name*" + eg name -> *name* + To search for an exact name prefix it with = + e.g =name -> name + " } proc search {args} { - set argd [punk::args::get_by_id punk::mix::commandset::loadedlib::search $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::loadedlib::search $args] set searchstrings [dict get $argd values searchstrings] set opts [dict get $argd opts] set opt_return [dict get $opts -return] @@ -55,7 +59,7 @@ namespace eval punk::mix::commandset::loadedlib { set packages [package names] set matches [list] foreach search $searchstrings { - if {[regexp {[?*]} $search]} { + if {[regexp {[?*\[]} $search]} { #caller has specified specific glob pattern - use it #todo - respect supplied case only if uppers present? require another flag? lappend matches {*}[lsearch -all -inline -nocase $packages $search] diff --git a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 44627536..2079eb8c 100644 --- a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -123,10 +123,11 @@ namespace eval punk::mix::commandset::module { #return all module templates with repeated ones suffixed with .2 .3 etc proc templates_dict {args} { set argspec { - *proc -name templates_dict -help "Templates from module and project paths" + @id -id ::punk::mix::commandset::module::templates_dict + @cmd -name templates_dict -help "Templates from module and project paths" -startdir -default "" -help "Project folder used in addition to module paths" -not -default "" -multiple 1 - *values + @values globsearches -default * -multiple 1 } set argd [punk::args::get_dict $argspec $args] @@ -141,8 +142,8 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] punk::args::definition [subst { - *id punk::mix::commandset::module::new - *proc -name "punk::mix::commandset::module::new" -help\ + @id -id ::punk::mix::commandset::module::new + @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. If the name given in the module argument is namespaced, the necessary subfolder(s) will be used or created." @@ -160,7 +161,7 @@ namespace eval punk::mix::commandset::module { If false (default) an error will be raised if there is a conflict." -quiet -default 0 -type boolean -help\ "Suppress information messages on stdout" - *values -min 1 -max 1 + @values -min 1 -max 1 module -type string -help\ "Name of module, possibly including a namespace and/or version number e.g mynamespace::mymodule-1.0" @@ -168,7 +169,7 @@ namespace eval punk::mix::commandset::module { proc new {args} { set year [clock format [clock seconds] -format %Y] # use \uFFFD because unicode replacement char should consistently render as 1 wide - set argd [punk::args::get_by_id punk::mix::commandset::module::new $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::module::new $args] lassign [dict values $argd] leaders opts values received set module [dict get $values module] 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 65a9fb77..98f171c7 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 @@ -1262,15 +1262,15 @@ namespace eval punk::mix::commandset::scriptwrap { # [list_begin arguments] # [arg_def string args] name-value pairs -scriptpath # [list_end] - *id punk::mix::commandset::scriptwrap - *proc -name punk::mix::commandset::get_wrapper_folders + @id -id ::punk::mix::commandset::scriptwrap + @cmd -name punk::mix::commandset::get_wrapper_folders - *opts -anyopts 0 + @opts -anyopts 0 -scriptpath -default "" -type directory\ -help "" #todo -help folder within a punk.templates provided area??? - *values -minvalues 0 -maxvalues 0 + @values -minvalues 0 -maxvalues 0 } $args] # -- --- --- --- --- --- --- --- --- 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 159c6f37..3f5f3a71 100644 --- a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -636,13 +636,14 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles + -stripbase -default 1 -type boolean + -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" + @values -min 0 -max -1 + } proc dirfiles {args} { - set argspecs { - -stripbase -default 1 -type boolean - -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" - *values -min 0 -max -1 - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] @@ -726,14 +727,14 @@ tcl::namespace::eval punk::nav::fs { # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied proc dirfiles_dict {args} { set argspecs { - *id punk::nav::fs::dirfiles_dict - *opts -any 0 + @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 + @values -min 0 -max -1 -type string } set argd [punk::args::get_dict $argspecs $args] lassign [dict values $argd] leaders opts vals @@ -991,16 +992,17 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles_dict_as_lines + -stripbase -default 0 -type boolean + -formatsizes -default 1 -type boolean + @values -min 1 -max -1 -type dict + } + #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? proc dirfiles_dict_as_lines {args} { package require overtype - - set argspecs { - -stripbase -default 0 -type boolean - -formatsizes -default 1 -type boolean - *values -min 1 -max -1 -type dict - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles_dict_as_lines $args] lassign [dict values $argd] leaders opts vals set list_of_dicts [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 14b8f00d..f8a1e939 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -1608,7 +1608,7 @@ tcl::namespace::eval punk::ns { if {$word1 eq "punk::mix::base::_cli"} { #special case for punk deck - REVIEW #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set fq [lindex $tgt end] + set fq [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) @@ -1618,7 +1618,8 @@ tcl::namespace::eval punk::ns { set fq [nsjoin $location $c] } if {$has_punkargs} { - set id [string trimleft $fq :] + #set id [string trimleft $fq :] + set id $fq if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1892,110 +1893,188 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + if {[lsearch -exact $nscommands $querycommand] >= 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]] }]} { - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { #fully qualified command specified but doesn't exist - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { - set thispath [uplevel 1 [list ::nsthis $commandpath]] - set targetns [nsprefix $thispath] - set name [nstail $thispath] - set targetparts [nsparts $targetns] - if {[lsearch $targetparts :*] >=0} { - #weird ns - set valid_ns [nsexists $targetns] + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand } 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 commandpath 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 + set thispath [uplevel 1 [list ::nsthis $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 + set numvals [expr {[llength $queryargs]+1}] + #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]] + + #set origin $querycommand + #set resolved $querycommand + } - } else { - #namespace doesn't seem to exist - but there still could be documentation for lazy loaded ns and command - set origin $commandpath - set resolved $commandpath - } - } - #set thiscmd [nsjoin $targetns $name] - #if {[info commands $thiscmd] eq ""} { - # set origin $thiscmd - # set resolved $thiscmd - #} else { - # set origin [nseval $targetns [list ::namespace origin $name]] - # set resolved [nseval $targetns [list ::namespace which $name]] - #} + } + } #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! - #considure using which_alias (wiki) + #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 fq [lindex $tgt end] + 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 fq $word1 + set targetword $word1 + 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]] } - set origin $fq + + + set origin $targetword #retest cmdtype on modified origin set cmdtype [punk::ns::cmdtype $origin] } else { @@ -2013,6 +2092,83 @@ tcl::namespace::eval punk::ns { } } + + set id $origin + if {[info commands ::punk::args::id_exists] ne ""} { + #cycle through longest first checking for id matching ::cmd ?subcmd..? + #REVIEW - this doesn't cater for prefix callable subcommands! + set argcopy $queryargs + while {[llength $argcopy]} { + if {[punk::args::id_exists [list $id {*}$argcopy]]} { + return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$argcopy]]] + } + lpop argcopy + } + + #didn't find any exact matches + #traverse from other direction taking prefixes into account + + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set def [punk::args::get_def $id] + if {[llength $queryargs]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + foreach q $queryargs { + if {[llength [dict get $def leader_names]]} { + set subitems [dict get $def leader_names] + if {[llength $subitems]} { + set next [lindex $subitems 0] + set arginfo [dict get $def arg_info $next] + + 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 ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices {*}$clist + } + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + 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 numvals [expr {[llength $queryargs]+1}] + return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] + } + #check if subcommands so far have a custom args def + set currentid [list $querycommand {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set def [punk::args::get_def $currentid + } else { + #We can get no further with custom defs + break + } + } + } else { + #review + break + } + } + } else { + return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } + } + } + + if {[string match "(autodef)*" $origin]} { + #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) + set origin [string range $origin [string length (autodef)] end] + set resolved $origin + } + switch -- $cmdtype { object { #class is also an object @@ -2025,19 +2181,19 @@ tcl::namespace::eval punk::ns { #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - if {[llength $commandargs]} { - set c1 [lindex $commandargs 0] + if {[llength $queryargs]} { + set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { switch -- $c1 { new { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} new" - *proc -name "${$origin} new" -help\ + @id -id "(autodef)${$origin} new" + @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 { @@ -2054,17 +2210,17 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin new"] + return [punk::args::usage {*}$opts "(autodef)$origin new"] } create { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} create" - *proc -name "${$origin} create" -help\ + @id -id "(autodef)${$origin} create" + @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" }] @@ -2083,20 +2239,20 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin create"] + return [punk::args::usage {*}$opts "(autodef)$origin create"] } destroy { #review - generally no doc # but we may want notes about a specific destructor set argspec [punk::lib::tstr -return string { - *id "${$origin} destroy" - *proc -name "destroy" -help\ + @id -id "(audodef)${$origin} destroy" + @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." - *values -min 0 -max 0 + @values -min 0 -max 0 }] punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin destroy"] + return [punk::args::usage {*}$opts "(autodef)$origin destroy"] } default { #use info object call to resolve callchain @@ -2111,20 +2267,24 @@ tcl::namespace::eval punk::ns { lassign $impl generaltype mname location methodtype switch -- $generaltype { method - private { - + #objects being dynamic systems - we should always reinspect. + #Don't use the cached (autodef) def + #If there is a custom def override - use it (should really be -dynamic - but we don't check) if {$location eq "object"} { - set id "[string trimleft $origin :] $c1" ;# " " + set idcustom "$origin $c1" + #set id "[string trimleft $origin :] $c1" ;# " " if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info object definition $origin $c1] } else { - set id "[string trimleft $location :] $c1" ;# " " + #set id "[string trimleft $location :] $c1" ;# " " + set idcustom "$location $c1" if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info class definition $location $c1] @@ -2138,12 +2298,15 @@ tcl::namespace::eval punk::ns { } } if {$def ne ""} { + #assert - if we pre + set autoid "(autodef)$location $c1" set arglist [lindex $def 0] set argspec [punk::lib::tstr -return string { - *id "${$location} ${$c1}" - *proc -name "${$location} ${$c1}" -help\ - "arglist:${$arglist}" - *values + @id -id "${$autoid}" + @cmd -name "${$location} ${$c1}" -help\ + "(autogenerated) + arglist:${$arglist}" + @values }] set i 0 foreach a $arglist { @@ -2166,7 +2329,7 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$location $c1"] + return [punk::args::usage {*}$opts $autoid] } else { return "unable to resolve $origin method $c1" } @@ -2189,9 +2352,11 @@ tcl::namespace::eval punk::ns { switch -- $generaltype { method - private { if {$location eq "object"} { - set id "[string trimleft $origin :] $cmd" ;# " " + #set id "[string trimleft $origin :] $cmd" ;# " " + set id "$origin $cmd" } else { - set id "[string trimleft $location :] $cmd" ;# " " + #set id "[string trimleft $location :] $cmd" ;# " " + set id "$location $cmd" } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { @@ -2212,15 +2377,16 @@ tcl::namespace::eval punk::ns { set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" + set idauto "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -name "Object: ${$origin}" -help\ - "Instance of class: ${$class}" - *values -min 1 + @id -id ${$idauto} + @cmd -name "Object: ${$origin}" -help\ + "Instance of class: ${$class} (info autogenerated)" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $idauto] } privateObject { return "Command is a privateObject - no info currently available" @@ -2287,11 +2453,11 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] - if {[llength $commandargs]} { - set match [tcl::prefix::match $subcommands [lindex $commandargs 0]] + 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 $commandargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + 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") } } @@ -2307,9 +2473,9 @@ tcl::namespace::eval punk::ns { 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] + lappend have_usageinfo {*}[dict get $nsinfo usageinfo] + lappend is_ensemble {*}[dict get $nsinfo ensembles] + lappend is_object {*}[dict get $nsinfo ooobjects] } set choicelabeldict [dict create] @@ -2324,14 +2490,17 @@ tcl::namespace::eval punk::ns { } set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set autoid "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -help "ensemble: ${$origin}" - *values -min 1 + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + ensemble: ${$origin}" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2364,12 +2533,6 @@ tcl::namespace::eval punk::ns { } } - set id [string trimleft $origin :] - if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] - } - } set origin_ns [nsprefix $origin] set parts [nsparts $origin_ns] set weird_ns 0 @@ -2379,24 +2542,42 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set argl {} set tail [nstail $origin] - foreach a [nseval_ifexists $origin_ns [list info args $tail]] { - if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { - lappend a $def + set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] + if {$cmdtype eq "proc"} { + foreach a [nseval_ifexists $origin_ns [list info args $tail]] { + if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } else { - set argl {} - foreach a [info args $origin] { - if {[info default $origin $a def]} { - lappend a $def + set cmdtype [punk::ns::cmdtype $origin] + if {$cmdtype eq "proc"} { + set argl {} + set infoargs [info args $origin] + foreach a $infoargs { + if {[info default $origin $a def]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } - set msg "No argument processor detected" - append msg \n "function signature: $resolved $argl" + if {[llength $queryargs]} { + #todo - something better + set msg "Undocumented or nonexistant subcommand $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" + } else { + set msg "Undocumented command $origin. Type: $cmdtype" + } + } return $msg } @@ -2738,8 +2919,8 @@ tcl::namespace::eval punk::ns { interp alias "" use "" punk::ns::pkguse punk::args::definition { - *id punk::ns::nsimport_noclobber - *proc -name punk::ns::nsimport_noclobber -help\ + @id -id ::punk::ns::nsimport_noclobber + @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, or that specified in -targetnamespace. Return list of imported commands, ignores failures due to name conflicts" @@ -2750,14 +2931,14 @@ tcl::namespace::eval punk::ns { If not supplied, caller's namespace is used." -prefix -optional 1 -help\ "string prefix for command names in target namespace" - *values -min 1 -max 1 + @values -min 1 -max 1 sourcepattern -type string -optional 0 -help\ "Glob pattern for source namespace. Globbing only active in the tail segment. e.g ::mynamespace::*" } proc nsimport_noclobber {args} { - lassign [dict values [punk::args::get_by_id punk::ns::nsimport_noclobber $args]] leaders opts values received + lassign [dict values [punk::args::get_by_id ::punk::ns::nsimport_noclobber $args]] leaders opts values received set sourcepattern [dict get $values sourcepattern] set source_ns [tcl::namespace::qualifiers $sourcepattern] diff --git a/src/bootsupport/modules/punk/path-0.1.0.tm b/src/bootsupport/modules/punk/path-0.1.0.tm index d3431188..65ede7c8 100644 --- a/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/bootsupport/modules/punk/path-0.1.0.tm @@ -645,14 +645,14 @@ namespace eval punk::path { } punk::args::definition { - *id punk::path::treefilenames + @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." -call-depth-internal -default 0 -type integer -antiglob_paths -default {} -help\ "list of path patterns to exclude may include * and ** path segments e.g /usr/**" - *values -min 0 -max -1 -optional 1 -type string + @values -min 0 -max -1 -optional 1 -type string tailglobs -multiple 1 -help\ "Patterns to match against filename portion (last segment) of each file path within the directory tree being searched." @@ -671,7 +671,7 @@ namespace eval punk::path { #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para]no natsorting - so order is dependent on filesystem - set argd [punk::args::get_by_id punk::path::treefilenames $args] + set argd [punk::args::get_by_id ::punk::path::treefilenames $args] lassign [dict values $argd] leaders opts values received set tailglobs [dict values $values] # -- --- --- --- --- --- --- diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index 28a7271b..98bc04ef 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -62,6 +62,73 @@ package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- namespace eval punk::repo { + variable PUNKARGS + variable PUNKARGS_aliases + + proc get_fossil_usage {} { + set allcmds [runout -n fossil help -a] + set mainhelp [runout -n fossil help] + set maincommands [list] + foreach ln [split $mainhelp \n] { + set ln [string trim $ln] + if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { + continue + } + lappend maincommands {*}$ln + } + set othercmds [punk::lib::ldiff $allcmds $maincommands] + + set result "@leaders -min 0\n" + + append result [tstr -return string { + subcommand -type string -choicecolumns 8 -choicegroups { + "frequently used commands" {${$maincommands}} + "" {${$othercmds}} + } + }] + + return $result + } + + + #lappend PUNKARGS [list -dynamic 1 { + # @id -id ::punk::repo::fossil_proxy + # @cmd -name fossil -help "fossil executable + # " + # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # } ""] + + lappend PUNKARGS [list -dynamic 1 { + @id -id ::punk::repo::fossil_proxy + @cmd -name fossil -help "fossil executable" + ${[punk::repo::get_fossil_usage]} + } ] + + + + #experiment + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + #TODO + #lappend PUNKARGS [list -dynamic 1 { + # @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]}} + # } ""] + lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} + lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} + #Todo - investigate proper way to install a client-side commit hook in the fossil project #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used @@ -137,7 +204,7 @@ namespace eval punk::repo { puts stderr "fossil command not found. Please install fossil" } } - interp alias "" fossil "" punk::repo::fossil_proxy + # --- # Calling auto_execok on an external tool can be too slow to do during package load (e.g could be 150ms) @@ -153,6 +220,7 @@ namespace eval punk::repo { # ---------- # + #uppercase FOSSIL to bypass fossil as alias to fossil_proxy proc establish_FOSSIL {args} { if {![info exists ::auto_execs(FOSSIL)]} { @@ -161,7 +229,6 @@ namespace eval punk::repo { interp alias "" FOSSIL "" ;#delete establishment alias FOSSIL {*}$args } - interp alias "" FOSSIL "" punk::repo::establish_FOSSIL # ---------- proc askuser {question} { @@ -1577,6 +1644,8 @@ namespace eval punk::repo { } } + interp alias "" fossil "" punk::repo::fossil_proxy + interp alias "" FOSSIL "" punk::repo::establish_FOSSIL interp alias {} is_fossil {} ::punk::repo::is_fossil interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root @@ -1609,6 +1678,17 @@ namespace eval punk::repo::lib { } + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +if {![info exists ::punk::args::register::NAMESPACES]} { + namespace eval ::punk::args::register { + set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace + } +} +lappend ::punk::args::register::NAMESPACES ::punk::repo +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::repo [namespace eval punk::repo { diff --git a/src/bootsupport/modules/punk/zip-0.1.1.tm b/src/bootsupport/modules/punk/zip-0.1.1.tm index 311a8025..11ae9ab2 100644 --- a/src/bootsupport/modules/punk/zip-0.1.1.tm +++ b/src/bootsupport/modules/punk/zip-0.1.1.tm @@ -180,10 +180,11 @@ tcl::namespace::eval punk::zip { #}] set argd [punk::args::get_dict { - *proc -name punk::zip::walk + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -excludes -default "" -help "list of glob expressions to match against files and exclude" -subpath -default "" - *values -min 1 -max -1 + @values -min 1 -max -1 base fileglobs -default {*} -multiple 1 } $args] @@ -373,11 +374,12 @@ tcl::namespace::eval punk::zip { #[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 { - *proc -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + @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 + @opts -comment -default "" -help "An optional comment specific to the added file" - *values -min 3 -max 4 + @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" @@ -525,9 +527,10 @@ tcl::namespace::eval punk::zip { #[para] Call 'punk::zip::mkzip' with no arguments for usage display. set argd [punk::args::get_dict { - *proc -name punk::zip::mkzip\ + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ -help "Create a zip archive in 'filename'" - *opts + @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. @@ -557,7 +560,7 @@ tcl::namespace::eval punk::zip { it must be a parent of -directory or the same path as -directory" -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - *values -min 1 -max -1 + @values -min 1 -max -1 filename -type file -default ""\ -help "name of zipfile to create" globs -default {*} -multiple 1\ diff --git a/src/bootsupport/modules/textblock-0.1.2.tm b/src/bootsupport/modules/textblock-0.1.2.tm index 3651c0f0..dcc023ec 100644 --- a/src/bootsupport/modules/textblock-0.1.2.tm +++ b/src/bootsupport/modules/textblock-0.1.2.tm @@ -123,12 +123,12 @@ tcl::namespace::eval textblock { set choicemsg " (unavailable packages: $unavailable)" } set argd [punk::args::get_dict [tstr -return string { - *id textblock::use_hash - *proc -name "textblock::use_hash" -help\ + @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 + @values -min 0 -max 1 hash_algorithm -choices {${$choices}} -optional 1 -help\ "algorithm choice ${$choicemsg}" }] $args] @@ -423,7 +423,6 @@ tcl::namespace::eval textblock { } } } - my configure {*}$o_opts_table #foreach {k v} $args { # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. @@ -453,6 +452,7 @@ tcl::namespace::eval textblock { -minheight 1\ -maxheight ""\ ] + my configure {*}$o_opts_table } method width_algorithm {{alg ""}} { @@ -593,7 +593,7 @@ tcl::namespace::eval textblock { tcl::dict::set o_opts_table_effective -framelimits_header $hlims return [tcl::dict::create body $blims header $hlims] } - method configure args { + method configure {args} { #*** !doctools #[call class::table [method configure] [arg args]] #[para] get or set various table-level properties @@ -781,6 +781,14 @@ tcl::namespace::eval textblock { } } } + -title { + set twidth [punk::ansi::printing_length $v] + if {[my width] < [expr {$twidth+2}]} { + set o_calculated_column_widths [list] + tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] + } + tcl::dict::set o_opts_table -title $v + } default { tcl::dict::set o_opts_table $k $v } @@ -3943,14 +3951,13 @@ tcl::namespace::eval textblock { if {$header_build eq "" && ![llength $body_blocks]} { set header_build $nextcol_header - lappend body_blocks $nextcol_body } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] } - lappend body_blocks $nextcol_body #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } + lappend body_blocks $nextcol_body incr padwidth $bodywidth incr colposn } @@ -4096,8 +4103,8 @@ tcl::namespace::eval textblock { } punk::args::definition { - *id textblock::periodic - *proc -name textblock::periodic -help "A rudimentary periodic table + @id -id ::textblock::periodic + @cmd -name textblock::periodic -help "A rudimentary periodic table This is primarily a test of textblock::class::table" -return -default table\ @@ -4109,13 +4116,13 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id textblock::periodic $args] opts] + set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -4345,7 +4352,10 @@ tcl::namespace::eval textblock { set FRAMETYPES [textblock::frametypes] punk::args::definition [punk::lib::tstr -return string { - *id textblock::list_as_table + @id -id ::textblock::list_as_table + @cmd -name "textblock::list_as_table" -help\ + "Display a list in a bordered table + " -return -default table -choices {table tableobject} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ @@ -4376,13 +4386,13 @@ tcl::namespace::eval textblock { -help "Number of table columns Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 + @values -min 0 -max 1 datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" }] proc list_as_table {args} { set FRAMETYPES [textblock::frametypes] - set argd [punk::args::get_by_id textblock::list_as_table $args] + set argd [punk::args::get_by_id ::textblock::list_as_table $args] set opts [dict get $argd opts] set datalist [dict get $argd values datalist] @@ -4894,7 +4904,7 @@ tcl::namespace::eval textblock { #review!? #-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line - set usage "pad ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" + set usage "pad block ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" foreach {k v} $args { switch -- $k { -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { @@ -5420,16 +5430,21 @@ tcl::namespace::eval textblock { return [punk::lib::list_as_lines -- $outlines] } + + punk::args::definition { + @id -id ::textblock::join_basic + @cmd -name textblock::join_basic -help\ + "Join blocks of text 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 + " + -- -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 + } + #join without regard to each line length in a block (no padding added to make each block uniform) proc ::textblock::join_basic {args} { - #*proc -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 { - -- -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 argd [punk::args::get_by_id ::textblock::join_basic $args] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5466,7 +5481,7 @@ tcl::namespace::eval textblock { return [::join $outlines \n] } proc ::textblock::join_basic2 {args} { - #*proc -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + #@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 { @@ -6046,8 +6061,8 @@ tcl::namespace::eval textblock { if {$bad_option || [llength $values] == 0} { #no framedef supplied, or unrecognised opt seen set spec [string map [list $::textblock::frametypes] { - *id textblock::framedef - *proc -name textblock::framedef\ + @id -id ::textblock::framedef + @cmd -name textblock::framedef\ -help "Return a dict of the elements that make up a frame border. May return a subset of available elements based on memberglob values." @@ -6058,7 +6073,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - *values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -7438,17 +7453,17 @@ tcl::namespace::eval textblock { set frame_cache [tcl::dict::create] punk::args::definition { - *id textblock::frame_cache - *proc -name textblock::frame_cache -help\ + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ "Display or clear the frame cache." -action -default {} -choices {clear} -help\ "Clear the textblock::frame_cache dictionary" -pretty -default 1 -help\ "Use 'pdict textblock::frame_cache */*' for prettier output" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc frame_cache {args} { - set argd [punk::args::get_by_id textblock::frame_cache $args] + set argd [punk::args::get_by_id ::textblock::frame_cache $args] set action [dict get $argd opts -action] if {$action ni [list clear ""]} { @@ -7490,13 +7505,40 @@ tcl::namespace::eval textblock { } + variable FRAMETYPES set FRAMETYPES [textblock::frametypes] + variable EG set EG [a+ brightblack] + variable RST set RST [a] + + proc frame_samples {} { + set FRAMETYPELABELS [dict create] + if {[info commands ::textblock::frame] ne ""} { + foreach ft [frametypes] { + dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] + } + } + set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] + return $FRAMETYPELABELS + } + #proc EG {} "return {[a+ brightblack]}" + #make EG fetch from SGR cache so as to abide by colour off/on + proc EG {} { + a+ brightblack + } + #proc RST {} "return {\x1b\[m}" + proc RST {} { + return "\x1b\[m" + } + + #catch 22 for -choicelabels - need some sort of lazy evaluation + # ${[textblock::frame_samples]} + #todo punk::args alias for centre center etc? - punk::args::definition [punk::lib::tstr -return string { - *id textblock::frame - *proc -name "textblock::frame"\ + punk::args::definition -dynamic 1 { + @id -id ::textblock::frame + @cmd -name "textblock::frame"\ -help "Frame a block of text with a border." -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and @@ -7504,18 +7546,21 @@ tcl::namespace::eval textblock { Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." - -type -default light -choices {${$FRAMETYPES}} -choicerestricted 0 -type dict\ + -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ + -choicelabels { + ${[textblock::frame_samples]} + }\ -help "Type of border for frame." -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. passing an empty string will result in no box, but title/subtitle will still appear if supplied. - ${$EG}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${$RST}" + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. May contain ANSI - no trailing reset required. - ${$EG}e.g 1: frame -title My[a+ green]Green[a]Thing - e.g 2: frame -title [a+ red underline]MyThing${$RST}" + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" -subtitle -default "" -type string -regexprefail {\n}\ -help "Frame subtitle placed on bottombar - no newlines May contain Ansi - no trailing reset required." @@ -7526,8 +7571,8 @@ tcl::namespace::eval textblock { -help "Height of resulting frame including borders." -ansiborder -default "" -type ansistring\ -help "Ansi escape sequence to set border attributes. - ${$EG}e.g 1: frame -ansiborder [a+ web-red] contents - e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${$RST}" + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" -ansibase -default "" -type ansistring\ -help "Default ANSI attributes within frame." -blockalign -default centre -choices {left right centre}\ @@ -7547,13 +7592,13 @@ tcl::namespace::eval textblock { Frame width doesn't adapt and content may be truncated so -width may need to be manually set to display more." - *values -min 0 -max 1 + @values -min 0 -max 1 contents -default "" -type string\ -help "Frame contents - may be a block of text containing newlines and ANSI. Text may be 'ragged' - ie unequal line-lengths. No trailing ANSI reset required. - ${$EG}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${$RST}" - }] + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } #options before content argument - which is allowed to be absent #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. @@ -7638,7 +7683,7 @@ tcl::namespace::eval textblock { #only use punk::args if check_args is true or our basic checks failed #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { - set argd [punk::args::get_by_id textblock::frame $args] + set argd [punk::args::get_by_id ::textblock::frame $args] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8346,18 +8391,18 @@ tcl::namespace::eval textblock { } } punk::args::definition { - *id textblock::gcross + @id -id ::textblock::gcross -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block Only cross sizes that divide the size of the overall block will be used. e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. " - *values -min 0 -max 1 + @values -min 0 -max 1 size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id textblock::gcross $args] + set argd [punk::args::get_by_id ::textblock::gcross $args] set size [dict get $argd values size] set opts [dict get $argd opts] diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index d2849bf5..54aa05d7 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/src/modules/argparsingtest-999999.0a1.0.tm @@ -277,8 +277,9 @@ 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::get_dict { - *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" - *opts -anyopts 0 + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string -show_edge -default \uFFEF -type string @@ -290,15 +291,15 @@ namespace eval argparsingtest { -1 -default 1 -type boolean -2 -default 2 -type integer -3 -default 3 -type integer - *values + @values } $args] return [tcl::dict::get $argd opts] } punk::args::definition { - *id argparsingtest::test1_punkargs2 - *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" - *opts -anyopts 0 + @id -id ::test1_punkargs_by_id + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string -show_edge -default \uFFEF -type string @@ -310,18 +311,41 @@ namespace eval argparsingtest { -1 -default 1 -type boolean -2 -default 2 -type integer -3 -default 3 -type integer - *values + @values + } + proc test1_punkargs_by_id {args} { + set argd [punk::args::get_by_id ::test1_punkargs_by_id $args] + return [tcl::dict::get $argd opts] + } + + punk::args::definition { + @id -id ::argparsingtest::test1_punkargs2 + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -join -type none -multiple 1 + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -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] + set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] return [tcl::dict::get $argd opts] } proc test1_punkargs_validate_ansistripped {args} { set argd [punk::args::get_dict { - *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" - *opts -anyopts 0 + @id -id ::argparsingtest::test1_punkargs_validate_ansistripped + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 -return -default string -type string -choices {string object} -help "return type" -frametype -default \uFFEF -type string -show_edge -default \uFFEF -type string @@ -333,7 +357,7 @@ namespace eval argparsingtest { -1 -default 1 -type boolean -validate_ansistripped true -2 -default 2 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true - *values + @values } $args] return [tcl::dict::get $argd opts] } diff --git a/src/modules/patternpunk-1.1.tm b/src/modules/patternpunk-1.1.tm index 124ce3b7..4f13a121 100644 --- a/src/modules/patternpunk-1.1.tm +++ b/src/modules/patternpunk-1.1.tm @@ -112,10 +112,10 @@ proc TCL {args} { } punk::args::definition { -*id ">punk . poses" -*proc -name ">punk . poses" -help "Show or list the poses for the Punk mascot" --censored -default 1 -type boolean -help "Set true to include mild toilet humour poses" --return -default table -choices {list table} + @id -id ">punk . poses" + @cmd -name ">punk . poses" -help "Show or list the poses for the Punk mascot" + -censored -default 1 -type boolean -help "Set true to include mild toilet humour poses" + -return -default table -choices {list table} } >punk .. Method poses {args} { set argd [punk::args::get_by_id ">punk . poses" $args] @@ -344,7 +344,8 @@ v_ /|\/ / package require punk::args set standard_frame_types [textblock::frametypes] set argd [punk::args::get_dict [tstr -return string { - *proc -name "deck" -help "Punk Deck mascot" + @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 -boxlimits -default {hl vl tlc blc trc brc} -help "Limit the border box to listed elements." @@ -353,7 +354,7 @@ v_ /|\/ / } -title -default "PATTERN" -type string -subtitle -default "PUNK" -type string - *values -max 0 + @values -max 0 }] $args] set frame_type [dict get $argd opts -frame] set box_map [dict get $argd opts -boxmap] @@ -367,7 +368,7 @@ v_ /|\/ / #TODO - reuse textblock::gcross arguments - but reorder for error display >punk .. Method gcross {{size 1} args} { package require textblock - set argd [punk::args::get_by_id textblock::gcross [list {*}$args $size]] + set argd [punk::args::get_by_id ::textblock::gcross [list {*}$args $size]] textblock::gcross {*}$args $size } diff --git a/src/modules/poshinfo-999999.0a1.0.tm b/src/modules/poshinfo-999999.0a1.0.tm index c38a23c7..d8f7c059 100644 --- a/src/modules/poshinfo-999999.0a1.0.tm +++ b/src/modules/poshinfo-999999.0a1.0.tm @@ -199,19 +199,19 @@ tcl::namespace::eval poshinfo { } punk::args::definition { - *id poshinfo::themes - *proc -name poshinfo::themes + @id -id ::poshinfo::themes + @cmd -name poshinfo::themes -format -default all -multiple 1 -choices {all yaml json}\ - -help "File format of posh theme - based on file extension" - -type -default all -multiple 1\ - -help "e.g omp" - -as -default "table" -choices {list showlist dict showdict table tableobject plaintext}\ - -help "return type of result" - *values -min 0 - globs -multiple 1 -default * -help "" + -help "File format of posh theme - based on file extension" + -type -default all -multiple 1\ + -help "e.g omp" + -as -default "table" -choices {list showlist dict showdict table tableobject plaintext}\ + -help "return type of result" + @values -min 0 + globs -multiple 1 -default * -help "" } proc themes {args} { - set argd [punk::args::get_by_id poshinfo::themes $args] + set argd [punk::args::get_by_id ::poshinfo::themes $args] set return_as [dict get $argd opts -as] set formats [dict get $argd opts -format] ;#multiple if {"yaml" in $formats} { diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index c093dd56..1a9ab766 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -306,10 +306,11 @@ namespace eval punk { #get last command result that was run through the repl proc ::punk::get_runchunk {args} { set argd [punk::args::get_dict { - *opts + @id -id ::punk::get_runchunk + @opts -1 -optional 1 -type none -2 -optional 1 -type none - *values -min 0 -max 0 + @values -min 0 -max 0 } $args] #todo - make this command run without truncating previous runchunks set runchunks [tsv::array names repl runchunks-*] @@ -7152,8 +7153,8 @@ namespace eval punk { } punk::args::definition { - *id punk::inspect - *proc -name punk::inspect -help\ + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. The raw value arguments (not options) are always returned to pass forward in the pipeline. @@ -7229,7 +7230,7 @@ namespace eval punk { "End of options marker. It is advisable to use this, as data in a pipeline may often begin with -" - *values -min 0 -max -1 + @values -min 0 -max -1 arg -type string -optional 1 -multiple 1 -help\ "value to display" } @@ -7261,7 +7262,7 @@ namespace eval punk { foreach {k v} $flags { if {$k ni [dict keys $defaults]} { #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" - punk::args::get_by_id punk::inspect $args + punk::args::get_by_id ::punk::inspect $args } } set opts [dict merge $defaults $flags] diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 39266073..921b3ed1 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -134,27 +134,27 @@ tcl::namespace::eval punk::ansi::class { } lappend ::punk::ansi::class::PUNKARGS [list { - *id "punk::ansi::class::class_ansi render_to_input_line" - *proc -name "punk::ansi::class::class_ansi render_to_input_line" -help\ + @id -id "::punk::ansi::class::class_ansi render_to_input_line" + @cmd -name "punk::ansi::class::class_ansi render_to_input_line" -help\ "render string from line 0 to line (experimental/debug)" -dimensions -type string -help\ "WxH where W is integer width >= 1 and H is integer heigth >= 1" -minus -type integer -help\ "number of chars to exclude from end" - *values -min 1 -max 1 + @values -min 1 -max 1 line -type indexexpression }] method render_to_input_line {args} { if {[llength $args] < 1} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set opts [tcl::dict::create\ -dimensions 80x24\ @@ -167,7 +167,7 @@ tcl::namespace::eval punk::ansi::class { } default { puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } } } @@ -588,20 +588,20 @@ tcl::namespace::eval punk::ansi { } lappend PUNKARGS [list -dynamic 1 { - *id punk::ansi::example - *proc -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console + @id -id ::punk::ansi::example + @cmd -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console " -colwidth -default 82 -help "Width of each column - default of 82 will fit a standard 80wide ansi image (when framed) You can specify a narrower width to truncate images on the right side" -folder -default "${[punk::ansi::Get_ansifolder]}" -help "Base folder for files if relative paths are used. Defaults to /src/testansi - where projectbase is determined from current directory. " - *values -min 0 -max -1 + @values -min 0 -max -1 files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help "List of filenames - leave empty to display 4 defaults" } ""] proc example {args} { - set argd [punk::args::get_by_id punk::ansi::example $args] + set argd [punk::args::get_by_id ::punk::ansi::example $args] set colwidth [dict get $argd opts -colwidth] set ansifolder [file normalize [dict get $argd opts -folder]] set fnames [dict get $argd values files] @@ -2355,21 +2355,21 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #sgr_cache clear called by punk::console::ansi when set to off #punk::args depends on punk::ansi - REVIEW + lappend PUNKARGS [list { + @id -id ::punk::ansi::sgr_cache + @cmd -name punk::ansi::sgr_cache -help\ + "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) + " + -action -default "" -choices "clear" -help\ + "-action clear will unset the keys in the punk::ansi::sgr_cache dict + This is called automatically when setting 'colour false' in the console" + + -pretty -default 1 -type boolean -help\ + "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" + @values -min 0 -max 0 + }] proc sgr_cache {args} { - set argdef { - *id punk::ansi::sgr_cache - *proc -name punk::ansi::sgr_cache -help\ - "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) - " - -action -default "" -choices "clear" -help\ - "-action clear will unset the keys in the punk::ansi::sgr_cache dict - This is called automatically when setting 'colour false' in the console" - - -pretty -default 1 -type boolean -help\ - "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" - *values -min 0 -max 0 - } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::get_by_id ::punk::ansi::sgr_cache $args] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] @@ -2412,34 +2412,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return [join $lines \n] } - lappend PUNKARGS [list { - *id punk::ansi::a+ - *proc -name "punk::ansi::a+" -help\ - "Returns an ANSI sgr escape sequence based on the list of supplied codes. - Unlike punk::ansi::a - it is not prefixed with an ANSI reset. - " - *values -min 0 -max -1 - } [string map [list [dict keys $SGR_map]] { - code -type string -optional 1 -multiple 1 -choices {} -choiceprefix 0 -choicerestricted 0 -help\ - "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. - A leading capital letter indicates a codename applies to the background colour. - Other accepted codes are: - term- Term- foreground/background where int is 0-255 terminal color - term- Term- foreground/background - rgb--- Rgb--- foreground/background where are the - 0-255 int values for red, green and blue. - rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 - web- Web- - - The acceptable values for and can be queried using - punk::ansi::a? term - and - punk::ansi::a? web - - Example to set foreground red and background cyan followed by a reset: - set str \"[a+ red Cyan]sample text[a]\" - " - }]] + #PUNKARGS doc performed below, after we create the proc proc a+ {args} { #*** !doctools #[call [fun a+] [opt {ansicode...}]] @@ -2907,6 +2880,41 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $result } + set SGR_samples [dict create] + foreach k [dict keys $SGR_map] { + dict set SGR_samples $k "[punk::ansi::a+ $k]sample\x1b\[m" + } + lappend PUNKARGS [list { + @id -id ::punk::ansi::a+ + @cmd -name "punk::ansi::a+" -help\ + "Returns an ANSI sgr escape sequence based on the list of supplied codes. + Unlike punk::ansi::a - it is not prefixed with an ANSI reset. + " + @values -min 0 -max -1 + } [string map [list [dict keys $SGR_map] $SGR_samples] { + code -type string -optional 1 -multiple 1 -choices {}\ + -choicelabels {}\ + -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ + "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. + A leading capital letter indicates a codename applies to the background colour. + Other accepted codes are: + term- Term- foreground/background where int is 0-255 terminal color + term- Term- foreground/background + rgb--- Rgb--- foreground/background where are the + 0-255 int values for red, green and blue. + rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 + web- Web- + + The acceptable values for and can be queried using + punk::ansi::a? term + and + punk::ansi::a? web + + Example to set foreground red and background cyan followed by a reset: + set str \"[a+ red Cyan]sample text[a]\" + " + }]] + proc a {args} { #*** !doctools #[call [fun a] [opt {ansicode...}]] @@ -4281,6 +4289,7 @@ tcl::namespace::eval punk::ansi { } 4 { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines + #e.g hyper on windows if {[llength $paramsplit] == 1} { tcl::dict::set codestate underline 4 } else { @@ -4634,6 +4643,8 @@ tcl::namespace::eval punk::ansi::ta { #[list_begin definitions] tcl::namespace::path ::punk::ansi + variable PUNKARGS + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position @@ -4706,15 +4717,31 @@ tcl::namespace::eval punk::ansi::ta { #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::ansi::ta::detect + @cmd -name punk::ansi::ta::detect -help\ + "Return a boolean indicating whether Ansi codes were detected in text. + Important caveat: + When text is a tcl list made from splitting (or lappending) some ansi string + - individual elements may be braced or have certain chars escaped. + (one example is if a list element contains an unbalanced brace) + This can cause square brackets that form part of the ansi to be backslash escaped + - and the function can fail to match it as an Ansi code. + " + @values -min 1 + text -type string + } ] + + #*** !doctools + #[call [fun detect] [arg text]] + #[para]Return a boolean indicating whether Ansi codes were detected in text + #[para]Important caveat: + #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) + #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match + #detect any ansi escapes #review - only detect 'complete' codes - or just use the opening escapes for performance? proc detect {text} [string map [list [list $re_ansi_detect]] { - #*** !doctools - #[call [fun detect] [arg text]] - #[para]Return a boolean indicating whether Ansi codes were detected in text - #[para]Important caveat: - #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) - #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match regexp $text }] @@ -7405,7 +7432,7 @@ if {![info exists ::punk::args::register::NAMESPACES]} { set NAMESPACES [list] } } -lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class +lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class ::punk::ansi::ta # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index e6497cdf..efb66a49 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -50,14 +50,14 @@ #[example { # proc dofilestuff {args} { # lassign [dict values [punk::args::get_dict { -# *proc -help "do some stuff with files e.g dofilestuff " -# *opts -type string +# @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 +# @values -min 1 -max -1 # } $args]] leaders opts values # # puts "translation is [dict get $opts -translation]" @@ -67,8 +67,8 @@ # } #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for *values -#[para]valid * lines being with *proc *leaders *opts *values +#[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: @@ -81,7 +81,7 @@ # -directory -default "" # -translation -default binary # -nocomplain -type none -# *values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 # } $args]] leaders opts values @@ -89,7 +89,7 @@ # 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]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 @@ -279,11 +279,140 @@ tcl::namespace::eval punk::args { #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 - lappend PUNKARGS [list { - *id punk::args::definition - *proc -name punk::args::definition -help\ + 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::definition + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::definition -help\ "Accepts a line-based definition of command arguments. - The definition should usually contain a line of the form: *id someid + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + options: -id + %B%@cmd%N% ?opt val...? + options -name -help + %B%@leaders%N% ?opt val...? + options -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + options -any + %B%@values%N% ?opt val...? + options -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + options -header (text for header row of table) + -body (text to replace entirety of autogenerated docs) + %B%@doc%N% ?opt val...? + options -name -url + + 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 + 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 value or option. + + 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 options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + -default + -multiple (for leaders & values defines whether + subsequent received values are stored agains the same + argument name - only applies to final leader or value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - no necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -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\} @@ -292,20 +421,20 @@ tcl::namespace::eval punk::args { 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 not usually significant, perhaps on the order of a few hundred uS, - but -dynamic true might be less desirable if the command is used in inner - loops in more performance-sensitive code. + 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 + @values -min 1 -max -1 text -type string -multiple 1 -help\ "Block(s) of text representing the argument specification 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. - e.g + e.g the following definition passes 2 blocks as text arguments definition { - *id myns::myfunc - *proc -name myns::myfunc -help\\ + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ \"Description of command\" #The following option defines an option-value pair @@ -314,13 +443,13 @@ tcl::namespace::eval punk::args { -flag1 -default 0 -type none -help\\ \"Info about flag1\" - *values -min 1 -max -1 + @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 definition {args} { variable argdata_cache variable argdefcache_by_id @@ -482,6 +611,7 @@ tcl::namespace::eval punk::args { 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]} { @@ -522,9 +652,10 @@ tcl::namespace::eval punk::args { set linebuild "" } } - set proc_info {} + set cmd_info {} set id_info {} ;#e.g -children ?? set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table set parser_info {} set leader_min "" #set leader_min 0 @@ -543,27 +674,50 @@ tcl::namespace::eval punk::args { "" - # {continue} } set linespecs [lassign $trimln argname] - if {$argname ne "*id" && [llength $linespecs] % 2} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs'" + if {[llength $linespecs] % 2 != 0} { + error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" } set firstchar [tcl::string::index $argname 0] set secondchar [tcl::string::index $argname 1] - if {$firstchar eq "*" && $secondchar ne "*"} { - set starspecs $linespecs + if {$firstchar eq "@" && $secondchar ne "@"} { + set at_specs $linespecs + switch -- [tcl::string::range $argname 1 end] { id { - #id line must have single entry - a unique id assigned by the user - an id will be allocated if no id line present or the value is "auto" - if {[llength $starspecs] == 0} { - error "punk::args::definition - *id line must have at least a single entry following *id." - } + #id An id will be allocated if no id line present or the -id value is "auto" if {$spec_id ne ""} { - #disallow duplicate *id line - error "punk::args::definition - *id already set. Existing value $spec_id" + #disallow duplicate @id line + error "punk::args::definition - @id already set. Existing value $spec_id" } - set spec_id [lindex $starspecs 0] - set id_info [lrange $starspecs 1 end] - if {[llength $id_info] %2} { - error "punk::args::definition - bad *id line. Remaining items on line after *id must be in paired option-value format - received '$linespecs'" + if {[dict exists $at_specs -id]} { + set spec_id [dict get $at_specs -id] + } else { + set spec_id auto + } + set id_info $at_specs + } + default { + #copy from an identified set of defaults (another argspec id) can be multiple + if {[dict exists $at_specs -id]} { + set copyfrom [get_def [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] + } + 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??? + } } } parser { @@ -596,27 +750,32 @@ tcl::namespace::eval punk::args { # 1 anykeys {0 info} # } #todo - set parser_info $starspecs + set parser_info $at_specs } - proc { + cmd { #allow arbitrary - review - set proc_info $starspecs + set cmd_info [dict merge $cmd_info $at_specs] } doc { - set doc_info $starspecs + 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 { if {$argspace eq "values"} { - error "punk::args::definition - *opts declaration must come before *values - received '$linespecs'" + error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" } set argspace "options" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -any - -anyopts { set opt_any $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } @@ -662,26 +821,26 @@ tcl::namespace::eval punk::args { tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *opts line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } } } leaders { if {$argspace in [list options values]} { - error "punk::args::definition - *leaders declaration must come before all options and values" + error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" } - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" } set leader_min $v #if {$leader_max == 0} { @@ -691,15 +850,16 @@ tcl::namespace::eval punk::args { -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" } set leader_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set leaderspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset leaderspec_defaults $k2 @@ -741,12 +901,12 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *leaders line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } } @@ -754,27 +914,28 @@ tcl::namespace::eval punk::args { } values { set argspace "values" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" } set val_min $v } -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" } set val_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset valspec_defaults $k2 @@ -816,19 +977,19 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *values line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } } } default { - error "punk::args::definition - unrecognised * line in '$ln'. Expected *proc *leaders *opts or *values - use **name if paramname needs to be *name" + error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" } } continue @@ -836,15 +997,15 @@ tcl::namespace::eval punk::args { if {$argspace eq "leaders"} { set argspace "options" } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before *values" + error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" } set argspecs $linespecs tcl::dict::set argspecs -ARGTYPE option lappend opt_names $argname set is_opt 1 } else { - if {$firstchar eq "*"} { - #allow basic ** escaping for literal argname that begins with * + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } set argspecs $linespecs @@ -898,7 +1059,7 @@ tcl::namespace::eval punk::args { lappend opt_solos $argname } else { #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname'" + error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } } any - anything { @@ -916,18 +1077,18 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choiceprefix - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -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 + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines #review -solo 1 vs -type none ? conflicting values? tcl::dict::set spec_merged $spec $specval } -validationtransform { #string is dict only 8.7/9+ if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary" + error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" } dict for {tk tv} $specval { switch -- $tk { @@ -935,18 +1096,18 @@ tcl::namespace::eval punk::args { } default { set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys" + error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" } } } } default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choiceprefix -choicerestricted\ + set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" + error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" } } } @@ -983,6 +1144,11 @@ tcl::namespace::eval punk::args { } } + if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + variable id_counter + set spec_id "autoid_[incr id_counter]" + } + # REVIEW #if {[llength $val_names] || $val_min > 0} { # #some values are specified @@ -995,23 +1161,19 @@ tcl::namespace::eval punk::args { #no values specified - we can allow last leader to be multiple foreach leadername [lrange $leader_names 0 end-1] { if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple" + error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" } } #} #confirm any valnames before last don't have -multiple key foreach valname [lrange $val_names 0 end-1] { if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple" + error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" } } - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { - variable id_counter - set spec_id "autoid_[incr id_counter]" - } - #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) + #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) set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize @@ -1043,8 +1205,9 @@ tcl::namespace::eval punk::args { val_max $val_max\ valspec_defaults $valspec_defaults\ val_checks_defaults $val_checks_defaults\ - proc_info $proc_info\ + cmd_info $cmd_info\ doc_info $doc_info\ + argdisplay_info $argdisplay_info\ id_info $id_info\ ] tcl::dict::set argdata_cache $cache_key $argdata_dict @@ -1081,7 +1244,6 @@ tcl::namespace::eval punk::args { return $result } } - return } proc get_spec_values {id {patternlist *}} { variable argdefcache_by_id @@ -1098,6 +1260,7 @@ tcl::namespace::eval punk::args { set def [dict remove $def -ARGTYPE] append result \n "$v $def" } + return $result } else { foreach pat $patternlist { set matches [dict keys $arg_info $pat] @@ -1111,19 +1274,28 @@ tcl::namespace::eval punk::args { return $result } } - return } #proc get_spec_leaders ?? #proc get_spec_opts ?? + proc get_def {id} { + if {[id_exists $id]} { + return [definition {*}[get_spec $id]] + } + } + proc is_dynamic {id} { + set spec [get_spec $id] + return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ] + } + variable aliases set aliases [dict create] lappend PUNKARGS [list { - *id punk::args::get_ids - *proc -name punk::args::get_ids -help\ + @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 + @values -min 0 -max 1 match -default * -help\ "exact id or glob pattern for ids" }] @@ -1182,23 +1354,37 @@ tcl::namespace::eval punk::args { set loaded_packages [list] proc update_definitions {} { + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - get's 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 variable loaded_packages upvar ::punk::args::register::NAMESPACES pkgs if {[llength $loaded_packages] == [llength $pkgs]} { #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. return {} } + # -- --- --- --- --- --- + set unloaded [punklib_ldiff $pkgs $loaded_packages] set newloaded [list] foreach pkgns $unloaded { + #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { foreach deflist [set ${pkgns}::PUNKARGS] { namespace eval $pkgns [list punk::args::definition {*}$deflist] } } + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } } errMsg]} { - lappend loaded_pkgs $pkgns + lappend loaded_packages $pkgns lappend newloaded $pkgns } else { puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" @@ -1273,7 +1459,8 @@ tcl::namespace::eval punk::args { set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error dict for {k v} $args { - switch -- $k { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + switch -- $fullk { -badarg { set badarg $v } @@ -1285,7 +1472,7 @@ tcl::namespace::eval punk::args { set as_error $v } -return { - if {$v ni {string table tableobject}} { + 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" } @@ -1293,7 +1480,7 @@ tcl::namespace::eval punk::args { } default { set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return" + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" } } } @@ -1328,14 +1515,22 @@ tcl::namespace::eval punk::args { append errmsg \n } } - set procname [Dict_getdef $spec_dict proc_info -name ""] - set prochelp [Dict_getdef $spec_dict proc_info -help ""] + set procname [Dict_getdef $spec_dict cmd_info -name ""] + set prochelp [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 ""] + set blank_header_col [list] if {$procname ne ""} { lappend blank_header_col "" set procname_display [a+ brightwhite]$procname[a] @@ -1344,7 +1539,8 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { lappend blank_header_col "" - set prochelp_display [a+ brightwhite]$prochelp[a] + #set prochelp_display [a+ brightwhite]$prochelp[a] + set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] } else { set prochelp_display "" } @@ -1354,18 +1550,32 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } if {$use_table} { set t [textblock::class::table new [a+ brightyellow]Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $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 {$procname ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] } else { lappend errlines "PROC/METHOD: $procname_display" } @@ -1373,7 +1583,7 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] } else { lappend errlines "Description: $prochelp_display" } @@ -1384,225 +1594,352 @@ tcl::namespace::eval punk::args { set docurl [punk::ansi::hyperlink $docurl] } if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display] + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] } else { lappend errlines "$docname $docurl_display" } incr h } if {$use_table} { - $t configure_header $h -values {Arg Type Default Multi Help} + 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-- " } - - set RST [a] - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + 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_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] - $trie destroy - foreach c [dict get $spec_dict opt_names] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } + + set RST [a] + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG [a+ brightred] + set greencheck [a+ brightgreen]\u2713[a] ;#green tick + set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX [a+ green] ;#use a+ so colour off can apply + if {$A_PREFIX eq ""} { + 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 opt_names [dict get $spec_dict opt_names] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict opt_names]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } } else { - set default "" + set opt_names [dict get $spec_dict opt_names] + set opt_names_display $opt_names } - set help [Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" + } + set leading_val_names [dict get $spec_dict leader_names] + set trailing_val_names [dict get $spec_dict val_names] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { - set casemsg " (case sensitive)" + set default "" } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices } else { - set prefixmsg "" + set choicegroups [dict merge [dict create "" $choices] $choicegroups] } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [list] - append help " Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } } - lappend formattedchoices $cdisplay + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] } } else { - set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - set prefix $c - set tail "" + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] + set formattedchoices $choicegroups } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + + } + } + 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 [a+ cyan]$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + #bold as well as brightcolour in case colour off. + append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + } else { + append help \n + } + append help \n [join $formatted \n] } - lappend formattedchoices $cdisplay - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + } 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 "" " [a+ red](no choices defined for main group)[a]" + } else { + dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + } + } else { + if {$groupname eq ""} { + append help \n " " [a+ red](no choices defined)[a] + } else { + append help \n " " [a+ red](no choices defined for group $groupname)[a] } - lappend formattedchoices $cdisplay } + } + } + 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]} { + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" } else { - set formattedchoices [dict get $arginfo -choices] + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" } - } } - set numcols 4 ;#todo - dynamic? - if {[llength $formattedchoices] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formattedchoices] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices] - append help \n[textblock::join -- " " $choicetable] - } else { - append help \n [join $formattedchoices \n] - } + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck } 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. - append help \n " " [a+ red](no choices defined)[a] + set multiple "" } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - 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]} { + 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 {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - 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 + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow[a] TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - lappend errlines "$argshow TYPE:$typeshow DEFAULT:$default MULTI:$multiple HELP:$help\n" } } - } + } ;#end is_custom_argdisplay if {$use_table} { $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] $t configure -maxwidth 80 ;#review - append errmsg [$t print] if {$returntype ne "tableobject"} { + append errmsg [$t print] #returntype of table means just the text of the table $t destroy } @@ -1640,19 +1977,26 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::usage - *proc -name punk::args::usage -help\ - "return usage information as a string - in table form." + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command. + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and not have an id. + 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 this as necessary. + " -return -default table -choices {string table tableobject} - *values -min 0 -max 1 + @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::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] set speclist [get_spec $id] if {[llength $speclist] == 0} { @@ -1662,9 +2006,9 @@ tcl::namespace::eval punk::args { } lappend PUNKARGS [list { - *id punk::args::get_by_id - *proc -name punk::args::get_by_id - *values -min 1 + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 id arglist -default "" -type list -help\ "list containing arguments to be parsed as per the @@ -1703,8 +2047,8 @@ tcl::namespace::eval punk::args { #[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 *proc *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. + #[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. @@ -1713,12 +2057,12 @@ tcl::namespace::eval punk::args { #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { - # *opts + # @opts # -opt1 -default {} # -opt2 -default { # etc # } - # *values -multiple 1 + # @values -multiple 1 #} $args #if {[llength $args] == 0} { @@ -2014,7 +2358,7 @@ tcl::namespace::eval punk::args { } if {$opt_any} { set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $opt_checks_defaults if {[tcl::dict::get $arg_info $a -type] ne "none"} { @@ -2023,7 +2367,6 @@ tcl::namespace::eval punk::args { } else { tcl::dict::set opts $a $newval } - lappend flagsreceived $a ;#adhoc flag as supplied if {[incr i] > $maxidx} { arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a } @@ -2041,11 +2384,12 @@ tcl::namespace::eval punk::args { } incr vals_remaining_possible -1 } + lappend flagsreceived $a ;#adhoc flag as supplied } else { if {[llength $opt_names]} { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while *opts -any 0" + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } arg_error $errmsg $argspecs -badarg $fullopt } @@ -2096,6 +2440,7 @@ tcl::namespace::eval punk::args { } 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 arg_info $positionalidx $leaderspec_defaults @@ -2132,7 +2477,8 @@ tcl::namespace::eval punk::args { } else { if {$in_multiple ne ""} { tcl::dict::lappend values_dict $in_multiple $val - #name already seen + #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 arg_info $positionalidx $valspec_defaults @@ -2228,7 +2574,7 @@ tcl::namespace::eval punk::args { set defaultval [tcl::dict::get $thisarg -default] } set type [tcl::dict::get $thisarg -type] - set has_choices [tcl::dict::exists $thisarg -choices] + 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] @@ -2259,10 +2605,22 @@ tcl::namespace::eval punk::args { if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set nocase [tcl::dict::get $thisarg -nocase] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + 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 clist} $choicegroups { + lappend allchoices {*}$clist + } + } + #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 @@ -2275,7 +2633,7 @@ tcl::namespace::eval punk::args { } } set idx 0 ;# - #opts/values_dict $argname membmer has been populated with the actual entered choices - which might be prefixes + #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] @@ -2283,44 +2641,95 @@ tcl::namespace::eval punk::args { foreach e $vlist e_check $vlist_check { if {$nocase} { set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $choices] + 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 $e_check] } else { set casemsg " (case sensitive)" set v_test $e_check - set choices_test $choices + set choices_test $allchoices } set choice_in_list 0 set matches_default [expr {$has_default && $e eq $defaultval}] if {!$matches_default} { if {$choiceprefix} { - set chosen [tcl::prefix::match -error "" $choices_test $v_test] - if {$chosen ne ""} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$e_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $e_check set choice_in_list 1 - #can we handle empty string as a choice? It should just work - REVIEW/test - #must use exact in case glob chars present e.g * ? [] (also ansi has square brackets) - set choice [lsearch -exact -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + set chosen $v_test + 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] $e_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + set choice_in_list [expr {$chosen ne ""}] + #we + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $e_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 "" + } + } + + if {$choice_in_list && !$choice_exact_match} { if {$is_multiple} { set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $choice + lset existing $idx $chosen tcl::dict::set $dname $argname $existing } else { - tcl::dict::set $dname $argname $choice + tcl::dict::set $dname $argname $chosen } } } 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 - } + #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 $e lappend vlist_check_validate $e_check } else { @@ -2330,13 +2739,13 @@ tcl::namespace::eval punk::args { } else { set prefixmsg "" } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname } } 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 + #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 } @@ -2354,7 +2763,7 @@ tcl::namespace::eval punk::args { 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 + #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 @@ -2376,7 +2785,7 @@ tcl::namespace::eval punk::args { #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 + #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 { @@ -2690,6 +3099,10 @@ tcl::namespace::eval punk::args { } 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] } @@ -2702,12 +3115,12 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::TEST - *opts -optional 0 + @id -id ::punk::args::TEST + @opts -optional 0 -o1 -default 111 -help "opt 1 mandatory" - *opts -optional 1 + @opts -optional 1 -o2 -default 222 -help "opt 2 optional" - *values -min 0 -max 1 + @values -min 0 -max 1 v -help\ "v1 optional" }] @@ -2762,16 +3175,18 @@ tcl::namespace::eval punk::args::lib { #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 punk::args::lib::tstr - *proc -name punk::args::lib::tstr -help\ + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ "A rough equivalent of js template literals" -allowcommands -default 0 -type none -help\ - "if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "if -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" -return -default list -choices {dict list string args}\ -choicelabels { dict\ "Return a dict with keys - 'template' and 'params'" + 'template', 'params' and + 'errors'" string\ "Return a single result being the string with @@ -2791,7 +3206,7 @@ tcl::namespace::eval punk::args::lib { args\ "Return a list where the first element is a list of template - plaintext secions as per the + plaintext sections as per the 'list' return mechanism, but the placeholder items are individual items in the returned list. @@ -2808,7 +3223,7 @@ tcl::namespace::eval punk::args::lib { contained variables in that case should be braced, 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 + @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 @@ -2820,7 +3235,7 @@ tcl::namespace::eval punk::args::lib { 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 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] @@ -2838,7 +3253,12 @@ tcl::namespace::eval punk::args::lib { dict set opts -allowcommands 1 } if {[llength $arglist] % 2 != 0} { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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 -return -eval} $k] @@ -2847,12 +3267,20 @@ tcl::namespace::eval punk::args::lib { dict set opts $fullk $v } default { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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_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] @@ -2871,6 +3299,7 @@ tcl::namespace::eval punk::args::lib { #set expressions [list] set params [list] set idx 0 + set errors [dict create] foreach {pt expression} $parts { lappend textchunks $pt incr idx ;#pt incr @@ -2881,17 +3310,32 @@ tcl::namespace::eval punk::args::lib { } #lappend expressions $expression if {$opt_eval} { - lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] } else { lappend params $expression } incr idx ;#expression incr } - switch -- $opt_return { - dict { - return [dict create template $textchunks params $params] + + 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 } + puts stderr "tstr errors:\n$einfo\n]" + } + + switch -- $opt_return { list { return [list $textchunks $params] } @@ -2906,20 +3350,18 @@ tcl::namespace::eval punk::args::lib { } return $out } - default { - } } } #test single placeholder tstr args where single placeholder must be an int proc tstr_test_one {args} { set argd [punk::args::get_dict { - *proc -name tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + @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 + @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" diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index 83220d1d..8b6036ab 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -141,29 +141,219 @@ tcl::namespace::eval punk::args::tclcore { variable PUNKARGS + # -- --- --- --- --- + #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] + # -- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # library commands loaded via auto_index # -- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { - *id parray - *proc -name "Builtin: parray" -help\ + @id -id ::parray + @cmd -name "Builtin: parray" -help\ "Prints on standard output the names and values of all the elements in the array arrayName, or just the names that match pattern (using the matching rules of string_match) and their values if pattern is given. ArrayName must be an array accessible to the caller of parray. It may either be local or global. The result of this command is the empty string. (loaded via auto_index)" - *values -min 1 -max 2 + @values -min 1 -max 2 arrayName -type string -help\ "variable name of an array" pattern -type string -optional 1 -help\ "Match pattern possibly containing glob characters" - } "*doc -name Manpage: -url [manpage_tcl library]" ] + } "@doc -name Manpage: -url [manpage_tcl library]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + #categorise array subcommands based on currently known groupings. + #we do this dynamically because Tcl ensembles (even some core ones) can have subcommands added at runtime. + proc array_subcommands {} { + package require punk::ns + set subdict [punk::ns::ensemble_subcommands array] + set expected_searchcmds {startsearch anymore nextelement donesearch} + set searchcmds [list] + foreach sc $expected_searchcmds { + if {$sc in [dict keys $subdict]} { + lappend searchcmds $sc + } + } + set argdef "" + append argdef "subcommand -choicegroups \{" \n + append argdef " \"\" \{" \n + append argdef " [dict keys [dict remove $subdict {*}$searchcmds]]" \n + append argdef " \}" \n + append argdef " \"search\" \{" \n + append argdef " $searchcmds" \n + append argdef " \}" \n + append argdef " \} -choicecolumns 4 " \n + + return $argdef + } + + lappend PUNKARGS [list -dynamic 1 { + @id -id ::array + @cmd -name "Builtin: array" -help\ + "Manipulate array variables" + @values + ${[punk::args::tclcore::array_subcommands]} + + } "@doc -name Manpage: -url [manpage_tcl array]" ] + + #todo - make generic - take command and known_groups_dict + proc info_subcommands {} { + package require punk::ns + set subdict [punk::ns::ensemble_subcommands info] + set allsubs [dict keys $subdict] + dict set groups "system" {hostname library nameofexecutable patchlevel script sharedlibextension tclversion} + dict set groups "{proc introspection}" {args body default} + dict set groups "variables" {constant consts exists globals locals vars} + dict set groups "{oo object introspection}" {class object} + + set allgrouped [list] + dict for {g members} $groups { + lappend allgrouped {*}$members + } + set others [list] + foreach sc $allsubs { + if {$sc ni $allgrouped} { + lappend others $sc + } + } + + set argdef "" + append argdef "subcommand -choicegroups \{" \n + append argdef " \"\" \{$others\}" \n + dict for {g members} $groups { + append argdef " $g \{$members\}" \n + } + append argdef " \}" \n + + return $argdef + } + lappend PUNKARGS [list -dynamic 1 { + @id -id ::info + @cmd -name "Builtin: info" -help\ + "Information about the state of the Tcl interpreter" + @values + ${[punk::args::tclcore::info_subcommands]} + + } "@doc -name Manpage: -url [manpage_tcl array]" ] + + + + #An idiom for sharing common features - incomplete - todo work out what happens with (default)::id that has leaders,opts,values + #todo @cmd -help+ text (append to existing help that came from a default?) + lappend PUNKARGS [list { + @id -id "(default)::tcl::binary::*::base64" + @cmd -help\ + "The base64 binary encoding is commonly used in mail messages and XML documents, + and uses mostly upper and lower case letters and digits. It has the distinction + of being able to be rewrapped arbitrarily without losing information. + " + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::encode::base64" + @default -id (default)::tcl::binary::*::base64 + @cmd -name "binary encode base64" + -maxlen -type integer -help\ + "Indicates that the output should be split into lines of no more than length + characters. By default, lines are not split." + -wrapchar -type character -default \n -help\ + "Indicates that, when lines are split because of the -maxlen option, character + should be used to separate lines. By default, this is a newline character, \"\\n\"." + @values -min 1 -max 1 + data -type string + } ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::decode::base64" + @cmd -name "binary decode base64" + -strict -type none -help\ + "Instructs the decoder to throw an error if it encounters any characters that + are not strictly part of the encoding itself. Otherwise it ignores them. + RFC 2045 calls for base64 decoders to be non-strict." + @values -min 1 -max 1 + data -type string + } ] + + + lappend PUNKARGS [list { + @id -id "(default)::tcl::binary::*::hex" + @cmd -help\ + "The hex binary encoding converts each byte to a pair of hexadecimal digits + that represent the byte value as a hexadecimal integer. When encoding, lower + characters are used. When decoding, upper and lower characters are accepted." + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::encode::hex" + @default -id (default)::tcl::binary::*::hex + @cmd -name "binary encode hex" + @values -min 1 -max 1 + data -type string + } ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::decode::hex" + @default -id (default)::tcl::binary::*::hex + @cmd -name "binary encode hex" + -strict -type none -help\ + "Instructs the decoder to throw an error if it encounters whitespace + characters. Otherwise it ignores them." + @values -min 1 -max 1 + data -type string + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + + + lappend PUNKARGS [list { + @id -id "(default)::tcl::binary::*::uuencode" + @cmd -help\ + "The uuencode binary encoding used to be common for transfer of data between Unix + systems and on USENT, but is less common these days, having been largely + superseded by the base64 binary encoding. + Note that neither the encoder nor the decoder handle the header and footer of the + uuencode format." + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::encode::uuencode" + @default -id (default)::tcl::binary::*::uuencode + #todo @cmd -help+ "Changing the options may produce files that other implementations of decoders cannot process" + @cmd -name "binary encode uuencode" + -maxlen -type integer -default 61 -range {5 85} -help\ + "Indicates the maximum number of characters to produce for each encoded line. + The valid range is 5 to 85. Line lengths outside that range cannot be + accommodated by the encoding format." + -wrapchar -type string -default \n -help\ + "Indicates the character(s) to use to mark the end of each encoded line. + Acceptable values are a sequence of zero or more character from the set + { \\x09 (TAB), \\x0B (VT), \\x0C (FF), \\x0D (CR) } followed by zero or + one newline \\x0A (LF). Any other values are rejected because they would + generate encoded text that could not be decoded. The default value is a + single newline. + " + @values -min 1 -max 1 + data -type string + } ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::decode::uuencode" + @default -id (default)::tcl::binary::*::uuencode + @cmd -name "binary decode uuencode" + -strict -type none -help\ + "Instructs the decoder to throw an error if it encounters anything outside + of the standard encoding format. Without this option, the decoder tolerates + some deviations, mostly to forgive reflows of lines between the encoder and + decoder." + @values -min 1 -max 1 + data -type string + } ] + + lappend PUNKARGS [list { - *id time - *proc -name "Builtin: time" -help\ + @id -id ::time + @cmd -name "Builtin: time" -help\ "Calls the Tcl interpreter count times to evaluate script (or once if count is not specified). It will then return a string of the form @@ -172,46 +362,129 @@ tcl::namespace::eval punk::args::tclcore { iteration, in microseconds. Time is measured in elapsed time, not CPU time. (see also: timerate)" - *values -min 1 -max 2 + @values -min 1 -max 2 script -type script count -type integer -default 1 -optional 1 - } "*doc -name Manpage: -url [manpage_tcl time]" ] + } "@doc -name Manpage: -url [manpage_tcl time]" ] + + + lappend PUNKARGS [list { + @id -id ::tcl::chan::tell + @cmd -name "Builtin: tcl::chan::tell" -help\ + "Returns a number giving the current access position within the underlying + data stream for the channel named channel. This value returned is a byte + offset that can be passed to ${[a+ bold]}chan seek${[a normal]} in order + 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 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + + 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::namespace::origin + @cmd -name "Builtin: tcl::namespace::origin" -help\ + "Returns the fully-qualified name of the original command to which the + imported command command refers. When a command is imported into a + namespace, a new command is created in that namespace that points to the + actual command in the exporting namespace. If a command is imported into + a sequence of namespaces a,b,...,n where each successive namespace just + imports the command from the previous namespace, this command returns + the fully-qualified name of the original command in the first namespace, a. + If command does not refer to an imported command, the command's own + fully-qualified name is returned + " + @values + command + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] lappend PUNKARGS [list { - *id tcl::namespace::path - *proc -name "Builtin: tcl::namespace::path" -help\ + @id -id ::tcl::namespace::path + @cmd -name "Builtin: tcl::namespace::path" -help\ "Returns the command resolution path of the current namespace. If namespaceList is specified as a list of named namespaces, the current namespace's command resolution path is set to those namespaces and returns the empty list. The default command resolution path is always empty. See the section NAME_RESOLUTION in the manpage for an explanation of the rules regarding name resolution." - *values -min 0 -max 1 + @values -min 0 -max 1 namespaceList -type list -optional 1 -help\ "List of existing namespaces" - } "*doc -name Manpage: -url [manpage_tcl namespace]" ] - + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] lappend PUNKARGS [list { - *id tcl::namespace::unknown - *proc -name "Builtin: tcl::namespace::unknown" -help\ + @id -id ::tcl::namespace::unknown + @cmd -name "Builtin: tcl::namespace::unknown" -help\ "Sets or returns the unknown command handler for the current namespace. The handler is invoked when a command called from within the namespace cannot be found in the current namespace, the namespace's path nor in the global namespace. When the handler is invoiked, the full invocation line will be appended to the script and the result evaluated in the context of the namespace. - The default handler for all namespaces is [a+ italic]::unknown[a]. + The default handler for all namespaces is ${[a+ italic]}::unknown${[a+ noitalic]}. If no argument is given, it returns the handler for the current namespace." - *values -min 0 -max 1 + @values -min 0 -max 1 script -type script -optional 1 -help\ "A well formed list representing a command name and optional arguments." - } "*doc -name Manpage: -url [manpage_tcl namespace]" ] + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] + lappend PUNKARGS [list { + @id -id ::tcl::namespace::which + @cmd -name "Builtin: tcl::namespace::which" -help\ + "Looks up name as either a command or variable and returns its fully-qulified name. + For example, if name does not exist in the current namespace but does exist in the + global namespace, this command returns a fully-qualified name in the global namespace. + If the command or variable does not exist, this command returns an empty string. If + the variable has been created but not defined, such as with the variable command or + through a trace on the variable, this command will return the fully-qualified name + of the variable. If no flag is given, name is treated as a command name. + See the section NAME RESOLUTION in the manpage for an explanation of the rules + regarding name resolution. + " + @opts + -command + -variable + @values -min 1 -max 1 + name + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] - set I [a+ italic] - set NI [a+ noitalic] lappend PUNKARGS [list { - *id tcl::process::status - *proc -name "Builtin: tcl::process::status" -help\ + @id -id ::tcl::process::status + @cmd -name "Builtin: tcl::process::status" -help\ "Returns a dictionary mapping subprocess PIDs to their respective status. if ${$I}pids${$NI} is specified as a list of PIDs then the command only returns the status of the matching subprocesses if they exist, and @@ -243,43 +516,43 @@ tcl::namespace::eval punk::args::tclcore { -- -type none -optional 1 -help\ "Marks the end of switches. The argument following this one will be treated as the first arg even if it starts with a -." - *values -min 0 -max 1 + @values -min 0 -max 1 pids -type list -optional 1 -help\ "A list of PIDs" - } "*doc -name Manpage: -url [manpage_tcl namespace]" ] + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] lappend PUNKARGS [list { - *id lappend - *proc -name "builtin: lappend" -help\ + @id -id ::lappend + @cmd -name "builtin: lappend" -help\ "Append list elements onto a variable. " - *values -min 1 -max -1 + @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]"] + } "@doc -name Manpage: -url [manpage_tcl lappend]"] punk::args::definition { - *id ledit - *proc -name "builtin: ledit" -help\ + @id -id ::ledit + @cmd -name "builtin: ledit" -help\ "Replace elements of a list stored in variable " - *values -min 3 -max -1 + @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]" + } "@doc -name Manpage: -url [manpage_tcl ledit]" punk::args::definition { - *id lpop - *proc -name "builtin: lpop" -help\ + @id -id ::lpop + @cmd -name "builtin: lpop" -help\ "Get and remove an element in a list " - *values -min 1 -max -1 + @values -min 1 -max -1 varName -type string -help\ "Existing list variable name" index -type indexexpression -default end -optional 1 -multiple 1 -help\ @@ -292,11 +565,11 @@ tcl::namespace::eval punk::args::tclcore { 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]" + } "@doc -name Manpage: -url [manpage_tcl lpop]" punk::args::definition { - *id lrange - *proc -name "builtin: lrange" -help\ + @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 @@ -304,20 +577,20 @@ tcl::namespace::eval punk::args::tclcore { indices relative to the end of the list. e.g lrange {a b c} 0 end-1 " - *values -min 3 -max 3 + @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 lrange]" punk::args::definition { - *id tcl::string::cat + @id -id ::tcl::string::cat - *proc -name "builtin: tcl::string::cat" -help\ + @cmd -name "builtin: tcl::string::cat" -help\ "Concatente the given strings just like placing them directly next to each other and return the resulting compound string. If no strings are present, the result is an empty string. @@ -326,14 +599,14 @@ tcl::namespace::eval punk::args::tclcore { to return -level 0, and is more efficient than building a list of arguments and using join with an empty join string." - *values -min 0 -max -1 + @values -min 0 -max -1 string -type string -optional 1 -multiple 1 - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::compare + @id -id ::tcl::string::compare - *proc -name "builtin: tcl::string::compare" -help\ + @cmd -name "builtin: tcl::string::compare" -help\ "Perform a character-by-character comparison of strings string1 and string2. Returns -1, 0, or 1, dpending on whether string1 is lexicographically lessthan, equal to, or greater than string2" @@ -345,15 +618,15 @@ tcl::namespace::eval punk::args::tclcore { "If -length is specified, then only the first length characters are used in the comparison. If -length is negative, it is ignored." - *values -min 2 -max 2 + @values -min 2 -max 2 string1 -type string string2 -type string - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::equal + @id -id ::tcl::string::equal - *proc -name "builtin: tcl::string::equal" -help\ + @cmd -name "builtin: tcl::string::equal" -help\ "Perform a character-by-character comparison of strings string1 and string2. Returns 1 if string1 and string2 are identical, or 0 when not." @@ -364,30 +637,30 @@ tcl::namespace::eval punk::args::tclcore { "If -length is specified, then only the first length characters are used in the comparison. If -length is negative, it is ignored." - *values -min 2 -max 2 + @values -min 2 -max 2 string1 -type string string2 -type string - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::first - *proc -name "builtin: tcl::string::first" -help\ + @id -id ::tcl::string::first + @cmd -name "builtin: tcl::string::first" -help\ "Search haystackString for a sequence of characters that exactly match the characters in needleString. If found, return the index of the first character in the first such match within haystackString. If there is no match, then return -1. If startIndex is specified (in any of the forms described in STRING_INDICES), then the search is constrained to start with the character in haystackString specified by the index. " - *values -min 2 -max 3 + @values -min 2 -max 3 needleString -type string haystackString -type string startIndex -type indexexpression -optional 1 -help\ "integer or simple expression." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::insert - *proc -name "builtin: tcl::string::insert" -help\ + @id -id ::tcl::string::insert + @cmd -name "builtin: tcl::string::insert" -help\ "Returns a copy of string with insertString inserted at the index'th character. If index is start-relative, the first character inserted in the returned string will be at the specified index. @@ -398,43 +671,43 @@ tcl::namespace::eval punk::args::tclcore { If index is at or after the end of the string (e.g., index is end), insertString is appended to string." - *values -min 3 -max 3 + @values -min 3 -max 3 string -type string index -type indexexpression -help\ "The index may be specified as described in the STRING_INDICES section" insertString -type string - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::last - *proc -name "builtin: tcl::string::last" -help\ + @id -id ::tcl::string::last + @cmd -name "builtin: tcl::string::last" -help\ "Search haystackString for a sequence of characters that exactly match the characters in needleString. If found, return the index of the first character in the last such match within haystackString. If there is no match, then return -1. If lastIndex is specified (in any of the forms described in STRING_INDICES), then only the characters in haystackString at or before the specified lastIndex will be considered by the search " - *values -min 2 -max 3 + @values -min 2 -max 3 needleString -type string haystackString -type string lastIndex -type indexexpression -optional 1 -help\ "integer or simple expression." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::repeat - *proc -name "builtin: tcl::string::repeat" -help\ + @id -id ::tcl::string::repeat + @cmd -name "builtin: tcl::string::repeat" -help\ "Returns a string consisting of string concatenated with itself count times." - *values -min 2 -max 2 + @values -min 2 -max 2 string -type string count -type int -help\ "If count is 0, the empty string will be returned." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::replace - *proc -name "builtin: tcl::string::replace" -help\ + @id -id ::tcl::string::replace + @cmd -name "builtin: tcl::string::replace" -help\ "Removes a range of consecutive characters from string, starting with the character whose index is first and ending with the character whose index is last (Using the forms described in STRING_INDICES). An index of 0 refers to the first @@ -444,68 +717,68 @@ 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 3 string -type string first -type indexexpression last -type indexexpression newstring -type string -optional 1 -help\ "If newstring is specified, then it is placed in the removed character range." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::totitle - *proc -name "builtin: tcl::string::totitle" -help\ + @id -id ::tcl::string::totitle + @cmd -name "builtin: tcl::string::totitle" -help\ "Returns a value equal to string except that the first character in string is converted to it's Unicode title case variant (or upper case if there is no title case variant) and the rest of the string is converted to lower case." - *values -min 1 -max 1 + @values -min 1 -max 1 string -type string first -type indexexpression -optional 1 -help\ "If first is specified, it refers to the first char index in the string to start modifying." last -type indexexpression -optional 1 -help\ "If last is specified, it refers to the char index in the string to stop at (inclusive)." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::wordend - *proc -name "builtin: tcl::string::wordend" -help\ + @id -id ::tcl::string::wordend + @cmd -name "builtin: tcl::string::wordend" -help\ "Returns the index of the character just after the last one in the word containing character charIndex of string. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) or underscore (Unicode connector punctuation) characters, or any single character other than these." - *values -min 2 -max 2 + @values -min 2 -max 2 string -type string charIndex -type indexexpression -help\ "integer or simple expresssion. e.g end e.g end-1 e.g M+N" - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::wordstart - *proc -name "builtin: tcl::string::wordstart" -help\ + @id -id ::tcl::string::wordstart + @cmd -name "builtin: tcl::string::wordstart" -help\ "Returns the index of the first character in the word containing character charIndex of string. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) or underscore (Unicode connector punctuation) characters, or any single character other than these. " - *values -min 2 -max 2 + @values -min 2 -max 2 string -type string charIndex -type indexexpression -help\ "integer or simple expresssion. e.g end e.g end-1 e.g M+N" - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition [punk::lib::tstr -return string { - *id tcl::string::is - *proc -name "builtin: tcl::string::is" -help\ + @id -id ::tcl::string::is + @cmd -name "builtin: tcl::string::is" -help\ "Returns 1 if string is a valid member of the specified character class, otherwise returns 0. " - *leaders -min 1 -max 1 + @leaders -min 1 -max 1 class -type string\ -choices { alnum @@ -649,15 +922,56 @@ tcl::namespace::eval punk::args::tclcore { varname will always be set to 0, due to the varied nature of a valid boolean value" -strict -type none -help\ - "If -strictis specified, then an empty string returns 0, + "If -strict is specified, then an empty string returns 0, 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." - *values -min 1 -max 1 + @values -min 1 -max 1 string -type string -optional 0 - }] "*doc -name Manpage: -url [manpage_tcl string]" + }] "@doc -name Manpage: -url [manpage_tcl string]" + + punk::args::definition { + @id -id ::zlib + @cmd -name "builtin: ::zlib" -help\ + "zlib - compression and decompression operations + " + @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?" + } + + } "@doc -name Manpage: -url [manpage_tcl zlib]" + punk::args::definition { + @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]" + + #*** !doctools #[subsection {Namespace punk::args::tclcore}] diff --git a/src/modules/punk/blockletter-999999.0a1.0.tm b/src/modules/punk/blockletter-999999.0a1.0.tm index cf9a4f02..a221675e 100644 --- a/src/modules/punk/blockletter-999999.0a1.0.tm +++ b/src/modules/punk/blockletter-999999.0a1.0.tm @@ -120,17 +120,17 @@ tcl::namespace::eval punk::blockletter { set logo_letter_colours [list Red Green Blue Purple Yellow] punk::args::definition [tstr -return string { - *id punk::blockletter::logo + @id -id ::punk::blockletter::logo -frametype -default {${$default_frametype}} -outlinecolour -default "web-white" -backgroundcolour -default {} -help "e.g Web-white This argument is the name as accepted by punk::ansi::a+" - *values -min 0 -max 0 + @values -min 0 -max 0 }] proc logo {args} { variable logo_letter_colours variable default_frametype - set argd [punk::args::get_by_id punk::blockletter::logo $args] + set argd [punk::args::get_by_id ::punk::blockletter::logo $args] set f [dict get $argd opts -frametype] set bd [dict get $argd opts -outlinecolour] set bgansi [dict get $argd opts -backgroundcolour] ;#we use ta::detect to see if already ansi and apply as necessary @@ -219,17 +219,17 @@ tcl::namespace::eval punk::blockletter { } punk::args::definition [tstr -return string { - *id punk::blockletter::text + @id -id ::punk::blockletter::text -bgcolour -default "Web-red" -bordercolour -default "web-white" -frametype -default {${$default_frametype}} - *values -min 1 -max 1 + @values -min 1 -max 1 str -help "Text to convert to blockletters Requires terminal font to support relevant block characters" " }] proc text {args} { - set argd [punk::args::get_by_id punk::blockletter::text $args] + set argd [punk::args::get_by_id ::punk::blockletter::text $args] set opts [dict get $argd opts] set str [dict get $argd values str] set str [string map {\r\n \n} $str] @@ -281,17 +281,17 @@ tcl::namespace::eval punk::blockletter::lib { punk::args::definition [tstr -return string { - *id punk::blockletter::block + @id -id ::punk::blockletter::block -height -default 2 -width -default 4 -frametype -default {${$::punk::blockletter::default_frametype}} -bgcolour -default "Web-red" -bordercolour -default "web-white" - *values -min 0 -max 0 + @values -min 0 -max 0 }] proc block {args} { upvar ::punk::blockletter::default_frametype ft - set argd [punk::args::get_by_id punk::blockletter::block $args] + set argd [punk::args::get_by_id ::punk::blockletter::block $args] set bg [dict get $argd opts -bgcolour] set bd [dict get $argd opts -bordercolour] set h [dict get $argd opts -height] 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 7cf3c602..45e16713 100644 --- a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm +++ b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm @@ -254,8 +254,9 @@ namespace eval punk::cap::handlers::templates { } method folders {args} { set argd [punk::args::get_dict { + @id -id "::punk::cap::handlers::templates::class::api folders" -startdir -default "" - *values -max 0 + @values -max 0 } $args] set opts [dict get $argd opts] @@ -471,10 +472,11 @@ namespace eval punk::cap::handlers::templates { } method get_itemdict_projectlayouts {args} { set argd [punk::args::get_dict { - *opts -anyopts 1 + @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 + @values -maxvalues -1 } $args] set opt_startdir [dict get $argd opts -startdir] @@ -648,14 +650,15 @@ namespace eval punk::cap::handlers::templates { #and a name determining command -command_get_item_name method _get_itemdict {args} { set argd [punk::args::get_dict { - *proc -name _get_itemdict - *opts -anyopts 0 + @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 + @values -maxvalues -1 globsearches -default * -multiple 1 } $args] set opts [dict get $argd opts] diff --git a/src/modules/punk/config-0.1.tm b/src/modules/punk/config-0.1.tm index 493ea5aa..fbce0905 100644 --- a/src/modules/punk/config-0.1.tm +++ b/src/modules/punk/config-0.1.tm @@ -362,10 +362,10 @@ tcl::namespace::eval punk::config { proc configure {args} { set argdef { - *id punk::config::configure - *proc -name punk::config::configure -help\ + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ "UNIMPLEMENTED" - *values -min 1 -max 1 + @values -min 1 -max 1 whichconfig -type string -choices {startup running stop} } set argd [punk::args::get_dict $argdef $args] @@ -388,15 +388,15 @@ tcl::namespace::eval punk::config { #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration proc copy {args} { set argdef { - *id punk::config::copy - *proc -name punk::config::copy -help\ + @id -id ::punk::config::copy + @cmd -name punk::config::copy -help\ "Copy a partial or full configuration from one config to another If a target config has additional settings, then the source config can be considered to be partial with regards to the target. " -type -default "" -choices {replace merge} -help\ "Defaults to merge when target is running-config Defaults to replace when source is running-config" - *values -min 2 -max 2 + @values -min 2 -max 2 fromconfig -help\ "running or startup or file name (not fully implemented)" toconfig -help\ diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 93668120..3ca98adc 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -875,7 +875,7 @@ namespace eval punk::console { } } - punk::args::set_alias punk::console::code_a+ punk::ansi::a+ + punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ proc code_a+ {args} { variable ansi_wanted if {$ansi_wanted <= 0} { @@ -1187,14 +1187,14 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::definition { - *id punk::console::cell_size + @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list - *values -min 0 -max 1 + @values -min 0 -max 1 newsize -default "" -help\ "character cell pixel dimensions WxH" } proc cell_size {args} { - set argd [punk::args::get_by_id punk::console::cell_size $args] + set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] set newsize [dict get $argd values newsize] diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index 18f75757..87a302a8 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.0.tm @@ -563,9 +563,10 @@ namespace eval punk::du { variable win_reparse_tags_by_int set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" } $args] set opts [dict get $argd opts] @@ -621,10 +622,11 @@ namespace eval punk::du { proc attributes_twapi {args} { set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" } $args] set opts [dict get $argd opts] diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index a1df3a31..be76cded 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -1252,14 +1252,14 @@ namespace eval punk::fileline { #[list_begin definitions] punk::args::definition { - *id punk::fileline::get_textinfo - *proc -name punk::fileline::get_textinfo -help\ + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" -file -default {} -type existingfile -translation -default iso8859-1 -encoding -default "\uFFFF" -includebom -default 0 - *values -min 0 -max 1 + @values -min 0 -max 1 } proc get_textinfo {args} { #*** !doctools @@ -1276,7 +1276,7 @@ namespace eval punk::fileline { #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. - lassign [dict values [punk::args::get_by_id punk::fileline::get_textinfo $args]] opts values + lassign [dict values [punk::args::get_by_id ::punk::fileline::get_textinfo $args]] opts values # -- --- --- --- set opt_file [dict get $opts -file] set opt_translation [dict get $opts -translation] diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index f84dd0af..74680b19 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -1009,13 +1009,13 @@ namespace eval punk::lib { set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " } set argspec [string map [list %sep% $sep] { - *id punk::lib::pdict - *proc -name pdict -help\ + @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 + @opts -any 1 #default separator to provide similarity to tcl's parray function -separator -default "%sep%" @@ -1023,7 +1023,7 @@ namespace eval punk::lib { -substructure -default {} -channel -default stdout -help "existing channel - or 'none' to return as string" - *values -min 1 -max -1 + @values -min 1 -max -1 dictvar -type string -help "name of variable. Can be a dict, list or array" @@ -1095,14 +1095,16 @@ namespace eval punk::lib { package require textblock set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { - *id punk::lib::showdict - *proc -name punk::lib::showdict -help "display dictionary keys and values" + @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 - " + -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" @@ -1114,7 +1116,7 @@ namespace eval punk::lib { -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 + @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" }] $args] @@ -2816,7 +2818,7 @@ namespace eval punk::lib { #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 { -joinchar -default \n - *values -min 1 -max 1 + @values -min 1 -max 1 } $args]] leaders opts values puts "opts:$opts" puts "values:$values" @@ -2857,7 +2859,7 @@ namespace eval punk::lib { #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 { - *opts -any 1 + @opts -any 1 -block -default {} } $args]] leaderdict opts valuedict tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] 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 7515ba22..e10f3347 100644 --- a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm @@ -168,9 +168,10 @@ namespace eval punk::mix::commandset::doc { } proc validate {args} { set argd [punk::args::get_dict { + @id -id ::punk::mix::commandset::doc::validate -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 - *values -min 0 -max -1 + @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 } $args] set opt_individual [tcl::dict::get $argd opts -individual] 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 dcac02a1..93ab90d2 100644 --- a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm @@ -34,7 +34,8 @@ namespace eval punk::mix::commandset::layout { #per layout functions proc files {{layout ""}} { set argd [punk::args::get_dict { - *values -min 1 -max 1 + @id -id ::punk::mix::commandset::layout::files + @values -min 1 -max 1 layout -type string -minsize 1 } [list $layout]] @@ -88,7 +89,8 @@ namespace eval punk::mix::commandset::layout { proc _default {args} { punk::args::get_dict [subst { - *proc -name ::punk::mix::commandset::layout::collection::_default + @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 diff --git a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm index 3e8781e3..6abe2c4e 100644 --- a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm @@ -27,8 +27,8 @@ namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs punk::args::definition { - *id punk::mix::commandset::loadedlib::search - *proc -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" + @id -id ::punk::mix::commandset::loadedlib::search + @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} -present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\ "(unimplemented) Display only those that are 0:absent 1:present 2:either" @@ -38,10 +38,13 @@ namespace eval punk::mix::commandset::loadedlib { searchstrings -default * -multiple 1 -help\ "Names to search for, may contain glob chars (* ?) e.g *lib* If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. - eg name -> *name*" + eg name -> *name* + To search for an exact name prefix it with = + e.g =name -> name + " } proc search {args} { - set argd [punk::args::get_by_id punk::mix::commandset::loadedlib::search $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::loadedlib::search $args] set searchstrings [dict get $argd values searchstrings] set opts [dict get $argd opts] set opt_return [dict get $opts -return] @@ -56,7 +59,7 @@ namespace eval punk::mix::commandset::loadedlib { set packages [package names] set matches [list] foreach search $searchstrings { - if {[regexp {[?*]} $search]} { + if {[regexp {[?*\[]} $search]} { #caller has specified specific glob pattern - use it #todo - respect supplied case only if uppers present? require another flag? lappend matches {*}[lsearch -all -inline -nocase $packages $search] diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm index 714de1e4..8361b730 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm @@ -123,10 +123,11 @@ namespace eval punk::mix::commandset::module { #return all module templates with repeated ones suffixed with .2 .3 etc proc templates_dict {args} { set argspec { - *proc -name templates_dict -help "Templates from module and project paths" + @id -id ::punk::mix::commandset::module::templates_dict + @cmd -name templates_dict -help "Templates from module and project paths" -startdir -default "" -help "Project folder used in addition to module paths" -not -default "" -multiple 1 - *values + @values globsearches -default * -multiple 1 } set argd [punk::args::get_dict $argspec $args] @@ -141,8 +142,8 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] punk::args::definition [subst { - *id punk::mix::commandset::module::new - *proc -name "punk::mix::commandset::module::new" -help\ + @id -id ::punk::mix::commandset::module::new + @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. If the name given in the module argument is namespaced, the necessary subfolder(s) will be used or created." @@ -160,7 +161,7 @@ namespace eval punk::mix::commandset::module { If false (default) an error will be raised if there is a conflict." -quiet -default 0 -type boolean -help\ "Suppress information messages on stdout" - *values -min 1 -max 1 + @values -min 1 -max 1 module -type string -help\ "Name of module, possibly including a namespace and/or version number e.g mynamespace::mymodule-1.0" @@ -168,7 +169,7 @@ namespace eval punk::mix::commandset::module { proc new {args} { set year [clock format [clock seconds] -format %Y] # use \uFFFD because unicode replacement char should consistently render as 1 wide - set argd [punk::args::get_by_id punk::mix::commandset::module::new $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::module::new $args] lassign [dict values $argd] leaders opts values received set module [dict get $values module] 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 4ab332b4..7f50fa87 100644 --- a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm @@ -1262,15 +1262,15 @@ namespace eval punk::mix::commandset::scriptwrap { # [list_begin arguments] # [arg_def string args] name-value pairs -scriptpath # [list_end] - *id punk::mix::commandset::scriptwrap - *proc -name punk::mix::commandset::get_wrapper_folders + @id -id ::punk::mix::commandset::scriptwrap + @cmd -name punk::mix::commandset::get_wrapper_folders - *opts -anyopts 0 + @opts -anyopts 0 -scriptpath -default "" -type directory\ -help "" #todo -help folder within a punk.templates provided area??? - *values -minvalues 0 -maxvalues 0 + @values -minvalues 0 -maxvalues 0 } $args] # -- --- --- --- --- --- --- --- --- diff --git a/src/modules/punk/nav/fs-999999.0a1.0.tm b/src/modules/punk/nav/fs-999999.0a1.0.tm index 268341d1..60baf233 100644 --- a/src/modules/punk/nav/fs-999999.0a1.0.tm +++ b/src/modules/punk/nav/fs-999999.0a1.0.tm @@ -636,13 +636,14 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles + -stripbase -default 1 -type boolean + -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" + @values -min 0 -max -1 + } proc dirfiles {args} { - set argspecs { - -stripbase -default 1 -type boolean - -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" - *values -min 0 -max -1 - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] @@ -726,14 +727,14 @@ tcl::namespace::eval punk::nav::fs { # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied proc dirfiles_dict {args} { set argspecs { - *id punk::nav::fs::dirfiles_dict - *opts -any 0 + @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 + @values -min 0 -max -1 -type string } set argd [punk::args::get_dict $argspecs $args] lassign [dict values $argd] leaders opts vals @@ -991,16 +992,17 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles_dict_as_lines + -stripbase -default 0 -type boolean + -formatsizes -default 1 -type boolean + @values -min 1 -max -1 -type dict + } + #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? proc dirfiles_dict_as_lines {args} { package require overtype - - set argspecs { - -stripbase -default 0 -type boolean - -formatsizes -default 1 -type boolean - *values -min 1 -max -1 -type dict - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles_dict_as_lines $args] lassign [dict values $argd] leaders opts vals set list_of_dicts [dict values $vals] diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 0fc59e13..f043f92a 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -1608,7 +1608,7 @@ tcl::namespace::eval punk::ns { if {$word1 eq "punk::mix::base::_cli"} { #special case for punk deck - REVIEW #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set fq [lindex $tgt end] + set fq [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) @@ -1618,7 +1618,8 @@ tcl::namespace::eval punk::ns { set fq [nsjoin $location $c] } if {$has_punkargs} { - set id [string trimleft $fq :] + #set id [string trimleft $fq :] + set id $fq if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1892,110 +1893,188 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + if {[lsearch -exact $nscommands $querycommand] >= 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]] }]} { - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { #fully qualified command specified but doesn't exist - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { - set thispath [uplevel 1 [list ::nsthis $commandpath]] - set targetns [nsprefix $thispath] - set name [nstail $thispath] - set targetparts [nsparts $targetns] - if {[lsearch $targetparts :*] >=0} { - #weird ns - set valid_ns [nsexists $targetns] + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand } 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 commandpath 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 + set thispath [uplevel 1 [list ::nsthis $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 + set numvals [expr {[llength $queryargs]+1}] + #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]] + + #set origin $querycommand + #set resolved $querycommand + } - } else { - #namespace doesn't seem to exist - but there still could be documentation for lazy loaded ns and command - set origin $commandpath - set resolved $commandpath - } - } - #set thiscmd [nsjoin $targetns $name] - #if {[info commands $thiscmd] eq ""} { - # set origin $thiscmd - # set resolved $thiscmd - #} else { - # set origin [nseval $targetns [list ::namespace origin $name]] - # set resolved [nseval $targetns [list ::namespace which $name]] - #} + } + } #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! - #considure using which_alias (wiki) + #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 fq [lindex $tgt end] + 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 fq $word1 + set targetword $word1 + 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]] } - set origin $fq + + + set origin $targetword #retest cmdtype on modified origin set cmdtype [punk::ns::cmdtype $origin] } else { @@ -2013,6 +2092,83 @@ tcl::namespace::eval punk::ns { } } + + set id $origin + if {[info commands ::punk::args::id_exists] ne ""} { + #cycle through longest first checking for id matching ::cmd ?subcmd..? + #REVIEW - this doesn't cater for prefix callable subcommands! + set argcopy $queryargs + while {[llength $argcopy]} { + if {[punk::args::id_exists [list $id {*}$argcopy]]} { + return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$argcopy]]] + } + lpop argcopy + } + + #didn't find any exact matches + #traverse from other direction taking prefixes into account + + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set def [punk::args::get_def $id] + if {[llength $queryargs]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + foreach q $queryargs { + if {[llength [dict get $def leader_names]]} { + set subitems [dict get $def leader_names] + if {[llength $subitems]} { + set next [lindex $subitems 0] + set arginfo [dict get $def arg_info $next] + + 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 ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices {*}$clist + } + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + 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 numvals [expr {[llength $queryargs]+1}] + return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] + } + #check if subcommands so far have a custom args def + set currentid [list $querycommand {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set def [punk::args::get_def $currentid + } else { + #We can get no further with custom defs + break + } + } + } else { + #review + break + } + } + } else { + return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } + } + } + + if {[string match "(autodef)*" $origin]} { + #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) + set origin [string range $origin [string length (autodef)] end] + set resolved $origin + } + switch -- $cmdtype { object { #class is also an object @@ -2025,19 +2181,19 @@ tcl::namespace::eval punk::ns { #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - if {[llength $commandargs]} { - set c1 [lindex $commandargs 0] + if {[llength $queryargs]} { + set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { switch -- $c1 { new { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} new" - *proc -name "${$origin} new" -help\ + @id -id "(autodef)${$origin} new" + @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 { @@ -2054,17 +2210,17 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin new"] + return [punk::args::usage {*}$opts "(autodef)$origin new"] } create { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} create" - *proc -name "${$origin} create" -help\ + @id -id "(autodef)${$origin} create" + @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" }] @@ -2083,20 +2239,20 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin create"] + return [punk::args::usage {*}$opts "(autodef)$origin create"] } destroy { #review - generally no doc # but we may want notes about a specific destructor set argspec [punk::lib::tstr -return string { - *id "${$origin} destroy" - *proc -name "destroy" -help\ + @id -id "(audodef)${$origin} destroy" + @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." - *values -min 0 -max 0 + @values -min 0 -max 0 }] punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin destroy"] + return [punk::args::usage {*}$opts "(autodef)$origin destroy"] } default { #use info object call to resolve callchain @@ -2111,20 +2267,24 @@ tcl::namespace::eval punk::ns { lassign $impl generaltype mname location methodtype switch -- $generaltype { method - private { - + #objects being dynamic systems - we should always reinspect. + #Don't use the cached (autodef) def + #If there is a custom def override - use it (should really be -dynamic - but we don't check) if {$location eq "object"} { - set id "[string trimleft $origin :] $c1" ;# " " + set idcustom "$origin $c1" + #set id "[string trimleft $origin :] $c1" ;# " " if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info object definition $origin $c1] } else { - set id "[string trimleft $location :] $c1" ;# " " + #set id "[string trimleft $location :] $c1" ;# " " + set idcustom "$location $c1" if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info class definition $location $c1] @@ -2138,12 +2298,15 @@ tcl::namespace::eval punk::ns { } } if {$def ne ""} { + #assert - if we pre + set autoid "(autodef)$location $c1" set arglist [lindex $def 0] set argspec [punk::lib::tstr -return string { - *id "${$location} ${$c1}" - *proc -name "${$location} ${$c1}" -help\ - "arglist:${$arglist}" - *values + @id -id "${$autoid}" + @cmd -name "${$location} ${$c1}" -help\ + "(autogenerated) + arglist:${$arglist}" + @values }] set i 0 foreach a $arglist { @@ -2166,7 +2329,7 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$location $c1"] + return [punk::args::usage {*}$opts $autoid] } else { return "unable to resolve $origin method $c1" } @@ -2189,9 +2352,11 @@ tcl::namespace::eval punk::ns { switch -- $generaltype { method - private { if {$location eq "object"} { - set id "[string trimleft $origin :] $cmd" ;# " " + #set id "[string trimleft $origin :] $cmd" ;# " " + set id "$origin $cmd" } else { - set id "[string trimleft $location :] $cmd" ;# " " + #set id "[string trimleft $location :] $cmd" ;# " " + set id "$location $cmd" } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { @@ -2212,15 +2377,16 @@ tcl::namespace::eval punk::ns { set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" + set idauto "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -name "Object: ${$origin}" -help\ - "Instance of class: ${$class}" - *values -min 1 + @id -id ${$idauto} + @cmd -name "Object: ${$origin}" -help\ + "Instance of class: ${$class} (info autogenerated)" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $idauto] } privateObject { return "Command is a privateObject - no info currently available" @@ -2287,11 +2453,11 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] - if {[llength $commandargs]} { - set match [tcl::prefix::match $subcommands [lindex $commandargs 0]] + 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 $commandargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + 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") } } @@ -2307,9 +2473,9 @@ tcl::namespace::eval punk::ns { 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] + lappend have_usageinfo {*}[dict get $nsinfo usageinfo] + lappend is_ensemble {*}[dict get $nsinfo ensembles] + lappend is_object {*}[dict get $nsinfo ooobjects] } set choicelabeldict [dict create] @@ -2324,14 +2490,17 @@ tcl::namespace::eval punk::ns { } set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set autoid "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -help "ensemble: ${$origin}" - *values -min 1 + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + ensemble: ${$origin}" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2364,12 +2533,6 @@ tcl::namespace::eval punk::ns { } } - set id [string trimleft $origin :] - if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] - } - } set origin_ns [nsprefix $origin] set parts [nsparts $origin_ns] set weird_ns 0 @@ -2379,24 +2542,42 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set argl {} set tail [nstail $origin] - foreach a [nseval_ifexists $origin_ns [list info args $tail]] { - if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { - lappend a $def + set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] + if {$cmdtype eq "proc"} { + foreach a [nseval_ifexists $origin_ns [list info args $tail]] { + if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } else { - set argl {} - foreach a [info args $origin] { - if {[info default $origin $a def]} { - lappend a $def + set cmdtype [punk::ns::cmdtype $origin] + if {$cmdtype eq "proc"} { + set argl {} + set infoargs [info args $origin] + foreach a $infoargs { + if {[info default $origin $a def]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } - set msg "No argument processor detected" - append msg \n "function signature: $resolved $argl" + if {[llength $queryargs]} { + #todo - something better + set msg "Undocumented or nonexistant subcommand $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" + } else { + set msg "Undocumented command $origin. Type: $cmdtype" + } + } return $msg } @@ -2738,8 +2919,8 @@ tcl::namespace::eval punk::ns { interp alias "" use "" punk::ns::pkguse punk::args::definition { - *id punk::ns::nsimport_noclobber - *proc -name punk::ns::nsimport_noclobber -help\ + @id -id ::punk::ns::nsimport_noclobber + @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, or that specified in -targetnamespace. Return list of imported commands, ignores failures due to name conflicts" @@ -2750,14 +2931,14 @@ tcl::namespace::eval punk::ns { If not supplied, caller's namespace is used." -prefix -optional 1 -help\ "string prefix for command names in target namespace" - *values -min 1 -max 1 + @values -min 1 -max 1 sourcepattern -type string -optional 0 -help\ "Glob pattern for source namespace. Globbing only active in the tail segment. e.g ::mynamespace::*" } proc nsimport_noclobber {args} { - lassign [dict values [punk::args::get_by_id punk::ns::nsimport_noclobber $args]] leaders opts values received + lassign [dict values [punk::args::get_by_id ::punk::ns::nsimport_noclobber $args]] leaders opts values received set sourcepattern [dict get $values sourcepattern] set source_ns [tcl::namespace::qualifiers $sourcepattern] diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index e0403382..7e6a0221 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -645,14 +645,14 @@ namespace eval punk::path { } punk::args::definition { - *id punk::path::treefilenames + @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." -call-depth-internal -default 0 -type integer -antiglob_paths -default {} -help\ "list of path patterns to exclude may include * and ** path segments e.g /usr/**" - *values -min 0 -max -1 -optional 1 -type string + @values -min 0 -max -1 -optional 1 -type string tailglobs -multiple 1 -help\ "Patterns to match against filename portion (last segment) of each file path within the directory tree being searched." @@ -671,7 +671,7 @@ namespace eval punk::path { #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para]no natsorting - so order is dependent on filesystem - set argd [punk::args::get_by_id punk::path::treefilenames $args] + set argd [punk::args::get_by_id ::punk::path::treefilenames $args] lassign [dict values $argd] leaders opts values received set tailglobs [dict values $values] # -- --- --- --- --- --- --- diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index 392e0ebf..9f77476c 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -62,6 +62,73 @@ package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- namespace eval punk::repo { + variable PUNKARGS + variable PUNKARGS_aliases + + proc get_fossil_usage {} { + set allcmds [runout -n fossil help -a] + set mainhelp [runout -n fossil help] + set maincommands [list] + foreach ln [split $mainhelp \n] { + set ln [string trim $ln] + if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { + continue + } + lappend maincommands {*}$ln + } + set othercmds [punk::lib::ldiff $allcmds $maincommands] + + set result "@leaders -min 0\n" + + append result [tstr -return string { + subcommand -type string -choicecolumns 8 -choicegroups { + "frequently used commands" {${$maincommands}} + "" {${$othercmds}} + } + }] + + return $result + } + + + #lappend PUNKARGS [list -dynamic 1 { + # @id -id ::punk::repo::fossil_proxy + # @cmd -name fossil -help "fossil executable + # " + # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # } ""] + + lappend PUNKARGS [list -dynamic 1 { + @id -id ::punk::repo::fossil_proxy + @cmd -name fossil -help "fossil executable" + ${[punk::repo::get_fossil_usage]} + } ] + + + + #experiment + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + #TODO + #lappend PUNKARGS [list -dynamic 1 { + # @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]}} + # } ""] + lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} + lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} + #Todo - investigate proper way to install a client-side commit hook in the fossil project #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used @@ -137,7 +204,7 @@ namespace eval punk::repo { puts stderr "fossil command not found. Please install fossil" } } - interp alias "" fossil "" punk::repo::fossil_proxy + # --- # Calling auto_execok on an external tool can be too slow to do during package load (e.g could be 150ms) @@ -153,6 +220,7 @@ namespace eval punk::repo { # ---------- # + #uppercase FOSSIL to bypass fossil as alias to fossil_proxy proc establish_FOSSIL {args} { if {![info exists ::auto_execs(FOSSIL)]} { @@ -161,7 +229,6 @@ namespace eval punk::repo { interp alias "" FOSSIL "" ;#delete establishment alias FOSSIL {*}$args } - interp alias "" FOSSIL "" punk::repo::establish_FOSSIL # ---------- proc askuser {question} { @@ -1577,6 +1644,8 @@ namespace eval punk::repo { } } + interp alias "" fossil "" punk::repo::fossil_proxy + interp alias "" FOSSIL "" punk::repo::establish_FOSSIL interp alias {} is_fossil {} ::punk::repo::is_fossil interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root @@ -1609,6 +1678,17 @@ namespace eval punk::repo::lib { } + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +if {![info exists ::punk::args::register::NAMESPACES]} { + namespace eval ::punk::args::register { + set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace + } +} +lappend ::punk::args::register::NAMESPACES ::punk::repo +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::repo [namespace eval punk::repo { diff --git a/src/modules/punk/safe-999999.0a1.0.tm b/src/modules/punk/safe-999999.0a1.0.tm index 3080b998..d7369119 100644 --- a/src/modules/punk/safe-999999.0a1.0.tm +++ b/src/modules/punk/safe-999999.0a1.0.tm @@ -366,7 +366,7 @@ tcl::namespace::eval punk::safe { #REVIEW set autoPath {} } - set argd [punk::args::get_by_id punk::safe::interpCreate $args] + set argd [punk::args::get_by_id ::punk::safe::interpCreate $args] set child [dict get $argd leaders child] set autoPath [dict get $argd opts -autoPath] punk::safe::lib::RejectExcessColons $child @@ -387,7 +387,7 @@ tcl::namespace::eval punk::safe { if {$AutoPathSync} { set autoPath {} } - set argd [punk::args::get_by_id punk::safe::interpIC $args] + set argd [punk::args::get_by_id ::punk::safe::interpIC $args] set child [dict get $argd leaders child] set autoPath [dict get $argd opts -autoPath] if {![::interp exists $child]} { @@ -437,7 +437,7 @@ tcl::namespace::eval punk::safe { # we know that "child" is our given argument because it also # checks for the "-help" option. #TODO! - set argd [punk::args::get_by_id punk::safe::interpIC $args] + set argd [punk::args::get_by_id ::punk::safe::interpIC $args] set child [dict get $argd leaders child] CheckInterp $child @@ -501,7 +501,7 @@ tcl::namespace::eval punk::safe { } default { #return -code error "unknown flag $name. Known options: $opt_names" - punk::args::get_by_id punk::safe::interpIC [list $child $arg] + punk::args::get_by_id ::punk::safe::interpIC [list $child $arg] } } } @@ -509,7 +509,7 @@ tcl::namespace::eval punk::safe { # Otherwise we want to parse the arguments like init and create did #set Args [::tcl::OptKeyParse ::safe::interpIC $args] - set argd [punk::args::get_by_id punk::safe::interpIC $args] + set argd [punk::args::get_by_id ::punk::safe::interpIC $args] set child [dict get $argd leaders child] CheckInterp $child namespace upvar ::punk::safe::system [VarName $child] state @@ -742,8 +742,8 @@ tcl::namespace::eval punk::safe::system { variable AutoPathSync set OPTS { - *id punk::safe::OPTS - *opts -optional 1 + @id -id ::punk::safe::OPTS + @opts -optional 1 -accessPath -type list -default {} -help\ "access path for the child" -noStatics -type none -default 0 -help\ @@ -765,27 +765,27 @@ tcl::namespace::eval punk::safe::system { set optlines [punk::args::get_spec punk::safe::OPTS -*] set INTERPCREATE { - *id punk::safe::interpCreate - *proc -name punk::safe::interpCreate -help\ + @id -id ::punk::safe::interpCreate + @cmd -name punk::safe::interpCreate -help\ "Create a safe interpreter with punk::safe specific aliases Returns the interpreter name" - *leaders + @leaders child -type string -default "" -regexprefail "^-" -regexprefailmsg "" -optional 1 -help\ "name of the child (optional)" } append INTERPCREATE \n $optlines - append INTERPCREATE \n {*values -max 0} + append INTERPCREATE \n {@values -max 0} punk::args::definition $INTERPCREATE set INTERPIC { - *id punk::safe::interpIC - *leaders + @id -id ::punk::safe::interpIC + @leaders child -type string -optional 0 -regexprefail "^-" -regexprefailmsg "" -help\ "name of the child" } append INTERPIC \n $optlines - append INTERPIC \n {*values -max 0} + append INTERPIC \n {@values -max 0} punk::args::definition $INTERPIC diff --git a/src/modules/punk/sixel-999999.0a1.0.tm b/src/modules/punk/sixel-999999.0a1.0.tm index 57eb1d00..b60aa564 100644 --- a/src/modules/punk/sixel-999999.0a1.0.tm +++ b/src/modules/punk/sixel-999999.0a1.0.tm @@ -142,21 +142,21 @@ tcl::namespace::eval punk::sixel { #we will for now consume all to final ST #TODO - sixel row/col info is dependent on terminal - pass in -terminalobject or -inoutchannels (for use with punk::console::cell_size) punk::args::definition { - *id punk::sixel::get_info - *proc -name punk::sixel::get_info -help\ + @id -id ::punk::sixel::get_info + @cmd -name punk::sixel::get_info -help\ "return a dict of information about the supplied sixelstring" -cache -default 1 -type boolean -help\ "Cached result based on sha1 hash." -cell_size -default "" -help\ "override terminal cell_size. If left empty, attempt to use value from querying terminal." - *values -min 1 -max 1 + @values -min 1 -max 1 sixelstring -type string -help "A single sixel image - currently only 7-bit supported" } variable sixelinfo_cache set sixelinfo_cache [dict create] proc get_info {args} { - set argd [punk::args::get_by_id punk::sixel::get_info $args] + set argd [punk::args::get_by_id ::punk::sixel::get_info $args] set sixelstring [dict get $argd values sixelstring] set do_cache [dict get $argd opts -cache] set cell_size_override [dict get $argd opts -cell_size] diff --git a/src/modules/punk/zip-999999.0a1.0.tm b/src/modules/punk/zip-999999.0a1.0.tm index 5e92941d..30912446 100644 --- a/src/modules/punk/zip-999999.0a1.0.tm +++ b/src/modules/punk/zip-999999.0a1.0.tm @@ -180,10 +180,11 @@ tcl::namespace::eval punk::zip { #}] set argd [punk::args::get_dict { - *proc -name punk::zip::walk + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -excludes -default "" -help "list of glob expressions to match against files and exclude" -subpath -default "" - *values -min 1 -max -1 + @values -min 1 -max -1 base fileglobs -default {*} -multiple 1 } $args] @@ -373,11 +374,12 @@ tcl::namespace::eval punk::zip { #[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 { - *proc -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + @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 + @opts -comment -default "" -help "An optional comment specific to the added file" - *values -min 3 -max 4 + @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" @@ -525,9 +527,10 @@ tcl::namespace::eval punk::zip { #[para] Call 'punk::zip::mkzip' with no arguments for usage display. set argd [punk::args::get_dict { - *proc -name punk::zip::mkzip\ + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ -help "Create a zip archive in 'filename'" - *opts + @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. @@ -557,7 +560,7 @@ tcl::namespace::eval punk::zip { it must be a parent of -directory or the same path as -directory" -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - *values -min 1 -max -1 + @values -min 1 -max -1 filename -type file -default ""\ -help "name of zipfile to create" globs -default {*} -multiple 1\ diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index e1d69015..8b03bb0d 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -123,12 +123,12 @@ tcl::namespace::eval textblock { set choicemsg " (unavailable packages: $unavailable)" } set argd [punk::args::get_dict [tstr -return string { - *id textblock::use_hash - *proc -name "textblock::use_hash" -help\ + @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 + @values -min 0 -max 1 hash_algorithm -choices {${$choices}} -optional 1 -help\ "algorithm choice ${$choicemsg}" }] $args] @@ -423,7 +423,6 @@ tcl::namespace::eval textblock { } } } - my configure {*}$o_opts_table #foreach {k v} $args { # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. @@ -453,6 +452,7 @@ tcl::namespace::eval textblock { -minheight 1\ -maxheight ""\ ] + my configure {*}$o_opts_table } method width_algorithm {{alg ""}} { @@ -593,7 +593,7 @@ tcl::namespace::eval textblock { tcl::dict::set o_opts_table_effective -framelimits_header $hlims return [tcl::dict::create body $blims header $hlims] } - method configure args { + method configure {args} { #*** !doctools #[call class::table [method configure] [arg args]] #[para] get or set various table-level properties @@ -781,6 +781,14 @@ tcl::namespace::eval textblock { } } } + -title { + set twidth [punk::ansi::printing_length $v] + if {[my width] < [expr {$twidth+2}]} { + set o_calculated_column_widths [list] + tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] + } + tcl::dict::set o_opts_table -title $v + } default { tcl::dict::set o_opts_table $k $v } @@ -3943,14 +3951,13 @@ tcl::namespace::eval textblock { if {$header_build eq "" && ![llength $body_blocks]} { set header_build $nextcol_header - lappend body_blocks $nextcol_body } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] } - lappend body_blocks $nextcol_body #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } + lappend body_blocks $nextcol_body incr padwidth $bodywidth incr colposn } @@ -4096,8 +4103,8 @@ tcl::namespace::eval textblock { } punk::args::definition { - *id textblock::periodic - *proc -name textblock::periodic -help "A rudimentary periodic table + @id -id ::textblock::periodic + @cmd -name textblock::periodic -help "A rudimentary periodic table This is primarily a test of textblock::class::table" -return -default table\ @@ -4109,13 +4116,13 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id textblock::periodic $args] opts] + set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -4345,7 +4352,10 @@ tcl::namespace::eval textblock { set FRAMETYPES [textblock::frametypes] punk::args::definition [punk::lib::tstr -return string { - *id textblock::list_as_table + @id -id ::textblock::list_as_table + @cmd -name "textblock::list_as_table" -help\ + "Display a list in a bordered table + " -return -default table -choices {table tableobject} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ @@ -4376,13 +4386,13 @@ tcl::namespace::eval textblock { -help "Number of table columns Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 + @values -min 0 -max 1 datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" }] proc list_as_table {args} { set FRAMETYPES [textblock::frametypes] - set argd [punk::args::get_by_id textblock::list_as_table $args] + set argd [punk::args::get_by_id ::textblock::list_as_table $args] set opts [dict get $argd opts] set datalist [dict get $argd values datalist] @@ -4894,7 +4904,7 @@ tcl::namespace::eval textblock { #review!? #-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line - set usage "pad ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" + set usage "pad block ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" foreach {k v} $args { switch -- $k { -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { @@ -5420,16 +5430,21 @@ tcl::namespace::eval textblock { return [punk::lib::list_as_lines -- $outlines] } + + punk::args::definition { + @id -id ::textblock::join_basic + @cmd -name textblock::join_basic -help\ + "Join blocks of text 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 + " + -- -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 + } + #join without regard to each line length in a block (no padding added to make each block uniform) proc ::textblock::join_basic {args} { - #*proc -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 { - -- -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 argd [punk::args::get_by_id ::textblock::join_basic $args] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5466,7 +5481,7 @@ tcl::namespace::eval textblock { return [::join $outlines \n] } proc ::textblock::join_basic2 {args} { - #*proc -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + #@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 { @@ -6046,8 +6061,8 @@ tcl::namespace::eval textblock { if {$bad_option || [llength $values] == 0} { #no framedef supplied, or unrecognised opt seen set spec [string map [list $::textblock::frametypes] { - *id textblock::framedef - *proc -name textblock::framedef\ + @id -id ::textblock::framedef + @cmd -name textblock::framedef\ -help "Return a dict of the elements that make up a frame border. May return a subset of available elements based on memberglob values." @@ -6058,7 +6073,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - *values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -7438,17 +7453,17 @@ tcl::namespace::eval textblock { set frame_cache [tcl::dict::create] punk::args::definition { - *id textblock::frame_cache - *proc -name textblock::frame_cache -help\ + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ "Display or clear the frame cache." -action -default {} -choices {clear} -help\ "Clear the textblock::frame_cache dictionary" -pretty -default 1 -help\ "Use 'pdict textblock::frame_cache */*' for prettier output" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc frame_cache {args} { - set argd [punk::args::get_by_id textblock::frame_cache $args] + set argd [punk::args::get_by_id ::textblock::frame_cache $args] set action [dict get $argd opts -action] if {$action ni [list clear ""]} { @@ -7490,13 +7505,40 @@ tcl::namespace::eval textblock { } + variable FRAMETYPES set FRAMETYPES [textblock::frametypes] + variable EG set EG [a+ brightblack] + variable RST set RST [a] + + proc frame_samples {} { + set FRAMETYPELABELS [dict create] + if {[info commands ::textblock::frame] ne ""} { + foreach ft [frametypes] { + dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] + } + } + set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] + return $FRAMETYPELABELS + } + #proc EG {} "return {[a+ brightblack]}" + #make EG fetch from SGR cache so as to abide by colour off/on + proc EG {} { + a+ brightblack + } + #proc RST {} "return {\x1b\[m}" + proc RST {} { + return "\x1b\[m" + } + + #catch 22 for -choicelabels - need some sort of lazy evaluation + # ${[textblock::frame_samples]} + #todo punk::args alias for centre center etc? - punk::args::definition [punk::lib::tstr -return string { - *id textblock::frame - *proc -name "textblock::frame"\ + punk::args::definition -dynamic 1 { + @id -id ::textblock::frame + @cmd -name "textblock::frame"\ -help "Frame a block of text with a border." -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and @@ -7504,18 +7546,21 @@ tcl::namespace::eval textblock { Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." - -type -default light -choices {${$FRAMETYPES}} -choicerestricted 0 -type dict\ + -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ + -choicelabels { + ${[textblock::frame_samples]} + }\ -help "Type of border for frame." -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. passing an empty string will result in no box, but title/subtitle will still appear if supplied. - ${$EG}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${$RST}" + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. May contain ANSI - no trailing reset required. - ${$EG}e.g 1: frame -title My[a+ green]Green[a]Thing - e.g 2: frame -title [a+ red underline]MyThing${$RST}" + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" -subtitle -default "" -type string -regexprefail {\n}\ -help "Frame subtitle placed on bottombar - no newlines May contain Ansi - no trailing reset required." @@ -7526,8 +7571,8 @@ tcl::namespace::eval textblock { -help "Height of resulting frame including borders." -ansiborder -default "" -type ansistring\ -help "Ansi escape sequence to set border attributes. - ${$EG}e.g 1: frame -ansiborder [a+ web-red] contents - e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${$RST}" + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" -ansibase -default "" -type ansistring\ -help "Default ANSI attributes within frame." -blockalign -default centre -choices {left right centre}\ @@ -7547,13 +7592,13 @@ tcl::namespace::eval textblock { Frame width doesn't adapt and content may be truncated so -width may need to be manually set to display more." - *values -min 0 -max 1 + @values -min 0 -max 1 contents -default "" -type string\ -help "Frame contents - may be a block of text containing newlines and ANSI. Text may be 'ragged' - ie unequal line-lengths. No trailing ANSI reset required. - ${$EG}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${$RST}" - }] + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } #options before content argument - which is allowed to be absent #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. @@ -7638,7 +7683,7 @@ tcl::namespace::eval textblock { #only use punk::args if check_args is true or our basic checks failed #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { - set argd [punk::args::get_by_id textblock::frame $args] + set argd [punk::args::get_by_id ::textblock::frame $args] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8346,18 +8391,18 @@ tcl::namespace::eval textblock { } } punk::args::definition { - *id textblock::gcross + @id -id ::textblock::gcross -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block Only cross sizes that divide the size of the overall block will be used. e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. " - *values -min 0 -max 1 + @values -min 0 -max 1 size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id textblock::gcross $args] + set argd [punk::args::get_by_id ::textblock::gcross $args] set size [dict get $argd values size] set opts [dict get $argd opts] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm index f0e34919..0d9cd0bc 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm @@ -402,7 +402,10 @@ tcl::namespace::eval overtype { set looplimit [expr {[tcl::string::length $overblock] + 10}] } - set scheme 3 + #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height + #lassign [blocksize $overblock] _w overblock_width _h overblock_height + + set scheme 4 switch -- $scheme { 0 { #one big chunk @@ -443,11 +446,18 @@ tcl::namespace::eval overtype { set inputchunks [lindex [list $lflines [unset lflines]] 0] } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks [string cat $ln \n] + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + } + } } - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height set replay_codes_underlay [tcl::dict::create 1 ""] @@ -495,7 +505,7 @@ tcl::namespace::eval overtype { } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderargs [list -experimental $opt_experimental\ + set renderopts [list -experimental $opt_experimental\ -cp437 $opt_cp437\ -info 1\ -crm_mode [tcl::dict::get $vtstate crm_mode]\ @@ -510,11 +520,8 @@ tcl::namespace::eval overtype { -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ - $undertext\ - $overtext\ ] - set LASTCALL $renderargs - set rinfo [renderline {*}$renderargs] + set rinfo [renderline {*}$renderopts $undertext $overtext] set instruction [tcl::dict::get $rinfo instruction] tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] @@ -1237,8 +1244,8 @@ tcl::namespace::eval overtype { append debugmsg "looplimit $looplimit reached\n" append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $LASTCALL -cursor_column]\n" + append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" + append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" tcl::dict::for {k v} $rinfo { append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm index 9440ae9c..1a9ab766 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -306,10 +306,11 @@ namespace eval punk { #get last command result that was run through the repl proc ::punk::get_runchunk {args} { set argd [punk::args::get_dict { - *opts + @id -id ::punk::get_runchunk + @opts -1 -optional 1 -type none -2 -optional 1 -type none - *values -min 0 -max 0 + @values -min 0 -max 0 } $args] #todo - make this command run without truncating previous runchunks set runchunks [tsv::array names repl runchunks-*] @@ -7152,8 +7153,8 @@ namespace eval punk { } punk::args::definition { - *id punk::inspect - *proc -name punk::inspect -help\ + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. The raw value arguments (not options) are always returned to pass forward in the pipeline. @@ -7227,9 +7228,9 @@ namespace eval punk { Does not affect return value." -- -type none -help\ "End of options marker. - It is advisable to use this, as data in a pipeline may often being with -" + It is advisable to use this, as data in a pipeline may often begin with -" - *values -min 0 -max -1 + @values -min 0 -max -1 arg -type string -optional 1 -multiple 1 -help\ "value to display" } @@ -7261,7 +7262,7 @@ namespace eval punk { foreach {k v} $flags { if {$k ni [dict keys $defaults]} { #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" - punk::args::get_by_id punk::inspect $args + punk::args::get_by_id ::punk::inspect $args } } set opts [dict merge $defaults $flags] 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 452092e7..a3f9c0b5 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 @@ -134,27 +134,27 @@ tcl::namespace::eval punk::ansi::class { } lappend ::punk::ansi::class::PUNKARGS [list { - *id "punk::ansi::class::class_ansi render_to_input_line" - *proc -name "punk::ansi::class::class_ansi render_to_input_line" -help\ + @id -id "::punk::ansi::class::class_ansi render_to_input_line" + @cmd -name "punk::ansi::class::class_ansi render_to_input_line" -help\ "render string from line 0 to line (experimental/debug)" -dimensions -type string -help\ "WxH where W is integer width >= 1 and H is integer heigth >= 1" -minus -type integer -help\ "number of chars to exclude from end" - *values -min 1 -max 1 + @values -min 1 -max 1 line -type indexexpression }] method render_to_input_line {args} { if {[llength $args] < 1} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set opts [tcl::dict::create\ -dimensions 80x24\ @@ -167,7 +167,7 @@ tcl::namespace::eval punk::ansi::class { } default { puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } } } @@ -588,20 +588,20 @@ tcl::namespace::eval punk::ansi { } lappend PUNKARGS [list -dynamic 1 { - *id punk::ansi::example - *proc -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console + @id -id ::punk::ansi::example + @cmd -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console " -colwidth -default 82 -help "Width of each column - default of 82 will fit a standard 80wide ansi image (when framed) You can specify a narrower width to truncate images on the right side" -folder -default "${[punk::ansi::Get_ansifolder]}" -help "Base folder for files if relative paths are used. Defaults to /src/testansi - where projectbase is determined from current directory. " - *values -min 0 -max -1 + @values -min 0 -max -1 files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help "List of filenames - leave empty to display 4 defaults" } ""] proc example {args} { - set argd [punk::args::get_by_id punk::ansi::example $args] + set argd [punk::args::get_by_id ::punk::ansi::example $args] set colwidth [dict get $argd opts -colwidth] set ansifolder [file normalize [dict get $argd opts -folder]] set fnames [dict get $argd values files] @@ -2355,21 +2355,21 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #sgr_cache clear called by punk::console::ansi when set to off #punk::args depends on punk::ansi - REVIEW + lappend PUNKARGS [list { + @id -id ::punk::ansi::sgr_cache + @cmd -name punk::ansi::sgr_cache -help\ + "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) + " + -action -default "" -choices "clear" -help\ + "-action clear will unset the keys in the punk::ansi::sgr_cache dict + This is called automatically when setting 'colour false' in the console" + + -pretty -default 1 -type boolean -help\ + "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" + @values -min 0 -max 0 + }] proc sgr_cache {args} { - set argdef { - *id punk::ansi::sgr_cache - *proc -name punk::ansi::sgr_cache -help\ - "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) - " - -action -default "" -choices "clear" -help\ - "-action clear will unset the keys in the punk::ansi::sgr_cache dict - This is called automatically when setting 'colour false' in the console" - - -pretty -default 1 -type boolean -help\ - "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" - *values -min 0 -max 0 - } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::get_by_id ::punk::ansi::sgr_cache $args] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] @@ -2412,34 +2412,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return [join $lines \n] } - lappend PUNKARGS [list { - *id punk::ansi::a+ - *proc -name "punk::ansi::a+" -help\ - "Returns an ANSI sgr escape sequence based on the list of supplied codes. - Unlike punk::ansi::a - it is not prefixed with an ANSI reset. - " - *values -min 0 -max -1 - } [string map [list [dict keys $SGR_map]] { - code -type string -optional 1 -multiple 1 -choices {} -choiceprefix 0 -choicerestricted 0 -help\ - "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. - A leading capital letter indicates a codename applies to the background colour. - Other accepted codes are: - term- Term- foreground/background where int is 0-255 terminal color - term- Term- foreground/background - rgb--- Rgb--- foreground/background where are the - 0-255 int values for red, green and blue. - rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 - web- Web- - - The acceptable values for and can be queried using - punk::ansi::a? term - and - punk::ansi::a? web - - Example to set foreground red and background cyan followed by a reset: - set str \"[a+ red Cyan]sample text[a]\" - " - }]] + #PUNKARGS doc performed below, after we create the proc proc a+ {args} { #*** !doctools #[call [fun a+] [opt {ansicode...}]] @@ -2907,6 +2880,41 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $result } + set SGR_samples [dict create] + foreach k [dict keys $SGR_map] { + dict set SGR_samples $k "[punk::ansi::a+ $k]sample\x1b\[m" + } + lappend PUNKARGS [list { + @id -id ::punk::ansi::a+ + @cmd -name "punk::ansi::a+" -help\ + "Returns an ANSI sgr escape sequence based on the list of supplied codes. + Unlike punk::ansi::a - it is not prefixed with an ANSI reset. + " + @values -min 0 -max -1 + } [string map [list [dict keys $SGR_map] $SGR_samples] { + code -type string -optional 1 -multiple 1 -choices {}\ + -choicelabels {}\ + -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ + "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. + A leading capital letter indicates a codename applies to the background colour. + Other accepted codes are: + term- Term- foreground/background where int is 0-255 terminal color + term- Term- foreground/background + rgb--- Rgb--- foreground/background where are the + 0-255 int values for red, green and blue. + rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 + web- Web- + + The acceptable values for and can be queried using + punk::ansi::a? term + and + punk::ansi::a? web + + Example to set foreground red and background cyan followed by a reset: + set str \"[a+ red Cyan]sample text[a]\" + " + }]] + proc a {args} { #*** !doctools #[call [fun a] [opt {ansicode...}]] @@ -4281,6 +4289,7 @@ tcl::namespace::eval punk::ansi { } 4 { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines + #e.g hyper on windows if {[llength $paramsplit] == 1} { tcl::dict::set codestate underline 4 } else { @@ -4634,6 +4643,8 @@ tcl::namespace::eval punk::ansi::ta { #[list_begin definitions] tcl::namespace::path ::punk::ansi + variable PUNKARGS + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position @@ -4706,15 +4717,31 @@ tcl::namespace::eval punk::ansi::ta { #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::ansi::ta::detect + @cmd -name punk::ansi::ta::detect -help\ + "Return a boolean indicating whether Ansi codes were detected in text. + Important caveat: + When text is a tcl list made from splitting (or lappending) some ansi string + - individual elements may be braced or have certain chars escaped. + (one example is if a list element contains an unbalanced brace) + This can cause square brackets that form part of the ansi to be backslash escaped + - and the function can fail to match it as an Ansi code. + " + @values -min 1 + text -type string + } ] + + #*** !doctools + #[call [fun detect] [arg text]] + #[para]Return a boolean indicating whether Ansi codes were detected in text + #[para]Important caveat: + #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) + #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match + #detect any ansi escapes #review - only detect 'complete' codes - or just use the opening escapes for performance? proc detect {text} [string map [list [list $re_ansi_detect]] { - #*** !doctools - #[call [fun detect] [arg text]] - #[para]Return a boolean indicating whether Ansi codes were detected in text - #[para]Important caveat: - #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) - #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match regexp $text }] @@ -7405,7 +7432,7 @@ if {![info exists ::punk::args::register::NAMESPACES]} { set NAMESPACES [list] } } -lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class +lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class ::punk::ansi::ta # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index 5a589fe3..2c9c77fa 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -50,14 +50,14 @@ #[example { # proc dofilestuff {args} { # lassign [dict values [punk::args::get_dict { -# *proc -help "do some stuff with files e.g dofilestuff " -# *opts -type string +# @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 +# @values -min 1 -max -1 # } $args]] leaders opts values # # puts "translation is [dict get $opts -translation]" @@ -67,8 +67,8 @@ # } #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for *values -#[para]valid * lines being with *proc *leaders *opts *values +#[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: @@ -81,7 +81,7 @@ # -directory -default "" # -translation -default binary # -nocomplain -type none -# *values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 # } $args]] leaders opts values @@ -89,7 +89,7 @@ # 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]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 @@ -279,11 +279,140 @@ tcl::namespace::eval punk::args { #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 - lappend PUNKARGS [list { - *id punk::args::definition - *proc -name punk::args::definition -help\ + 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::definition + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::definition -help\ "Accepts a line-based definition of command arguments. - The definition should usually contain a line of the form: *id someid + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + options: -id + %B%@cmd%N% ?opt val...? + options -name -help + %B%@leaders%N% ?opt val...? + options -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + options -any + %B%@values%N% ?opt val...? + options -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + options -header (text for header row of table) + -body (text to replace entirety of autogenerated docs) + %B%@doc%N% ?opt val...? + options -name -url + + 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 + 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 value or option. + + 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 options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + -default + -multiple (for leaders & values defines whether + subsequent received values are stored agains the same + argument name - only applies to final leader or value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - no necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -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\} @@ -292,20 +421,20 @@ tcl::namespace::eval punk::args { 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 not usually significant, perhaps on the order of a few hundred uS, - but -dynamic true might be less desirable if the command is used in inner - loops in more performance-sensitive code. + 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 + @values -min 1 -max -1 text -type string -multiple 1 -help\ "Block(s) of text representing the argument specification 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. - e.g + e.g the following definition passes 2 blocks as text arguments definition { - *id myns::myfunc - *proc -name myns::myfunc -help\\ + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ \"Description of command\" #The following option defines an option-value pair @@ -314,13 +443,13 @@ tcl::namespace::eval punk::args { -flag1 -default 0 -type none -help\\ \"Info about flag1\" - *values -min 1 -max -1 + @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 definition {args} { variable argdata_cache variable argdefcache_by_id @@ -482,6 +611,7 @@ tcl::namespace::eval punk::args { 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]} { @@ -522,9 +652,10 @@ tcl::namespace::eval punk::args { set linebuild "" } } - set proc_info {} + set cmd_info {} set id_info {} ;#e.g -children ?? set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table set parser_info {} set leader_min "" #set leader_min 0 @@ -543,27 +674,50 @@ tcl::namespace::eval punk::args { "" - # {continue} } set linespecs [lassign $trimln argname] - if {$argname ne "*id" && [llength $linespecs] % 2} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs'" + if {[llength $linespecs] % 2 != 0} { + error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" } set firstchar [tcl::string::index $argname 0] set secondchar [tcl::string::index $argname 1] - if {$firstchar eq "*" && $secondchar ne "*"} { - set starspecs $linespecs + if {$firstchar eq "@" && $secondchar ne "@"} { + set at_specs $linespecs + switch -- [tcl::string::range $argname 1 end] { id { - #id line must have single entry - a unique id assigned by the user - an id will be allocated if no id line present or the value is "auto" - if {[llength $starspecs] == 0} { - error "punk::args::definition - *id line must have at least a single entry following *id." - } + #id An id will be allocated if no id line present or the -id value is "auto" if {$spec_id ne ""} { - #disallow duplicate *id line - error "punk::args::definition - *id already set. Existing value $spec_id" + #disallow duplicate @id line + error "punk::args::definition - @id already set. Existing value $spec_id" } - set spec_id [lindex $starspecs 0] - set id_info [lrange $starspecs 1 end] - if {[llength $id_info] %2} { - error "punk::args::definition - bad *id line. Remaining items on line after *id must be in paired option-value format - received '$linespecs'" + if {[dict exists $at_specs -id]} { + set spec_id [dict get $at_specs -id] + } else { + set spec_id auto + } + set id_info $at_specs + } + default { + #copy from an identified set of defaults (another argspec id) can be multiple + if {[dict exists $at_specs -id]} { + set copyfrom [get_def [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] + } + 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??? + } } } parser { @@ -596,27 +750,32 @@ tcl::namespace::eval punk::args { # 1 anykeys {0 info} # } #todo - set parser_info $starspecs + set parser_info $at_specs } - proc { + cmd { #allow arbitrary - review - set proc_info $starspecs + set cmd_info [dict merge $cmd_info $at_specs] } doc { - set doc_info $starspecs + 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 { if {$argspace eq "values"} { - error "punk::args::definition - *opts declaration must come before *values - received '$linespecs'" + error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" } set argspace "options" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -any - -anyopts { set opt_any $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } @@ -662,26 +821,26 @@ tcl::namespace::eval punk::args { tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *opts line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } } } leaders { if {$argspace in [list options values]} { - error "punk::args::definition - *leaders declaration must come before all options and values" + error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" } - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" } set leader_min $v #if {$leader_max == 0} { @@ -691,15 +850,16 @@ tcl::namespace::eval punk::args { -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" } set leader_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set leaderspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset leaderspec_defaults $k2 @@ -741,12 +901,12 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *leaders line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } } @@ -754,27 +914,28 @@ tcl::namespace::eval punk::args { } values { set argspace "values" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" } set val_min $v } -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" } set val_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset valspec_defaults $k2 @@ -816,19 +977,19 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *values line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } } } default { - error "punk::args::definition - unrecognised * line in '$ln'. Expected *proc *leaders *opts or *values - use **name if paramname needs to be *name" + error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" } } continue @@ -836,15 +997,15 @@ tcl::namespace::eval punk::args { if {$argspace eq "leaders"} { set argspace "options" } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before *values" + error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" } set argspecs $linespecs tcl::dict::set argspecs -ARGTYPE option lappend opt_names $argname set is_opt 1 } else { - if {$firstchar eq "*"} { - #allow basic ** escaping for literal argname that begins with * + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } set argspecs $linespecs @@ -898,7 +1059,7 @@ tcl::namespace::eval punk::args { lappend opt_solos $argname } else { #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname'" + error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } } any - anything { @@ -916,18 +1077,18 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choiceprefix - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -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 + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines #review -solo 1 vs -type none ? conflicting values? tcl::dict::set spec_merged $spec $specval } -validationtransform { #string is dict only 8.7/9+ if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary" + error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" } dict for {tk tv} $specval { switch -- $tk { @@ -935,18 +1096,18 @@ tcl::namespace::eval punk::args { } default { set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys" + error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" } } } } default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choiceprefix -choicerestricted\ + set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" + error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" } } } @@ -983,6 +1144,11 @@ tcl::namespace::eval punk::args { } } + if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + variable id_counter + set spec_id "autoid_[incr id_counter]" + } + # REVIEW #if {[llength $val_names] || $val_min > 0} { # #some values are specified @@ -995,23 +1161,19 @@ tcl::namespace::eval punk::args { #no values specified - we can allow last leader to be multiple foreach leadername [lrange $leader_names 0 end-1] { if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple" + error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" } } #} #confirm any valnames before last don't have -multiple key foreach valname [lrange $val_names 0 end-1] { if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple" + error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" } } - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { - variable id_counter - set spec_id "autoid_[incr id_counter]" - } - #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) + #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) set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize @@ -1043,8 +1205,9 @@ tcl::namespace::eval punk::args { val_max $val_max\ valspec_defaults $valspec_defaults\ val_checks_defaults $val_checks_defaults\ - proc_info $proc_info\ + cmd_info $cmd_info\ doc_info $doc_info\ + argdisplay_info $argdisplay_info\ id_info $id_info\ ] tcl::dict::set argdata_cache $cache_key $argdata_dict @@ -1081,7 +1244,6 @@ tcl::namespace::eval punk::args { return $result } } - return } proc get_spec_values {id {patternlist *}} { variable argdefcache_by_id @@ -1098,6 +1260,7 @@ tcl::namespace::eval punk::args { set def [dict remove $def -ARGTYPE] append result \n "$v $def" } + return $result } else { foreach pat $patternlist { set matches [dict keys $arg_info $pat] @@ -1111,19 +1274,28 @@ tcl::namespace::eval punk::args { return $result } } - return } #proc get_spec_leaders ?? #proc get_spec_opts ?? + proc get_def {id} { + if {[id_exists $id]} { + return [definition {*}[get_spec $id]] + } + } + proc is_dynamic {id} { + set spec [get_spec $id] + return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ] + } + variable aliases set aliases [dict create] lappend PUNKARGS [list { - *id punk::args::get_ids - *proc -name punk::args::get_ids -help\ + @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 + @values -min 0 -max 1 match -default * -help\ "exact id or glob pattern for ids" }] @@ -1182,23 +1354,37 @@ tcl::namespace::eval punk::args { set loaded_packages [list] proc update_definitions {} { + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - get's 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 variable loaded_packages upvar ::punk::args::register::NAMESPACES pkgs if {[llength $loaded_packages] == [llength $pkgs]} { #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. return {} } + # -- --- --- --- --- --- + set unloaded [punklib_ldiff $pkgs $loaded_packages] set newloaded [list] foreach pkgns $unloaded { + #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { foreach deflist [set ${pkgns}::PUNKARGS] { namespace eval $pkgns [list punk::args::definition {*}$deflist] } } + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } } errMsg]} { - lappend loaded_pkgs $pkgns + lappend loaded_packages $pkgns lappend newloaded $pkgns } else { puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" @@ -1273,7 +1459,8 @@ tcl::namespace::eval punk::args { set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error dict for {k v} $args { - switch -- $k { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + switch -- $fullk { -badarg { set badarg $v } @@ -1285,7 +1472,7 @@ tcl::namespace::eval punk::args { set as_error $v } -return { - if {$v ni {string table tableobject}} { + 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" } @@ -1293,7 +1480,7 @@ tcl::namespace::eval punk::args { } default { set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return" + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" } } } @@ -1328,14 +1515,22 @@ tcl::namespace::eval punk::args { append errmsg \n } } - set procname [Dict_getdef $spec_dict proc_info -name ""] - set prochelp [Dict_getdef $spec_dict proc_info -help ""] + set procname [Dict_getdef $spec_dict cmd_info -name ""] + set prochelp [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 ""] + set blank_header_col [list] if {$procname ne ""} { lappend blank_header_col "" set procname_display [a+ brightwhite]$procname[a] @@ -1344,7 +1539,8 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { lappend blank_header_col "" - set prochelp_display [a+ brightwhite]$prochelp[a] + #set prochelp_display [a+ brightwhite]$prochelp[a] + set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] } else { set prochelp_display "" } @@ -1354,18 +1550,32 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } if {$use_table} { set t [textblock::class::table new [a+ brightyellow]Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $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 {$procname ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] } else { lappend errlines "PROC/METHOD: $procname_display" } @@ -1373,7 +1583,7 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] } else { lappend errlines "Description: $prochelp_display" } @@ -1384,225 +1594,352 @@ tcl::namespace::eval punk::args { set docurl [punk::ansi::hyperlink $docurl] } if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display] + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] } else { lappend errlines "$docname $docurl_display" } incr h } if {$use_table} { - $t configure_header $h -values {Arg Type Default Multi Help} + 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-- " } - - set RST [a] - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + 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_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] - $trie destroy - foreach c [dict get $spec_dict opt_names] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } + + set RST [a] + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG [a+ brightred] + set greencheck [a+ brightgreen]\u2713[a] ;#green tick + set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX [a+ green] ;#use a+ so colour off can apply + if {$A_PREFIX eq ""} { + 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 opt_names [dict get $spec_dict opt_names] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict opt_names]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } } else { - set default "" + set opt_names [dict get $spec_dict opt_names] + set opt_names_display $opt_names } - set help [Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" + } + set leading_val_names [dict get $spec_dict leader_names] + set trailing_val_names [dict get $spec_dict val_names] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { - set casemsg " (case sensitive)" + set default "" } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices } else { - set prefixmsg "" + set choicegroups [dict merge [dict create "" $choices] $choicegroups] } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [list] - append help " Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } } - lappend formattedchoices $cdisplay + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] } } else { - set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - set prefix $c - set tail "" + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] + set formattedchoices $choicegroups } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + + } + } + 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 [a+ cyan]$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + #bold as well as brightcolour in case colour off. + append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + } else { + append help \n + } + append help \n [join $formatted \n] } - lappend formattedchoices $cdisplay - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + } 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 "" " [a+ red](no choices defined for main group)[a]" + } else { + dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + } + } else { + if {$groupname eq ""} { + append help \n " " [a+ red](no choices defined)[a] + } else { + append help \n " " [a+ red](no choices defined for group $groupname)[a] } - lappend formattedchoices $cdisplay } + } + } + 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]} { + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" } else { - set formattedchoices [dict get $arginfo -choices] + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" } - } } - set numcols 4 ;#todo - dynamic? - if {[llength $formattedchoices] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formattedchoices] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices] - append help \n[textblock::join -- " " $choicetable] - } else { - append help \n [join $formattedchoices \n] - } + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck } 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. - append help \n " " [a+ red](no choices defined)[a] + set multiple "" } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - 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]} { + 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 {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - 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 + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow[a] TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - lappend errlines "$argshow TYPE:$typeshow DEFAULT:$default MULTI:$multiple HELP:$help\n" } } - } + } ;#end is_custom_argdisplay if {$use_table} { $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] $t configure -maxwidth 80 ;#review - append errmsg [$t print] if {$returntype ne "tableobject"} { + append errmsg [$t print] #returntype of table means just the text of the table $t destroy } @@ -1640,19 +1977,26 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::usage - *proc -name punk::args::usage -help\ - "return usage information as a string - in table form." + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command. + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and not have an id. + 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 this as necessary. + " -return -default table -choices {string table tableobject} - *values -min 0 -max 1 + @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::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] set speclist [get_spec $id] if {[llength $speclist] == 0} { @@ -1662,9 +2006,9 @@ tcl::namespace::eval punk::args { } lappend PUNKARGS [list { - *id punk::args::get_by_id - *proc -name punk::args::get_by_id - *values -min 1 + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 id arglist -default "" -type list -help\ "list containing arguments to be parsed as per the @@ -1703,8 +2047,8 @@ tcl::namespace::eval punk::args { #[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 *proc *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. + #[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. @@ -1713,12 +2057,12 @@ tcl::namespace::eval punk::args { #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { - # *opts + # @opts # -opt1 -default {} # -opt2 -default { # etc # } - # *values -multiple 1 + # @values -multiple 1 #} $args #if {[llength $args] == 0} { @@ -2014,7 +2358,7 @@ tcl::namespace::eval punk::args { } if {$opt_any} { set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $opt_checks_defaults if {[tcl::dict::get $arg_info $a -type] ne "none"} { @@ -2023,7 +2367,6 @@ tcl::namespace::eval punk::args { } else { tcl::dict::set opts $a $newval } - lappend flagsreceived $a ;#adhoc flag as supplied if {[incr i] > $maxidx} { arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a } @@ -2041,11 +2384,12 @@ tcl::namespace::eval punk::args { } incr vals_remaining_possible -1 } + lappend flagsreceived $a ;#adhoc flag as supplied } else { if {[llength $opt_names]} { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while *opts -any 0" + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } arg_error $errmsg $argspecs -badarg $fullopt } @@ -2096,6 +2440,7 @@ tcl::namespace::eval punk::args { } 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 arg_info $positionalidx $leaderspec_defaults @@ -2132,7 +2477,8 @@ tcl::namespace::eval punk::args { } else { if {$in_multiple ne ""} { tcl::dict::lappend values_dict $in_multiple $val - #name already seen + #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 arg_info $positionalidx $valspec_defaults @@ -2228,7 +2574,7 @@ tcl::namespace::eval punk::args { set defaultval [tcl::dict::get $thisarg -default] } set type [tcl::dict::get $thisarg -type] - set has_choices [tcl::dict::exists $thisarg -choices] + 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] @@ -2259,10 +2605,22 @@ tcl::namespace::eval punk::args { if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set nocase [tcl::dict::get $thisarg -nocase] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + 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 clist} $choicegroups { + lappend allchoices {*}$clist + } + } + #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 @@ -2275,7 +2633,7 @@ tcl::namespace::eval punk::args { } } set idx 0 ;# - #opts/values_dict $argname membmer has been populated with the actual entered choices - which might be prefixes + #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] @@ -2283,44 +2641,95 @@ tcl::namespace::eval punk::args { foreach e $vlist e_check $vlist_check { if {$nocase} { set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $choices] + 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 $e_check] } else { set casemsg " (case sensitive)" set v_test $e_check - set choices_test $choices + set choices_test $allchoices } set choice_in_list 0 set matches_default [expr {$has_default && $e eq $defaultval}] if {!$matches_default} { if {$choiceprefix} { - set chosen [tcl::prefix::match -error "" $choices_test $v_test] - if {$chosen ne ""} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$e_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $e_check set choice_in_list 1 - #can we handle empty string as a choice? It should just work - REVIEW/test - #must use exact in case glob chars present e.g * ? [] (also ansi has square brackets) - set choice [lsearch -exact -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + set chosen $v_test + 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] $e_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + set choice_in_list [expr {$chosen ne ""}] + #we + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $e_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 "" + } + } + + if {$choice_in_list && !$choice_exact_match} { if {$is_multiple} { set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $choice + lset existing $idx $chosen tcl::dict::set $dname $argname $existing } else { - tcl::dict::set $dname $argname $choice + tcl::dict::set $dname $argname $chosen } } } 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 - } + #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 $e lappend vlist_check_validate $e_check } else { @@ -2330,13 +2739,13 @@ tcl::namespace::eval punk::args { } else { set prefixmsg "" } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname } } 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 + #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 } @@ -2354,7 +2763,7 @@ tcl::namespace::eval punk::args { 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 + #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 @@ -2376,7 +2785,7 @@ tcl::namespace::eval punk::args { #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 + #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 { @@ -2690,6 +3099,10 @@ tcl::namespace::eval punk::args { } 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] } @@ -2702,12 +3115,12 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::TEST - *opts -optional 0 + @id -id ::punk::args::TEST + @opts -optional 0 -o1 -default 111 -help "opt 1 mandatory" - *opts -optional 1 + @opts -optional 1 -o2 -default 222 -help "opt 2 optional" - *values -min 0 -max 1 + @values -min 0 -max 1 v -help\ "v1 optional" }] @@ -2762,16 +3175,18 @@ tcl::namespace::eval punk::args::lib { #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 punk::args::lib::tstr - *proc -name punk::args::lib::tstr -help\ + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ "A rough equivalent of js template literals" -allowcommands -default 0 -type none -help\ - "if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "if -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" -return -default list -choices {dict list string args}\ -choicelabels { dict\ "Return a dict with keys - 'template' and 'params'" + 'template', 'params' and + 'errors'" string\ "Return a single result being the string with @@ -2791,7 +3206,7 @@ tcl::namespace::eval punk::args::lib { args\ "Return a list where the first element is a list of template - plaintext secions as per the + plaintext sections as per the 'list' return mechanism, but the placeholder items are individual items in the returned list. @@ -2808,7 +3223,7 @@ tcl::namespace::eval punk::args::lib { contained variables in that case should be braced, 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 + @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 @@ -2820,7 +3235,7 @@ tcl::namespace::eval punk::args::lib { 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 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] @@ -2838,7 +3253,12 @@ tcl::namespace::eval punk::args::lib { dict set opts -allowcommands 1 } if {[llength $arglist] % 2 != 0} { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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 -return -eval} $k] @@ -2847,12 +3267,20 @@ tcl::namespace::eval punk::args::lib { dict set opts $fullk $v } default { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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_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] @@ -2871,6 +3299,7 @@ tcl::namespace::eval punk::args::lib { #set expressions [list] set params [list] set idx 0 + set errors [dict create] foreach {pt expression} $parts { lappend textchunks $pt incr idx ;#pt incr @@ -2881,17 +3310,32 @@ tcl::namespace::eval punk::args::lib { } #lappend expressions $expression if {$opt_eval} { - lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] } else { lappend params $expression } incr idx ;#expression incr } - switch -- $opt_return { - dict { - return [dict create template $textchunks params $params] + + 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 } + puts stderr "tstr errors:\n$einfo\n]" + } + + switch -- $opt_return { list { return [list $textchunks $params] } @@ -2906,20 +3350,18 @@ tcl::namespace::eval punk::args::lib { } return $out } - default { - } } } #test single placeholder tstr args where single placeholder must be an int proc tstr_test_one {args} { set argd [punk::args::get_dict { - *proc -name tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + @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 + @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" 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 eacc6619..5624ec58 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 @@ -254,8 +254,9 @@ namespace eval punk::cap::handlers::templates { } method folders {args} { set argd [punk::args::get_dict { + @id -id "::punk::cap::handlers::templates::class::api folders" -startdir -default "" - *values -max 0 + @values -max 0 } $args] set opts [dict get $argd opts] @@ -471,10 +472,11 @@ namespace eval punk::cap::handlers::templates { } method get_itemdict_projectlayouts {args} { set argd [punk::args::get_dict { - *opts -anyopts 1 + @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 + @values -maxvalues -1 } $args] set opt_startdir [dict get $argd opts -startdir] @@ -648,14 +650,15 @@ namespace eval punk::cap::handlers::templates { #and a name determining command -command_get_item_name method _get_itemdict {args} { set argd [punk::args::get_dict { - *proc -name _get_itemdict - *opts -anyopts 0 + @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 + @values -maxvalues -1 globsearches -default * -multiple 1 } $args] set opts [dict get $argd opts] 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 493ea5aa..fbce0905 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 @@ -362,10 +362,10 @@ tcl::namespace::eval punk::config { proc configure {args} { set argdef { - *id punk::config::configure - *proc -name punk::config::configure -help\ + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ "UNIMPLEMENTED" - *values -min 1 -max 1 + @values -min 1 -max 1 whichconfig -type string -choices {startup running stop} } set argd [punk::args::get_dict $argdef $args] @@ -388,15 +388,15 @@ tcl::namespace::eval punk::config { #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration proc copy {args} { set argdef { - *id punk::config::copy - *proc -name punk::config::copy -help\ + @id -id ::punk::config::copy + @cmd -name punk::config::copy -help\ "Copy a partial or full configuration from one config to another If a target config has additional settings, then the source config can be considered to be partial with regards to the target. " -type -default "" -choices {replace merge} -help\ "Defaults to merge when target is running-config Defaults to replace when source is running-config" - *values -min 2 -max 2 + @values -min 2 -max 2 fromconfig -help\ "running or startup or file name (not fully implemented)" toconfig -help\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index c27503c3..d2c08e8b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -875,7 +875,7 @@ namespace eval punk::console { } } - punk::args::set_alias punk::console::code_a+ punk::ansi::a+ + punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ proc code_a+ {args} { variable ansi_wanted if {$ansi_wanted <= 0} { @@ -1187,14 +1187,14 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::definition { - *id punk::console::cell_size + @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list - *values -min 0 -max 1 + @values -min 0 -max 1 newsize -default "" -help\ "character cell pixel dimensions WxH" } proc cell_size {args} { - set argd [punk::args::get_by_id punk::console::cell_size $args] + set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] set newsize [dict get $argd values newsize] 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 9f74d2d5..adb47eff 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 @@ -563,9 +563,10 @@ namespace eval punk::du { variable win_reparse_tags_by_int set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" } $args] set opts [dict get $argd opts] @@ -621,10 +622,11 @@ namespace eval punk::du { proc attributes_twapi {args} { set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" } $args] set opts [dict get $argd opts] 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 04f3487b..6de20bff 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 @@ -1252,14 +1252,14 @@ namespace eval punk::fileline { #[list_begin definitions] punk::args::definition { - *id punk::fileline::get_textinfo - *proc -name punk::fileline::get_textinfo -help\ + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" -file -default {} -type existingfile -translation -default iso8859-1 -encoding -default "\uFFFF" -includebom -default 0 - *values -min 0 -max 1 + @values -min 0 -max 1 } proc get_textinfo {args} { #*** !doctools @@ -1276,7 +1276,7 @@ namespace eval punk::fileline { #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. - lassign [dict values [punk::args::get_by_id punk::fileline::get_textinfo $args]] opts values + lassign [dict values [punk::args::get_by_id ::punk::fileline::get_textinfo $args]] opts values # -- --- --- --- set opt_file [dict get $opts -file] set opt_translation [dict get $opts -translation] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm index 6fabbba7..353d1f65 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -1009,13 +1009,13 @@ namespace eval punk::lib { set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " } set argspec [string map [list %sep% $sep] { - *id punk::lib::pdict - *proc -name pdict -help\ + @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 + @opts -any 1 #default separator to provide similarity to tcl's parray function -separator -default "%sep%" @@ -1023,7 +1023,7 @@ namespace eval punk::lib { -substructure -default {} -channel -default stdout -help "existing channel - or 'none' to return as string" - *values -min 1 -max -1 + @values -min 1 -max -1 dictvar -type string -help "name of variable. Can be a dict, list or array" @@ -1095,14 +1095,16 @@ namespace eval punk::lib { package require textblock set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { - *id punk::lib::showdict - *proc -name punk::lib::showdict -help "display dictionary keys and values" + @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 - " + -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" @@ -1114,7 +1116,7 @@ namespace eval punk::lib { -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 + @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" }] $args] @@ -2816,7 +2818,7 @@ namespace eval punk::lib { #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 { -joinchar -default \n - *values -min 1 -max 1 + @values -min 1 -max 1 } $args]] leaders opts values puts "opts:$opts" puts "values:$values" @@ -2857,7 +2859,7 @@ namespace eval punk::lib { #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 { - *opts -any 1 + @opts -any 1 -block -default {} } $args]] leaderdict opts valuedict tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] 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 8d68b28a..6b1923b1 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 @@ -168,9 +168,10 @@ namespace eval punk::mix::commandset::doc { } proc validate {args} { set argd [punk::args::get_dict { + @id -id ::punk::mix::commandset::doc::validate -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 - *values -min 0 -max -1 + @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 } $args] set opt_individual [tcl::dict::get $argd opts -individual] 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 a31da91a..47c75d33 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 @@ -34,7 +34,8 @@ namespace eval punk::mix::commandset::layout { #per layout functions proc files {{layout ""}} { set argd [punk::args::get_dict { - *values -min 1 -max 1 + @id -id ::punk::mix::commandset::layout::files + @values -min 1 -max 1 layout -type string -minsize 1 } [list $layout]] @@ -88,7 +89,8 @@ namespace eval punk::mix::commandset::layout { proc _default {args} { punk::args::get_dict [subst { - *proc -name ::punk::mix::commandset::layout::collection::_default + @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 diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index f5a5491e..f427f29f 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -27,20 +27,24 @@ namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs punk::args::definition { - *id punk::mix::commandset::loadedlib::search - *proc -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" + @id -id ::punk::mix::commandset::loadedlib::search + @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} -present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\ - "(unimplemented) Display only those that are 0:absent 1:present 2:both" - -highlight -type boolean -default 1 -help "Highlight which version is present with ansi underline and colour" + "(unimplemented) Display only those that are 0:absent 1:present 2:either" + -highlight -type boolean -default 1 -help\ + "Highlight which version is present with ansi underline and colour" -refresh -default 0 -type boolean -help "Re-scan the tm and library folders" searchstrings -default * -multiple 1 -help\ "Names to search for, may contain glob chars (* ?) e.g *lib* If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. - eg name -> *name*" + eg name -> *name* + To search for an exact name prefix it with = + e.g =name -> name + " } proc search {args} { - set argd [punk::args::get_by_id punk::mix::commandset::loadedlib::search $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::loadedlib::search $args] set searchstrings [dict get $argd values searchstrings] set opts [dict get $argd opts] set opt_return [dict get $opts -return] @@ -55,7 +59,7 @@ namespace eval punk::mix::commandset::loadedlib { set packages [package names] set matches [list] foreach search $searchstrings { - if {[regexp {[?*]} $search]} { + if {[regexp {[?*\[]} $search]} { #caller has specified specific glob pattern - use it #todo - respect supplied case only if uppers present? require another flag? lappend matches {*}[lsearch -all -inline -nocase $packages $search] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 44627536..2079eb8c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -123,10 +123,11 @@ namespace eval punk::mix::commandset::module { #return all module templates with repeated ones suffixed with .2 .3 etc proc templates_dict {args} { set argspec { - *proc -name templates_dict -help "Templates from module and project paths" + @id -id ::punk::mix::commandset::module::templates_dict + @cmd -name templates_dict -help "Templates from module and project paths" -startdir -default "" -help "Project folder used in addition to module paths" -not -default "" -multiple 1 - *values + @values globsearches -default * -multiple 1 } set argd [punk::args::get_dict $argspec $args] @@ -141,8 +142,8 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] punk::args::definition [subst { - *id punk::mix::commandset::module::new - *proc -name "punk::mix::commandset::module::new" -help\ + @id -id ::punk::mix::commandset::module::new + @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. If the name given in the module argument is namespaced, the necessary subfolder(s) will be used or created." @@ -160,7 +161,7 @@ namespace eval punk::mix::commandset::module { If false (default) an error will be raised if there is a conflict." -quiet -default 0 -type boolean -help\ "Suppress information messages on stdout" - *values -min 1 -max 1 + @values -min 1 -max 1 module -type string -help\ "Name of module, possibly including a namespace and/or version number e.g mynamespace::mymodule-1.0" @@ -168,7 +169,7 @@ namespace eval punk::mix::commandset::module { proc new {args} { set year [clock format [clock seconds] -format %Y] # use \uFFFD because unicode replacement char should consistently render as 1 wide - set argd [punk::args::get_by_id punk::mix::commandset::module::new $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::module::new $args] lassign [dict values $argd] leaders opts values received set module [dict get $values module] 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 65a9fb77..98f171c7 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 @@ -1262,15 +1262,15 @@ namespace eval punk::mix::commandset::scriptwrap { # [list_begin arguments] # [arg_def string args] name-value pairs -scriptpath # [list_end] - *id punk::mix::commandset::scriptwrap - *proc -name punk::mix::commandset::get_wrapper_folders + @id -id ::punk::mix::commandset::scriptwrap + @cmd -name punk::mix::commandset::get_wrapper_folders - *opts -anyopts 0 + @opts -anyopts 0 -scriptpath -default "" -type directory\ -help "" #todo -help folder within a punk.templates provided area??? - *values -minvalues 0 -maxvalues 0 + @values -minvalues 0 -maxvalues 0 } $args] # -- --- --- --- --- --- --- --- --- 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 159c6f37..3f5f3a71 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 @@ -636,13 +636,14 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles + -stripbase -default 1 -type boolean + -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" + @values -min 0 -max -1 + } proc dirfiles {args} { - set argspecs { - -stripbase -default 1 -type boolean - -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" - *values -min 0 -max -1 - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] @@ -726,14 +727,14 @@ tcl::namespace::eval punk::nav::fs { # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied proc dirfiles_dict {args} { set argspecs { - *id punk::nav::fs::dirfiles_dict - *opts -any 0 + @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 + @values -min 0 -max -1 -type string } set argd [punk::args::get_dict $argspecs $args] lassign [dict values $argd] leaders opts vals @@ -991,16 +992,17 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles_dict_as_lines + -stripbase -default 0 -type boolean + -formatsizes -default 1 -type boolean + @values -min 1 -max -1 -type dict + } + #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? proc dirfiles_dict_as_lines {args} { package require overtype - - set argspecs { - -stripbase -default 0 -type boolean - -formatsizes -default 1 -type boolean - *values -min 1 -max -1 -type dict - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles_dict_as_lines $args] lassign [dict values $argd] leaders opts vals set list_of_dicts [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 14b8f00d..f8a1e939 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 @@ -1608,7 +1608,7 @@ tcl::namespace::eval punk::ns { if {$word1 eq "punk::mix::base::_cli"} { #special case for punk deck - REVIEW #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set fq [lindex $tgt end] + set fq [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) @@ -1618,7 +1618,8 @@ tcl::namespace::eval punk::ns { set fq [nsjoin $location $c] } if {$has_punkargs} { - set id [string trimleft $fq :] + #set id [string trimleft $fq :] + set id $fq if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1892,110 +1893,188 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + if {[lsearch -exact $nscommands $querycommand] >= 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]] }]} { - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { #fully qualified command specified but doesn't exist - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { - set thispath [uplevel 1 [list ::nsthis $commandpath]] - set targetns [nsprefix $thispath] - set name [nstail $thispath] - set targetparts [nsparts $targetns] - if {[lsearch $targetparts :*] >=0} { - #weird ns - set valid_ns [nsexists $targetns] + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand } 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 commandpath 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 + set thispath [uplevel 1 [list ::nsthis $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 + set numvals [expr {[llength $queryargs]+1}] + #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]] + + #set origin $querycommand + #set resolved $querycommand + } - } else { - #namespace doesn't seem to exist - but there still could be documentation for lazy loaded ns and command - set origin $commandpath - set resolved $commandpath - } - } - #set thiscmd [nsjoin $targetns $name] - #if {[info commands $thiscmd] eq ""} { - # set origin $thiscmd - # set resolved $thiscmd - #} else { - # set origin [nseval $targetns [list ::namespace origin $name]] - # set resolved [nseval $targetns [list ::namespace which $name]] - #} + } + } #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! - #considure using which_alias (wiki) + #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 fq [lindex $tgt end] + 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 fq $word1 + set targetword $word1 + 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]] } - set origin $fq + + + set origin $targetword #retest cmdtype on modified origin set cmdtype [punk::ns::cmdtype $origin] } else { @@ -2013,6 +2092,83 @@ tcl::namespace::eval punk::ns { } } + + set id $origin + if {[info commands ::punk::args::id_exists] ne ""} { + #cycle through longest first checking for id matching ::cmd ?subcmd..? + #REVIEW - this doesn't cater for prefix callable subcommands! + set argcopy $queryargs + while {[llength $argcopy]} { + if {[punk::args::id_exists [list $id {*}$argcopy]]} { + return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$argcopy]]] + } + lpop argcopy + } + + #didn't find any exact matches + #traverse from other direction taking prefixes into account + + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set def [punk::args::get_def $id] + if {[llength $queryargs]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + foreach q $queryargs { + if {[llength [dict get $def leader_names]]} { + set subitems [dict get $def leader_names] + if {[llength $subitems]} { + set next [lindex $subitems 0] + set arginfo [dict get $def arg_info $next] + + 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 ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices {*}$clist + } + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + 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 numvals [expr {[llength $queryargs]+1}] + return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] + } + #check if subcommands so far have a custom args def + set currentid [list $querycommand {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set def [punk::args::get_def $currentid + } else { + #We can get no further with custom defs + break + } + } + } else { + #review + break + } + } + } else { + return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } + } + } + + if {[string match "(autodef)*" $origin]} { + #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) + set origin [string range $origin [string length (autodef)] end] + set resolved $origin + } + switch -- $cmdtype { object { #class is also an object @@ -2025,19 +2181,19 @@ tcl::namespace::eval punk::ns { #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - if {[llength $commandargs]} { - set c1 [lindex $commandargs 0] + if {[llength $queryargs]} { + set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { switch -- $c1 { new { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} new" - *proc -name "${$origin} new" -help\ + @id -id "(autodef)${$origin} new" + @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 { @@ -2054,17 +2210,17 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin new"] + return [punk::args::usage {*}$opts "(autodef)$origin new"] } create { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} create" - *proc -name "${$origin} create" -help\ + @id -id "(autodef)${$origin} create" + @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" }] @@ -2083,20 +2239,20 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin create"] + return [punk::args::usage {*}$opts "(autodef)$origin create"] } destroy { #review - generally no doc # but we may want notes about a specific destructor set argspec [punk::lib::tstr -return string { - *id "${$origin} destroy" - *proc -name "destroy" -help\ + @id -id "(audodef)${$origin} destroy" + @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." - *values -min 0 -max 0 + @values -min 0 -max 0 }] punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin destroy"] + return [punk::args::usage {*}$opts "(autodef)$origin destroy"] } default { #use info object call to resolve callchain @@ -2111,20 +2267,24 @@ tcl::namespace::eval punk::ns { lassign $impl generaltype mname location methodtype switch -- $generaltype { method - private { - + #objects being dynamic systems - we should always reinspect. + #Don't use the cached (autodef) def + #If there is a custom def override - use it (should really be -dynamic - but we don't check) if {$location eq "object"} { - set id "[string trimleft $origin :] $c1" ;# " " + set idcustom "$origin $c1" + #set id "[string trimleft $origin :] $c1" ;# " " if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info object definition $origin $c1] } else { - set id "[string trimleft $location :] $c1" ;# " " + #set id "[string trimleft $location :] $c1" ;# " " + set idcustom "$location $c1" if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info class definition $location $c1] @@ -2138,12 +2298,15 @@ tcl::namespace::eval punk::ns { } } if {$def ne ""} { + #assert - if we pre + set autoid "(autodef)$location $c1" set arglist [lindex $def 0] set argspec [punk::lib::tstr -return string { - *id "${$location} ${$c1}" - *proc -name "${$location} ${$c1}" -help\ - "arglist:${$arglist}" - *values + @id -id "${$autoid}" + @cmd -name "${$location} ${$c1}" -help\ + "(autogenerated) + arglist:${$arglist}" + @values }] set i 0 foreach a $arglist { @@ -2166,7 +2329,7 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$location $c1"] + return [punk::args::usage {*}$opts $autoid] } else { return "unable to resolve $origin method $c1" } @@ -2189,9 +2352,11 @@ tcl::namespace::eval punk::ns { switch -- $generaltype { method - private { if {$location eq "object"} { - set id "[string trimleft $origin :] $cmd" ;# " " + #set id "[string trimleft $origin :] $cmd" ;# " " + set id "$origin $cmd" } else { - set id "[string trimleft $location :] $cmd" ;# " " + #set id "[string trimleft $location :] $cmd" ;# " " + set id "$location $cmd" } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { @@ -2212,15 +2377,16 @@ tcl::namespace::eval punk::ns { set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" + set idauto "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -name "Object: ${$origin}" -help\ - "Instance of class: ${$class}" - *values -min 1 + @id -id ${$idauto} + @cmd -name "Object: ${$origin}" -help\ + "Instance of class: ${$class} (info autogenerated)" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $idauto] } privateObject { return "Command is a privateObject - no info currently available" @@ -2287,11 +2453,11 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] - if {[llength $commandargs]} { - set match [tcl::prefix::match $subcommands [lindex $commandargs 0]] + 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 $commandargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + 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") } } @@ -2307,9 +2473,9 @@ tcl::namespace::eval punk::ns { 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] + lappend have_usageinfo {*}[dict get $nsinfo usageinfo] + lappend is_ensemble {*}[dict get $nsinfo ensembles] + lappend is_object {*}[dict get $nsinfo ooobjects] } set choicelabeldict [dict create] @@ -2324,14 +2490,17 @@ tcl::namespace::eval punk::ns { } set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set autoid "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -help "ensemble: ${$origin}" - *values -min 1 + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + ensemble: ${$origin}" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2364,12 +2533,6 @@ tcl::namespace::eval punk::ns { } } - set id [string trimleft $origin :] - if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] - } - } set origin_ns [nsprefix $origin] set parts [nsparts $origin_ns] set weird_ns 0 @@ -2379,24 +2542,42 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set argl {} set tail [nstail $origin] - foreach a [nseval_ifexists $origin_ns [list info args $tail]] { - if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { - lappend a $def + set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] + if {$cmdtype eq "proc"} { + foreach a [nseval_ifexists $origin_ns [list info args $tail]] { + if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } else { - set argl {} - foreach a [info args $origin] { - if {[info default $origin $a def]} { - lappend a $def + set cmdtype [punk::ns::cmdtype $origin] + if {$cmdtype eq "proc"} { + set argl {} + set infoargs [info args $origin] + foreach a $infoargs { + if {[info default $origin $a def]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } - set msg "No argument processor detected" - append msg \n "function signature: $resolved $argl" + if {[llength $queryargs]} { + #todo - something better + set msg "Undocumented or nonexistant subcommand $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" + } else { + set msg "Undocumented command $origin. Type: $cmdtype" + } + } return $msg } @@ -2738,8 +2919,8 @@ tcl::namespace::eval punk::ns { interp alias "" use "" punk::ns::pkguse punk::args::definition { - *id punk::ns::nsimport_noclobber - *proc -name punk::ns::nsimport_noclobber -help\ + @id -id ::punk::ns::nsimport_noclobber + @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, or that specified in -targetnamespace. Return list of imported commands, ignores failures due to name conflicts" @@ -2750,14 +2931,14 @@ tcl::namespace::eval punk::ns { If not supplied, caller's namespace is used." -prefix -optional 1 -help\ "string prefix for command names in target namespace" - *values -min 1 -max 1 + @values -min 1 -max 1 sourcepattern -type string -optional 0 -help\ "Glob pattern for source namespace. Globbing only active in the tail segment. e.g ::mynamespace::*" } proc nsimport_noclobber {args} { - lassign [dict values [punk::args::get_by_id punk::ns::nsimport_noclobber $args]] leaders opts values received + lassign [dict values [punk::args::get_by_id ::punk::ns::nsimport_noclobber $args]] leaders opts values received set sourcepattern [dict get $values sourcepattern] set source_ns [tcl::namespace::qualifiers $sourcepattern] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index d3431188..65ede7c8 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -645,14 +645,14 @@ namespace eval punk::path { } punk::args::definition { - *id punk::path::treefilenames + @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." -call-depth-internal -default 0 -type integer -antiglob_paths -default {} -help\ "list of path patterns to exclude may include * and ** path segments e.g /usr/**" - *values -min 0 -max -1 -optional 1 -type string + @values -min 0 -max -1 -optional 1 -type string tailglobs -multiple 1 -help\ "Patterns to match against filename portion (last segment) of each file path within the directory tree being searched." @@ -671,7 +671,7 @@ namespace eval punk::path { #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para]no natsorting - so order is dependent on filesystem - set argd [punk::args::get_by_id punk::path::treefilenames $args] + set argd [punk::args::get_by_id ::punk::path::treefilenames $args] lassign [dict values $argd] leaders opts values received set tailglobs [dict values $values] # -- --- --- --- --- --- --- 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 28a7271b..98bc04ef 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 @@ -62,6 +62,73 @@ package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- namespace eval punk::repo { + variable PUNKARGS + variable PUNKARGS_aliases + + proc get_fossil_usage {} { + set allcmds [runout -n fossil help -a] + set mainhelp [runout -n fossil help] + set maincommands [list] + foreach ln [split $mainhelp \n] { + set ln [string trim $ln] + if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { + continue + } + lappend maincommands {*}$ln + } + set othercmds [punk::lib::ldiff $allcmds $maincommands] + + set result "@leaders -min 0\n" + + append result [tstr -return string { + subcommand -type string -choicecolumns 8 -choicegroups { + "frequently used commands" {${$maincommands}} + "" {${$othercmds}} + } + }] + + return $result + } + + + #lappend PUNKARGS [list -dynamic 1 { + # @id -id ::punk::repo::fossil_proxy + # @cmd -name fossil -help "fossil executable + # " + # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # } ""] + + lappend PUNKARGS [list -dynamic 1 { + @id -id ::punk::repo::fossil_proxy + @cmd -name fossil -help "fossil executable" + ${[punk::repo::get_fossil_usage]} + } ] + + + + #experiment + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + #TODO + #lappend PUNKARGS [list -dynamic 1 { + # @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]}} + # } ""] + lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} + lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} + #Todo - investigate proper way to install a client-side commit hook in the fossil project #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used @@ -137,7 +204,7 @@ namespace eval punk::repo { puts stderr "fossil command not found. Please install fossil" } } - interp alias "" fossil "" punk::repo::fossil_proxy + # --- # Calling auto_execok on an external tool can be too slow to do during package load (e.g could be 150ms) @@ -153,6 +220,7 @@ namespace eval punk::repo { # ---------- # + #uppercase FOSSIL to bypass fossil as alias to fossil_proxy proc establish_FOSSIL {args} { if {![info exists ::auto_execs(FOSSIL)]} { @@ -161,7 +229,6 @@ namespace eval punk::repo { interp alias "" FOSSIL "" ;#delete establishment alias FOSSIL {*}$args } - interp alias "" FOSSIL "" punk::repo::establish_FOSSIL # ---------- proc askuser {question} { @@ -1577,6 +1644,8 @@ namespace eval punk::repo { } } + interp alias "" fossil "" punk::repo::fossil_proxy + interp alias "" FOSSIL "" punk::repo::establish_FOSSIL interp alias {} is_fossil {} ::punk::repo::is_fossil interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root @@ -1609,6 +1678,17 @@ namespace eval punk::repo::lib { } + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +if {![info exists ::punk::args::register::NAMESPACES]} { + namespace eval ::punk::args::register { + set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace + } +} +lappend ::punk::args::register::NAMESPACES ::punk::repo +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::repo [namespace eval punk::repo { 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 311a8025..11ae9ab2 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 @@ -180,10 +180,11 @@ tcl::namespace::eval punk::zip { #}] set argd [punk::args::get_dict { - *proc -name punk::zip::walk + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -excludes -default "" -help "list of glob expressions to match against files and exclude" -subpath -default "" - *values -min 1 -max -1 + @values -min 1 -max -1 base fileglobs -default {*} -multiple 1 } $args] @@ -373,11 +374,12 @@ tcl::namespace::eval punk::zip { #[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 { - *proc -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + @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 + @opts -comment -default "" -help "An optional comment specific to the added file" - *values -min 3 -max 4 + @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" @@ -525,9 +527,10 @@ tcl::namespace::eval punk::zip { #[para] Call 'punk::zip::mkzip' with no arguments for usage display. set argd [punk::args::get_dict { - *proc -name punk::zip::mkzip\ + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ -help "Create a zip archive in 'filename'" - *opts + @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. @@ -557,7 +560,7 @@ tcl::namespace::eval punk::zip { it must be a parent of -directory or the same path as -directory" -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - *values -min 1 -max -1 + @values -min 1 -max -1 filename -type file -default ""\ -help "name of zipfile to create" globs -default {*} -multiple 1\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm index 3651c0f0..dcc023ec 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.2.tm @@ -123,12 +123,12 @@ tcl::namespace::eval textblock { set choicemsg " (unavailable packages: $unavailable)" } set argd [punk::args::get_dict [tstr -return string { - *id textblock::use_hash - *proc -name "textblock::use_hash" -help\ + @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 + @values -min 0 -max 1 hash_algorithm -choices {${$choices}} -optional 1 -help\ "algorithm choice ${$choicemsg}" }] $args] @@ -423,7 +423,6 @@ tcl::namespace::eval textblock { } } } - my configure {*}$o_opts_table #foreach {k v} $args { # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. @@ -453,6 +452,7 @@ tcl::namespace::eval textblock { -minheight 1\ -maxheight ""\ ] + my configure {*}$o_opts_table } method width_algorithm {{alg ""}} { @@ -593,7 +593,7 @@ tcl::namespace::eval textblock { tcl::dict::set o_opts_table_effective -framelimits_header $hlims return [tcl::dict::create body $blims header $hlims] } - method configure args { + method configure {args} { #*** !doctools #[call class::table [method configure] [arg args]] #[para] get or set various table-level properties @@ -781,6 +781,14 @@ tcl::namespace::eval textblock { } } } + -title { + set twidth [punk::ansi::printing_length $v] + if {[my width] < [expr {$twidth+2}]} { + set o_calculated_column_widths [list] + tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] + } + tcl::dict::set o_opts_table -title $v + } default { tcl::dict::set o_opts_table $k $v } @@ -3943,14 +3951,13 @@ tcl::namespace::eval textblock { if {$header_build eq "" && ![llength $body_blocks]} { set header_build $nextcol_header - lappend body_blocks $nextcol_body } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] } - lappend body_blocks $nextcol_body #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } + lappend body_blocks $nextcol_body incr padwidth $bodywidth incr colposn } @@ -4096,8 +4103,8 @@ tcl::namespace::eval textblock { } punk::args::definition { - *id textblock::periodic - *proc -name textblock::periodic -help "A rudimentary periodic table + @id -id ::textblock::periodic + @cmd -name textblock::periodic -help "A rudimentary periodic table This is primarily a test of textblock::class::table" -return -default table\ @@ -4109,13 +4116,13 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id textblock::periodic $args] opts] + set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -4345,7 +4352,10 @@ tcl::namespace::eval textblock { set FRAMETYPES [textblock::frametypes] punk::args::definition [punk::lib::tstr -return string { - *id textblock::list_as_table + @id -id ::textblock::list_as_table + @cmd -name "textblock::list_as_table" -help\ + "Display a list in a bordered table + " -return -default table -choices {table tableobject} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ @@ -4376,13 +4386,13 @@ tcl::namespace::eval textblock { -help "Number of table columns Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 + @values -min 0 -max 1 datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" }] proc list_as_table {args} { set FRAMETYPES [textblock::frametypes] - set argd [punk::args::get_by_id textblock::list_as_table $args] + set argd [punk::args::get_by_id ::textblock::list_as_table $args] set opts [dict get $argd opts] set datalist [dict get $argd values datalist] @@ -4894,7 +4904,7 @@ tcl::namespace::eval textblock { #review!? #-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line - set usage "pad ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" + set usage "pad block ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" foreach {k v} $args { switch -- $k { -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { @@ -5420,16 +5430,21 @@ tcl::namespace::eval textblock { return [punk::lib::list_as_lines -- $outlines] } + + punk::args::definition { + @id -id ::textblock::join_basic + @cmd -name textblock::join_basic -help\ + "Join blocks of text 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 + " + -- -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 + } + #join without regard to each line length in a block (no padding added to make each block uniform) proc ::textblock::join_basic {args} { - #*proc -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 { - -- -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 argd [punk::args::get_by_id ::textblock::join_basic $args] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5466,7 +5481,7 @@ tcl::namespace::eval textblock { return [::join $outlines \n] } proc ::textblock::join_basic2 {args} { - #*proc -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + #@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 { @@ -6046,8 +6061,8 @@ tcl::namespace::eval textblock { if {$bad_option || [llength $values] == 0} { #no framedef supplied, or unrecognised opt seen set spec [string map [list $::textblock::frametypes] { - *id textblock::framedef - *proc -name textblock::framedef\ + @id -id ::textblock::framedef + @cmd -name textblock::framedef\ -help "Return a dict of the elements that make up a frame border. May return a subset of available elements based on memberglob values." @@ -6058,7 +6073,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - *values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -7438,17 +7453,17 @@ tcl::namespace::eval textblock { set frame_cache [tcl::dict::create] punk::args::definition { - *id textblock::frame_cache - *proc -name textblock::frame_cache -help\ + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ "Display or clear the frame cache." -action -default {} -choices {clear} -help\ "Clear the textblock::frame_cache dictionary" -pretty -default 1 -help\ "Use 'pdict textblock::frame_cache */*' for prettier output" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc frame_cache {args} { - set argd [punk::args::get_by_id textblock::frame_cache $args] + set argd [punk::args::get_by_id ::textblock::frame_cache $args] set action [dict get $argd opts -action] if {$action ni [list clear ""]} { @@ -7490,13 +7505,40 @@ tcl::namespace::eval textblock { } + variable FRAMETYPES set FRAMETYPES [textblock::frametypes] + variable EG set EG [a+ brightblack] + variable RST set RST [a] + + proc frame_samples {} { + set FRAMETYPELABELS [dict create] + if {[info commands ::textblock::frame] ne ""} { + foreach ft [frametypes] { + dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] + } + } + set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] + return $FRAMETYPELABELS + } + #proc EG {} "return {[a+ brightblack]}" + #make EG fetch from SGR cache so as to abide by colour off/on + proc EG {} { + a+ brightblack + } + #proc RST {} "return {\x1b\[m}" + proc RST {} { + return "\x1b\[m" + } + + #catch 22 for -choicelabels - need some sort of lazy evaluation + # ${[textblock::frame_samples]} + #todo punk::args alias for centre center etc? - punk::args::definition [punk::lib::tstr -return string { - *id textblock::frame - *proc -name "textblock::frame"\ + punk::args::definition -dynamic 1 { + @id -id ::textblock::frame + @cmd -name "textblock::frame"\ -help "Frame a block of text with a border." -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and @@ -7504,18 +7546,21 @@ tcl::namespace::eval textblock { Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." - -type -default light -choices {${$FRAMETYPES}} -choicerestricted 0 -type dict\ + -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ + -choicelabels { + ${[textblock::frame_samples]} + }\ -help "Type of border for frame." -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. passing an empty string will result in no box, but title/subtitle will still appear if supplied. - ${$EG}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${$RST}" + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. May contain ANSI - no trailing reset required. - ${$EG}e.g 1: frame -title My[a+ green]Green[a]Thing - e.g 2: frame -title [a+ red underline]MyThing${$RST}" + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" -subtitle -default "" -type string -regexprefail {\n}\ -help "Frame subtitle placed on bottombar - no newlines May contain Ansi - no trailing reset required." @@ -7526,8 +7571,8 @@ tcl::namespace::eval textblock { -help "Height of resulting frame including borders." -ansiborder -default "" -type ansistring\ -help "Ansi escape sequence to set border attributes. - ${$EG}e.g 1: frame -ansiborder [a+ web-red] contents - e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${$RST}" + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" -ansibase -default "" -type ansistring\ -help "Default ANSI attributes within frame." -blockalign -default centre -choices {left right centre}\ @@ -7547,13 +7592,13 @@ tcl::namespace::eval textblock { Frame width doesn't adapt and content may be truncated so -width may need to be manually set to display more." - *values -min 0 -max 1 + @values -min 0 -max 1 contents -default "" -type string\ -help "Frame contents - may be a block of text containing newlines and ANSI. Text may be 'ragged' - ie unequal line-lengths. No trailing ANSI reset required. - ${$EG}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${$RST}" - }] + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } #options before content argument - which is allowed to be absent #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. @@ -7638,7 +7683,7 @@ tcl::namespace::eval textblock { #only use punk::args if check_args is true or our basic checks failed #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { - set argd [punk::args::get_by_id textblock::frame $args] + set argd [punk::args::get_by_id ::textblock::frame $args] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8346,18 +8391,18 @@ tcl::namespace::eval textblock { } } punk::args::definition { - *id textblock::gcross + @id -id ::textblock::gcross -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block Only cross sizes that divide the size of the overall block will be used. e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. " - *values -min 0 -max 1 + @values -min 0 -max 1 size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id textblock::gcross $args] + set argd [punk::args::get_by_id ::textblock::gcross $args] set size [dict get $argd values size] set opts [dict get $argd opts] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm index f0e34919..0d9cd0bc 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm @@ -402,7 +402,10 @@ tcl::namespace::eval overtype { set looplimit [expr {[tcl::string::length $overblock] + 10}] } - set scheme 3 + #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height + #lassign [blocksize $overblock] _w overblock_width _h overblock_height + + set scheme 4 switch -- $scheme { 0 { #one big chunk @@ -443,11 +446,18 @@ tcl::namespace::eval overtype { set inputchunks [lindex [list $lflines [unset lflines]] 0] } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks [string cat $ln \n] + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + } + } } - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height set replay_codes_underlay [tcl::dict::create 1 ""] @@ -495,7 +505,7 @@ tcl::namespace::eval overtype { } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderargs [list -experimental $opt_experimental\ + set renderopts [list -experimental $opt_experimental\ -cp437 $opt_cp437\ -info 1\ -crm_mode [tcl::dict::get $vtstate crm_mode]\ @@ -510,11 +520,8 @@ tcl::namespace::eval overtype { -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ - $undertext\ - $overtext\ ] - set LASTCALL $renderargs - set rinfo [renderline {*}$renderargs] + set rinfo [renderline {*}$renderopts $undertext $overtext] set instruction [tcl::dict::get $rinfo instruction] tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] @@ -1237,8 +1244,8 @@ tcl::namespace::eval overtype { append debugmsg "looplimit $looplimit reached\n" append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $LASTCALL -cursor_column]\n" + append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" + append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" tcl::dict::for {k v} $rinfo { append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm index 9440ae9c..1a9ab766 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm @@ -306,10 +306,11 @@ namespace eval punk { #get last command result that was run through the repl proc ::punk::get_runchunk {args} { set argd [punk::args::get_dict { - *opts + @id -id ::punk::get_runchunk + @opts -1 -optional 1 -type none -2 -optional 1 -type none - *values -min 0 -max 0 + @values -min 0 -max 0 } $args] #todo - make this command run without truncating previous runchunks set runchunks [tsv::array names repl runchunks-*] @@ -7152,8 +7153,8 @@ namespace eval punk { } punk::args::definition { - *id punk::inspect - *proc -name punk::inspect -help\ + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. The raw value arguments (not options) are always returned to pass forward in the pipeline. @@ -7227,9 +7228,9 @@ namespace eval punk { Does not affect return value." -- -type none -help\ "End of options marker. - It is advisable to use this, as data in a pipeline may often being with -" + It is advisable to use this, as data in a pipeline may often begin with -" - *values -min 0 -max -1 + @values -min 0 -max -1 arg -type string -optional 1 -multiple 1 -help\ "value to display" } @@ -7261,7 +7262,7 @@ namespace eval punk { foreach {k v} $flags { if {$k ni [dict keys $defaults]} { #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" - punk::args::get_by_id punk::inspect $args + punk::args::get_by_id ::punk::inspect $args } } set opts [dict merge $defaults $flags] 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 452092e7..a3f9c0b5 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 @@ -134,27 +134,27 @@ tcl::namespace::eval punk::ansi::class { } lappend ::punk::ansi::class::PUNKARGS [list { - *id "punk::ansi::class::class_ansi render_to_input_line" - *proc -name "punk::ansi::class::class_ansi render_to_input_line" -help\ + @id -id "::punk::ansi::class::class_ansi render_to_input_line" + @cmd -name "punk::ansi::class::class_ansi render_to_input_line" -help\ "render string from line 0 to line (experimental/debug)" -dimensions -type string -help\ "WxH where W is integer width >= 1 and H is integer heigth >= 1" -minus -type integer -help\ "number of chars to exclude from end" - *values -min 1 -max 1 + @values -min 1 -max 1 line -type indexexpression }] method render_to_input_line {args} { if {[llength $args] < 1} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set opts [tcl::dict::create\ -dimensions 80x24\ @@ -167,7 +167,7 @@ tcl::namespace::eval punk::ansi::class { } default { puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } } } @@ -588,20 +588,20 @@ tcl::namespace::eval punk::ansi { } lappend PUNKARGS [list -dynamic 1 { - *id punk::ansi::example - *proc -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console + @id -id ::punk::ansi::example + @cmd -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console " -colwidth -default 82 -help "Width of each column - default of 82 will fit a standard 80wide ansi image (when framed) You can specify a narrower width to truncate images on the right side" -folder -default "${[punk::ansi::Get_ansifolder]}" -help "Base folder for files if relative paths are used. Defaults to /src/testansi - where projectbase is determined from current directory. " - *values -min 0 -max -1 + @values -min 0 -max -1 files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help "List of filenames - leave empty to display 4 defaults" } ""] proc example {args} { - set argd [punk::args::get_by_id punk::ansi::example $args] + set argd [punk::args::get_by_id ::punk::ansi::example $args] set colwidth [dict get $argd opts -colwidth] set ansifolder [file normalize [dict get $argd opts -folder]] set fnames [dict get $argd values files] @@ -2355,21 +2355,21 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #sgr_cache clear called by punk::console::ansi when set to off #punk::args depends on punk::ansi - REVIEW + lappend PUNKARGS [list { + @id -id ::punk::ansi::sgr_cache + @cmd -name punk::ansi::sgr_cache -help\ + "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) + " + -action -default "" -choices "clear" -help\ + "-action clear will unset the keys in the punk::ansi::sgr_cache dict + This is called automatically when setting 'colour false' in the console" + + -pretty -default 1 -type boolean -help\ + "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" + @values -min 0 -max 0 + }] proc sgr_cache {args} { - set argdef { - *id punk::ansi::sgr_cache - *proc -name punk::ansi::sgr_cache -help\ - "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) - " - -action -default "" -choices "clear" -help\ - "-action clear will unset the keys in the punk::ansi::sgr_cache dict - This is called automatically when setting 'colour false' in the console" - - -pretty -default 1 -type boolean -help\ - "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" - *values -min 0 -max 0 - } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::get_by_id ::punk::ansi::sgr_cache $args] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] @@ -2412,34 +2412,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return [join $lines \n] } - lappend PUNKARGS [list { - *id punk::ansi::a+ - *proc -name "punk::ansi::a+" -help\ - "Returns an ANSI sgr escape sequence based on the list of supplied codes. - Unlike punk::ansi::a - it is not prefixed with an ANSI reset. - " - *values -min 0 -max -1 - } [string map [list [dict keys $SGR_map]] { - code -type string -optional 1 -multiple 1 -choices {} -choiceprefix 0 -choicerestricted 0 -help\ - "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. - A leading capital letter indicates a codename applies to the background colour. - Other accepted codes are: - term- Term- foreground/background where int is 0-255 terminal color - term- Term- foreground/background - rgb--- Rgb--- foreground/background where are the - 0-255 int values for red, green and blue. - rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 - web- Web- - - The acceptable values for and can be queried using - punk::ansi::a? term - and - punk::ansi::a? web - - Example to set foreground red and background cyan followed by a reset: - set str \"[a+ red Cyan]sample text[a]\" - " - }]] + #PUNKARGS doc performed below, after we create the proc proc a+ {args} { #*** !doctools #[call [fun a+] [opt {ansicode...}]] @@ -2907,6 +2880,41 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $result } + set SGR_samples [dict create] + foreach k [dict keys $SGR_map] { + dict set SGR_samples $k "[punk::ansi::a+ $k]sample\x1b\[m" + } + lappend PUNKARGS [list { + @id -id ::punk::ansi::a+ + @cmd -name "punk::ansi::a+" -help\ + "Returns an ANSI sgr escape sequence based on the list of supplied codes. + Unlike punk::ansi::a - it is not prefixed with an ANSI reset. + " + @values -min 0 -max -1 + } [string map [list [dict keys $SGR_map] $SGR_samples] { + code -type string -optional 1 -multiple 1 -choices {}\ + -choicelabels {}\ + -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ + "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. + A leading capital letter indicates a codename applies to the background colour. + Other accepted codes are: + term- Term- foreground/background where int is 0-255 terminal color + term- Term- foreground/background + rgb--- Rgb--- foreground/background where are the + 0-255 int values for red, green and blue. + rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 + web- Web- + + The acceptable values for and can be queried using + punk::ansi::a? term + and + punk::ansi::a? web + + Example to set foreground red and background cyan followed by a reset: + set str \"[a+ red Cyan]sample text[a]\" + " + }]] + proc a {args} { #*** !doctools #[call [fun a] [opt {ansicode...}]] @@ -4281,6 +4289,7 @@ tcl::namespace::eval punk::ansi { } 4 { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines + #e.g hyper on windows if {[llength $paramsplit] == 1} { tcl::dict::set codestate underline 4 } else { @@ -4634,6 +4643,8 @@ tcl::namespace::eval punk::ansi::ta { #[list_begin definitions] tcl::namespace::path ::punk::ansi + variable PUNKARGS + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position @@ -4706,15 +4717,31 @@ tcl::namespace::eval punk::ansi::ta { #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::ansi::ta::detect + @cmd -name punk::ansi::ta::detect -help\ + "Return a boolean indicating whether Ansi codes were detected in text. + Important caveat: + When text is a tcl list made from splitting (or lappending) some ansi string + - individual elements may be braced or have certain chars escaped. + (one example is if a list element contains an unbalanced brace) + This can cause square brackets that form part of the ansi to be backslash escaped + - and the function can fail to match it as an Ansi code. + " + @values -min 1 + text -type string + } ] + + #*** !doctools + #[call [fun detect] [arg text]] + #[para]Return a boolean indicating whether Ansi codes were detected in text + #[para]Important caveat: + #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) + #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match + #detect any ansi escapes #review - only detect 'complete' codes - or just use the opening escapes for performance? proc detect {text} [string map [list [list $re_ansi_detect]] { - #*** !doctools - #[call [fun detect] [arg text]] - #[para]Return a boolean indicating whether Ansi codes were detected in text - #[para]Important caveat: - #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) - #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match regexp $text }] @@ -7405,7 +7432,7 @@ if {![info exists ::punk::args::register::NAMESPACES]} { set NAMESPACES [list] } } -lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class +lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class ::punk::ansi::ta # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index 5a589fe3..2c9c77fa 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -50,14 +50,14 @@ #[example { # proc dofilestuff {args} { # lassign [dict values [punk::args::get_dict { -# *proc -help "do some stuff with files e.g dofilestuff " -# *opts -type string +# @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 +# @values -min 1 -max -1 # } $args]] leaders opts values # # puts "translation is [dict get $opts -translation]" @@ -67,8 +67,8 @@ # } #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for *values -#[para]valid * lines being with *proc *leaders *opts *values +#[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: @@ -81,7 +81,7 @@ # -directory -default "" # -translation -default binary # -nocomplain -type none -# *values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 # } $args]] leaders opts values @@ -89,7 +89,7 @@ # 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]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 @@ -279,11 +279,140 @@ tcl::namespace::eval punk::args { #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 - lappend PUNKARGS [list { - *id punk::args::definition - *proc -name punk::args::definition -help\ + 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::definition + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::definition -help\ "Accepts a line-based definition of command arguments. - The definition should usually contain a line of the form: *id someid + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + options: -id + %B%@cmd%N% ?opt val...? + options -name -help + %B%@leaders%N% ?opt val...? + options -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + options -any + %B%@values%N% ?opt val...? + options -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + options -header (text for header row of table) + -body (text to replace entirety of autogenerated docs) + %B%@doc%N% ?opt val...? + options -name -url + + 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 + 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 value or option. + + 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 options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + -default + -multiple (for leaders & values defines whether + subsequent received values are stored agains the same + argument name - only applies to final leader or value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - no necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -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\} @@ -292,20 +421,20 @@ tcl::namespace::eval punk::args { 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 not usually significant, perhaps on the order of a few hundred uS, - but -dynamic true might be less desirable if the command is used in inner - loops in more performance-sensitive code. + 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 + @values -min 1 -max -1 text -type string -multiple 1 -help\ "Block(s) of text representing the argument specification 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. - e.g + e.g the following definition passes 2 blocks as text arguments definition { - *id myns::myfunc - *proc -name myns::myfunc -help\\ + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ \"Description of command\" #The following option defines an option-value pair @@ -314,13 +443,13 @@ tcl::namespace::eval punk::args { -flag1 -default 0 -type none -help\\ \"Info about flag1\" - *values -min 1 -max -1 + @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 definition {args} { variable argdata_cache variable argdefcache_by_id @@ -482,6 +611,7 @@ tcl::namespace::eval punk::args { 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]} { @@ -522,9 +652,10 @@ tcl::namespace::eval punk::args { set linebuild "" } } - set proc_info {} + set cmd_info {} set id_info {} ;#e.g -children ?? set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table set parser_info {} set leader_min "" #set leader_min 0 @@ -543,27 +674,50 @@ tcl::namespace::eval punk::args { "" - # {continue} } set linespecs [lassign $trimln argname] - if {$argname ne "*id" && [llength $linespecs] % 2} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs'" + if {[llength $linespecs] % 2 != 0} { + error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" } set firstchar [tcl::string::index $argname 0] set secondchar [tcl::string::index $argname 1] - if {$firstchar eq "*" && $secondchar ne "*"} { - set starspecs $linespecs + if {$firstchar eq "@" && $secondchar ne "@"} { + set at_specs $linespecs + switch -- [tcl::string::range $argname 1 end] { id { - #id line must have single entry - a unique id assigned by the user - an id will be allocated if no id line present or the value is "auto" - if {[llength $starspecs] == 0} { - error "punk::args::definition - *id line must have at least a single entry following *id." - } + #id An id will be allocated if no id line present or the -id value is "auto" if {$spec_id ne ""} { - #disallow duplicate *id line - error "punk::args::definition - *id already set. Existing value $spec_id" + #disallow duplicate @id line + error "punk::args::definition - @id already set. Existing value $spec_id" } - set spec_id [lindex $starspecs 0] - set id_info [lrange $starspecs 1 end] - if {[llength $id_info] %2} { - error "punk::args::definition - bad *id line. Remaining items on line after *id must be in paired option-value format - received '$linespecs'" + if {[dict exists $at_specs -id]} { + set spec_id [dict get $at_specs -id] + } else { + set spec_id auto + } + set id_info $at_specs + } + default { + #copy from an identified set of defaults (another argspec id) can be multiple + if {[dict exists $at_specs -id]} { + set copyfrom [get_def [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] + } + 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??? + } } } parser { @@ -596,27 +750,32 @@ tcl::namespace::eval punk::args { # 1 anykeys {0 info} # } #todo - set parser_info $starspecs + set parser_info $at_specs } - proc { + cmd { #allow arbitrary - review - set proc_info $starspecs + set cmd_info [dict merge $cmd_info $at_specs] } doc { - set doc_info $starspecs + 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 { if {$argspace eq "values"} { - error "punk::args::definition - *opts declaration must come before *values - received '$linespecs'" + error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" } set argspace "options" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -any - -anyopts { set opt_any $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } @@ -662,26 +821,26 @@ tcl::namespace::eval punk::args { tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *opts line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } } } leaders { if {$argspace in [list options values]} { - error "punk::args::definition - *leaders declaration must come before all options and values" + error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" } - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" } set leader_min $v #if {$leader_max == 0} { @@ -691,15 +850,16 @@ tcl::namespace::eval punk::args { -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" } set leader_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set leaderspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset leaderspec_defaults $k2 @@ -741,12 +901,12 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *leaders line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } } @@ -754,27 +914,28 @@ tcl::namespace::eval punk::args { } values { set argspace "values" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" } set val_min $v } -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" } set val_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset valspec_defaults $k2 @@ -816,19 +977,19 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *values line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } } } default { - error "punk::args::definition - unrecognised * line in '$ln'. Expected *proc *leaders *opts or *values - use **name if paramname needs to be *name" + error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" } } continue @@ -836,15 +997,15 @@ tcl::namespace::eval punk::args { if {$argspace eq "leaders"} { set argspace "options" } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before *values" + error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" } set argspecs $linespecs tcl::dict::set argspecs -ARGTYPE option lappend opt_names $argname set is_opt 1 } else { - if {$firstchar eq "*"} { - #allow basic ** escaping for literal argname that begins with * + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } set argspecs $linespecs @@ -898,7 +1059,7 @@ tcl::namespace::eval punk::args { lappend opt_solos $argname } else { #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname'" + error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } } any - anything { @@ -916,18 +1077,18 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choiceprefix - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -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 + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines #review -solo 1 vs -type none ? conflicting values? tcl::dict::set spec_merged $spec $specval } -validationtransform { #string is dict only 8.7/9+ if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary" + error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" } dict for {tk tv} $specval { switch -- $tk { @@ -935,18 +1096,18 @@ tcl::namespace::eval punk::args { } default { set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys" + error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" } } } } default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choiceprefix -choicerestricted\ + set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" + error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" } } } @@ -983,6 +1144,11 @@ tcl::namespace::eval punk::args { } } + if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + variable id_counter + set spec_id "autoid_[incr id_counter]" + } + # REVIEW #if {[llength $val_names] || $val_min > 0} { # #some values are specified @@ -995,23 +1161,19 @@ tcl::namespace::eval punk::args { #no values specified - we can allow last leader to be multiple foreach leadername [lrange $leader_names 0 end-1] { if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple" + error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" } } #} #confirm any valnames before last don't have -multiple key foreach valname [lrange $val_names 0 end-1] { if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple" + error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" } } - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { - variable id_counter - set spec_id "autoid_[incr id_counter]" - } - #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) + #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) set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize @@ -1043,8 +1205,9 @@ tcl::namespace::eval punk::args { val_max $val_max\ valspec_defaults $valspec_defaults\ val_checks_defaults $val_checks_defaults\ - proc_info $proc_info\ + cmd_info $cmd_info\ doc_info $doc_info\ + argdisplay_info $argdisplay_info\ id_info $id_info\ ] tcl::dict::set argdata_cache $cache_key $argdata_dict @@ -1081,7 +1244,6 @@ tcl::namespace::eval punk::args { return $result } } - return } proc get_spec_values {id {patternlist *}} { variable argdefcache_by_id @@ -1098,6 +1260,7 @@ tcl::namespace::eval punk::args { set def [dict remove $def -ARGTYPE] append result \n "$v $def" } + return $result } else { foreach pat $patternlist { set matches [dict keys $arg_info $pat] @@ -1111,19 +1274,28 @@ tcl::namespace::eval punk::args { return $result } } - return } #proc get_spec_leaders ?? #proc get_spec_opts ?? + proc get_def {id} { + if {[id_exists $id]} { + return [definition {*}[get_spec $id]] + } + } + proc is_dynamic {id} { + set spec [get_spec $id] + return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ] + } + variable aliases set aliases [dict create] lappend PUNKARGS [list { - *id punk::args::get_ids - *proc -name punk::args::get_ids -help\ + @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 + @values -min 0 -max 1 match -default * -help\ "exact id or glob pattern for ids" }] @@ -1182,23 +1354,37 @@ tcl::namespace::eval punk::args { set loaded_packages [list] proc update_definitions {} { + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - get's 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 variable loaded_packages upvar ::punk::args::register::NAMESPACES pkgs if {[llength $loaded_packages] == [llength $pkgs]} { #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. return {} } + # -- --- --- --- --- --- + set unloaded [punklib_ldiff $pkgs $loaded_packages] set newloaded [list] foreach pkgns $unloaded { + #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { foreach deflist [set ${pkgns}::PUNKARGS] { namespace eval $pkgns [list punk::args::definition {*}$deflist] } } + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } } errMsg]} { - lappend loaded_pkgs $pkgns + lappend loaded_packages $pkgns lappend newloaded $pkgns } else { puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" @@ -1273,7 +1459,8 @@ tcl::namespace::eval punk::args { set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error dict for {k v} $args { - switch -- $k { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + switch -- $fullk { -badarg { set badarg $v } @@ -1285,7 +1472,7 @@ tcl::namespace::eval punk::args { set as_error $v } -return { - if {$v ni {string table tableobject}} { + 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" } @@ -1293,7 +1480,7 @@ tcl::namespace::eval punk::args { } default { set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return" + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" } } } @@ -1328,14 +1515,22 @@ tcl::namespace::eval punk::args { append errmsg \n } } - set procname [Dict_getdef $spec_dict proc_info -name ""] - set prochelp [Dict_getdef $spec_dict proc_info -help ""] + set procname [Dict_getdef $spec_dict cmd_info -name ""] + set prochelp [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 ""] + set blank_header_col [list] if {$procname ne ""} { lappend blank_header_col "" set procname_display [a+ brightwhite]$procname[a] @@ -1344,7 +1539,8 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { lappend blank_header_col "" - set prochelp_display [a+ brightwhite]$prochelp[a] + #set prochelp_display [a+ brightwhite]$prochelp[a] + set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] } else { set prochelp_display "" } @@ -1354,18 +1550,32 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } if {$use_table} { set t [textblock::class::table new [a+ brightyellow]Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $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 {$procname ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] } else { lappend errlines "PROC/METHOD: $procname_display" } @@ -1373,7 +1583,7 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] } else { lappend errlines "Description: $prochelp_display" } @@ -1384,225 +1594,352 @@ tcl::namespace::eval punk::args { set docurl [punk::ansi::hyperlink $docurl] } if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display] + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] } else { lappend errlines "$docname $docurl_display" } incr h } if {$use_table} { - $t configure_header $h -values {Arg Type Default Multi Help} + 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-- " } - - set RST [a] - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + 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_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] - $trie destroy - foreach c [dict get $spec_dict opt_names] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } + + set RST [a] + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG [a+ brightred] + set greencheck [a+ brightgreen]\u2713[a] ;#green tick + set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX [a+ green] ;#use a+ so colour off can apply + if {$A_PREFIX eq ""} { + 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 opt_names [dict get $spec_dict opt_names] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict opt_names]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } } else { - set default "" + set opt_names [dict get $spec_dict opt_names] + set opt_names_display $opt_names } - set help [Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" + } + set leading_val_names [dict get $spec_dict leader_names] + set trailing_val_names [dict get $spec_dict val_names] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { - set casemsg " (case sensitive)" + set default "" } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices } else { - set prefixmsg "" + set choicegroups [dict merge [dict create "" $choices] $choicegroups] } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [list] - append help " Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } } - lappend formattedchoices $cdisplay + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] } } else { - set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - set prefix $c - set tail "" + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] + set formattedchoices $choicegroups } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + + } + } + 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 [a+ cyan]$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + #bold as well as brightcolour in case colour off. + append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + } else { + append help \n + } + append help \n [join $formatted \n] } - lappend formattedchoices $cdisplay - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + } 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 "" " [a+ red](no choices defined for main group)[a]" + } else { + dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + } + } else { + if {$groupname eq ""} { + append help \n " " [a+ red](no choices defined)[a] + } else { + append help \n " " [a+ red](no choices defined for group $groupname)[a] } - lappend formattedchoices $cdisplay } + } + } + 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]} { + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" } else { - set formattedchoices [dict get $arginfo -choices] + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" } - } } - set numcols 4 ;#todo - dynamic? - if {[llength $formattedchoices] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formattedchoices] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices] - append help \n[textblock::join -- " " $choicetable] - } else { - append help \n [join $formattedchoices \n] - } + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck } 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. - append help \n " " [a+ red](no choices defined)[a] + set multiple "" } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - 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]} { + 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 {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - 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 + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow[a] TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - lappend errlines "$argshow TYPE:$typeshow DEFAULT:$default MULTI:$multiple HELP:$help\n" } } - } + } ;#end is_custom_argdisplay if {$use_table} { $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] $t configure -maxwidth 80 ;#review - append errmsg [$t print] if {$returntype ne "tableobject"} { + append errmsg [$t print] #returntype of table means just the text of the table $t destroy } @@ -1640,19 +1977,26 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::usage - *proc -name punk::args::usage -help\ - "return usage information as a string - in table form." + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command. + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and not have an id. + 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 this as necessary. + " -return -default table -choices {string table tableobject} - *values -min 0 -max 1 + @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::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] set speclist [get_spec $id] if {[llength $speclist] == 0} { @@ -1662,9 +2006,9 @@ tcl::namespace::eval punk::args { } lappend PUNKARGS [list { - *id punk::args::get_by_id - *proc -name punk::args::get_by_id - *values -min 1 + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 id arglist -default "" -type list -help\ "list containing arguments to be parsed as per the @@ -1703,8 +2047,8 @@ tcl::namespace::eval punk::args { #[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 *proc *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. + #[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. @@ -1713,12 +2057,12 @@ tcl::namespace::eval punk::args { #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { - # *opts + # @opts # -opt1 -default {} # -opt2 -default { # etc # } - # *values -multiple 1 + # @values -multiple 1 #} $args #if {[llength $args] == 0} { @@ -2014,7 +2358,7 @@ tcl::namespace::eval punk::args { } if {$opt_any} { set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $opt_checks_defaults if {[tcl::dict::get $arg_info $a -type] ne "none"} { @@ -2023,7 +2367,6 @@ tcl::namespace::eval punk::args { } else { tcl::dict::set opts $a $newval } - lappend flagsreceived $a ;#adhoc flag as supplied if {[incr i] > $maxidx} { arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a } @@ -2041,11 +2384,12 @@ tcl::namespace::eval punk::args { } incr vals_remaining_possible -1 } + lappend flagsreceived $a ;#adhoc flag as supplied } else { if {[llength $opt_names]} { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while *opts -any 0" + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } arg_error $errmsg $argspecs -badarg $fullopt } @@ -2096,6 +2440,7 @@ tcl::namespace::eval punk::args { } 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 arg_info $positionalidx $leaderspec_defaults @@ -2132,7 +2477,8 @@ tcl::namespace::eval punk::args { } else { if {$in_multiple ne ""} { tcl::dict::lappend values_dict $in_multiple $val - #name already seen + #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 arg_info $positionalidx $valspec_defaults @@ -2228,7 +2574,7 @@ tcl::namespace::eval punk::args { set defaultval [tcl::dict::get $thisarg -default] } set type [tcl::dict::get $thisarg -type] - set has_choices [tcl::dict::exists $thisarg -choices] + 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] @@ -2259,10 +2605,22 @@ tcl::namespace::eval punk::args { if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set nocase [tcl::dict::get $thisarg -nocase] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + 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 clist} $choicegroups { + lappend allchoices {*}$clist + } + } + #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 @@ -2275,7 +2633,7 @@ tcl::namespace::eval punk::args { } } set idx 0 ;# - #opts/values_dict $argname membmer has been populated with the actual entered choices - which might be prefixes + #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] @@ -2283,44 +2641,95 @@ tcl::namespace::eval punk::args { foreach e $vlist e_check $vlist_check { if {$nocase} { set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $choices] + 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 $e_check] } else { set casemsg " (case sensitive)" set v_test $e_check - set choices_test $choices + set choices_test $allchoices } set choice_in_list 0 set matches_default [expr {$has_default && $e eq $defaultval}] if {!$matches_default} { if {$choiceprefix} { - set chosen [tcl::prefix::match -error "" $choices_test $v_test] - if {$chosen ne ""} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$e_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $e_check set choice_in_list 1 - #can we handle empty string as a choice? It should just work - REVIEW/test - #must use exact in case glob chars present e.g * ? [] (also ansi has square brackets) - set choice [lsearch -exact -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + set chosen $v_test + 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] $e_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + set choice_in_list [expr {$chosen ne ""}] + #we + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $e_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 "" + } + } + + if {$choice_in_list && !$choice_exact_match} { if {$is_multiple} { set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $choice + lset existing $idx $chosen tcl::dict::set $dname $argname $existing } else { - tcl::dict::set $dname $argname $choice + tcl::dict::set $dname $argname $chosen } } } 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 - } + #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 $e lappend vlist_check_validate $e_check } else { @@ -2330,13 +2739,13 @@ tcl::namespace::eval punk::args { } else { set prefixmsg "" } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname } } 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 + #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 } @@ -2354,7 +2763,7 @@ tcl::namespace::eval punk::args { 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 + #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 @@ -2376,7 +2785,7 @@ tcl::namespace::eval punk::args { #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 + #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 { @@ -2690,6 +3099,10 @@ tcl::namespace::eval punk::args { } 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] } @@ -2702,12 +3115,12 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::TEST - *opts -optional 0 + @id -id ::punk::args::TEST + @opts -optional 0 -o1 -default 111 -help "opt 1 mandatory" - *opts -optional 1 + @opts -optional 1 -o2 -default 222 -help "opt 2 optional" - *values -min 0 -max 1 + @values -min 0 -max 1 v -help\ "v1 optional" }] @@ -2762,16 +3175,18 @@ tcl::namespace::eval punk::args::lib { #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 punk::args::lib::tstr - *proc -name punk::args::lib::tstr -help\ + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ "A rough equivalent of js template literals" -allowcommands -default 0 -type none -help\ - "if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "if -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" -return -default list -choices {dict list string args}\ -choicelabels { dict\ "Return a dict with keys - 'template' and 'params'" + 'template', 'params' and + 'errors'" string\ "Return a single result being the string with @@ -2791,7 +3206,7 @@ tcl::namespace::eval punk::args::lib { args\ "Return a list where the first element is a list of template - plaintext secions as per the + plaintext sections as per the 'list' return mechanism, but the placeholder items are individual items in the returned list. @@ -2808,7 +3223,7 @@ tcl::namespace::eval punk::args::lib { contained variables in that case should be braced, 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 + @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 @@ -2820,7 +3235,7 @@ tcl::namespace::eval punk::args::lib { 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 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] @@ -2838,7 +3253,12 @@ tcl::namespace::eval punk::args::lib { dict set opts -allowcommands 1 } if {[llength $arglist] % 2 != 0} { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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 -return -eval} $k] @@ -2847,12 +3267,20 @@ tcl::namespace::eval punk::args::lib { dict set opts $fullk $v } default { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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_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] @@ -2871,6 +3299,7 @@ tcl::namespace::eval punk::args::lib { #set expressions [list] set params [list] set idx 0 + set errors [dict create] foreach {pt expression} $parts { lappend textchunks $pt incr idx ;#pt incr @@ -2881,17 +3310,32 @@ tcl::namespace::eval punk::args::lib { } #lappend expressions $expression if {$opt_eval} { - lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] } else { lappend params $expression } incr idx ;#expression incr } - switch -- $opt_return { - dict { - return [dict create template $textchunks params $params] + + 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 } + puts stderr "tstr errors:\n$einfo\n]" + } + + switch -- $opt_return { list { return [list $textchunks $params] } @@ -2906,20 +3350,18 @@ tcl::namespace::eval punk::args::lib { } return $out } - default { - } } } #test single placeholder tstr args where single placeholder must be an int proc tstr_test_one {args} { set argd [punk::args::get_dict { - *proc -name tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + @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 + @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" 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 eacc6619..5624ec58 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 @@ -254,8 +254,9 @@ namespace eval punk::cap::handlers::templates { } method folders {args} { set argd [punk::args::get_dict { + @id -id "::punk::cap::handlers::templates::class::api folders" -startdir -default "" - *values -max 0 + @values -max 0 } $args] set opts [dict get $argd opts] @@ -471,10 +472,11 @@ namespace eval punk::cap::handlers::templates { } method get_itemdict_projectlayouts {args} { set argd [punk::args::get_dict { - *opts -anyopts 1 + @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 + @values -maxvalues -1 } $args] set opt_startdir [dict get $argd opts -startdir] @@ -648,14 +650,15 @@ namespace eval punk::cap::handlers::templates { #and a name determining command -command_get_item_name method _get_itemdict {args} { set argd [punk::args::get_dict { - *proc -name _get_itemdict - *opts -anyopts 0 + @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 + @values -maxvalues -1 globsearches -default * -multiple 1 } $args] set opts [dict get $argd opts] 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 493ea5aa..fbce0905 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 @@ -362,10 +362,10 @@ tcl::namespace::eval punk::config { proc configure {args} { set argdef { - *id punk::config::configure - *proc -name punk::config::configure -help\ + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ "UNIMPLEMENTED" - *values -min 1 -max 1 + @values -min 1 -max 1 whichconfig -type string -choices {startup running stop} } set argd [punk::args::get_dict $argdef $args] @@ -388,15 +388,15 @@ tcl::namespace::eval punk::config { #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration proc copy {args} { set argdef { - *id punk::config::copy - *proc -name punk::config::copy -help\ + @id -id ::punk::config::copy + @cmd -name punk::config::copy -help\ "Copy a partial or full configuration from one config to another If a target config has additional settings, then the source config can be considered to be partial with regards to the target. " -type -default "" -choices {replace merge} -help\ "Defaults to merge when target is running-config Defaults to replace when source is running-config" - *values -min 2 -max 2 + @values -min 2 -max 2 fromconfig -help\ "running or startup or file name (not fully implemented)" toconfig -help\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index c27503c3..d2c08e8b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -875,7 +875,7 @@ namespace eval punk::console { } } - punk::args::set_alias punk::console::code_a+ punk::ansi::a+ + punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ proc code_a+ {args} { variable ansi_wanted if {$ansi_wanted <= 0} { @@ -1187,14 +1187,14 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::definition { - *id punk::console::cell_size + @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list - *values -min 0 -max 1 + @values -min 0 -max 1 newsize -default "" -help\ "character cell pixel dimensions WxH" } proc cell_size {args} { - set argd [punk::args::get_by_id punk::console::cell_size $args] + set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] set newsize [dict get $argd values newsize] 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 9f74d2d5..adb47eff 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 @@ -563,9 +563,10 @@ namespace eval punk::du { variable win_reparse_tags_by_int set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" } $args] set opts [dict get $argd opts] @@ -621,10 +622,11 @@ namespace eval punk::du { proc attributes_twapi {args} { set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" } $args] set opts [dict get $argd opts] 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 04f3487b..6de20bff 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 @@ -1252,14 +1252,14 @@ namespace eval punk::fileline { #[list_begin definitions] punk::args::definition { - *id punk::fileline::get_textinfo - *proc -name punk::fileline::get_textinfo -help\ + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" -file -default {} -type existingfile -translation -default iso8859-1 -encoding -default "\uFFFF" -includebom -default 0 - *values -min 0 -max 1 + @values -min 0 -max 1 } proc get_textinfo {args} { #*** !doctools @@ -1276,7 +1276,7 @@ namespace eval punk::fileline { #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. - lassign [dict values [punk::args::get_by_id punk::fileline::get_textinfo $args]] opts values + lassign [dict values [punk::args::get_by_id ::punk::fileline::get_textinfo $args]] opts values # -- --- --- --- set opt_file [dict get $opts -file] set opt_translation [dict get $opts -translation] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm index 6fabbba7..353d1f65 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -1009,13 +1009,13 @@ namespace eval punk::lib { set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " } set argspec [string map [list %sep% $sep] { - *id punk::lib::pdict - *proc -name pdict -help\ + @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 + @opts -any 1 #default separator to provide similarity to tcl's parray function -separator -default "%sep%" @@ -1023,7 +1023,7 @@ namespace eval punk::lib { -substructure -default {} -channel -default stdout -help "existing channel - or 'none' to return as string" - *values -min 1 -max -1 + @values -min 1 -max -1 dictvar -type string -help "name of variable. Can be a dict, list or array" @@ -1095,14 +1095,16 @@ namespace eval punk::lib { package require textblock set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { - *id punk::lib::showdict - *proc -name punk::lib::showdict -help "display dictionary keys and values" + @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 - " + -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" @@ -1114,7 +1116,7 @@ namespace eval punk::lib { -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 + @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" }] $args] @@ -2816,7 +2818,7 @@ namespace eval punk::lib { #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 { -joinchar -default \n - *values -min 1 -max 1 + @values -min 1 -max 1 } $args]] leaders opts values puts "opts:$opts" puts "values:$values" @@ -2857,7 +2859,7 @@ namespace eval punk::lib { #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 { - *opts -any 1 + @opts -any 1 -block -default {} } $args]] leaderdict opts valuedict tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] 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 8d68b28a..6b1923b1 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 @@ -168,9 +168,10 @@ namespace eval punk::mix::commandset::doc { } proc validate {args} { set argd [punk::args::get_dict { + @id -id ::punk::mix::commandset::doc::validate -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 - *values -min 0 -max -1 + @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 } $args] set opt_individual [tcl::dict::get $argd opts -individual] 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 a31da91a..47c75d33 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 @@ -34,7 +34,8 @@ namespace eval punk::mix::commandset::layout { #per layout functions proc files {{layout ""}} { set argd [punk::args::get_dict { - *values -min 1 -max 1 + @id -id ::punk::mix::commandset::layout::files + @values -min 1 -max 1 layout -type string -minsize 1 } [list $layout]] @@ -88,7 +89,8 @@ namespace eval punk::mix::commandset::layout { proc _default {args} { punk::args::get_dict [subst { - *proc -name ::punk::mix::commandset::layout::collection::_default + @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 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index f5a5491e..f427f29f 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -27,20 +27,24 @@ namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs punk::args::definition { - *id punk::mix::commandset::loadedlib::search - *proc -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" + @id -id ::punk::mix::commandset::loadedlib::search + @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} -present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\ - "(unimplemented) Display only those that are 0:absent 1:present 2:both" - -highlight -type boolean -default 1 -help "Highlight which version is present with ansi underline and colour" + "(unimplemented) Display only those that are 0:absent 1:present 2:either" + -highlight -type boolean -default 1 -help\ + "Highlight which version is present with ansi underline and colour" -refresh -default 0 -type boolean -help "Re-scan the tm and library folders" searchstrings -default * -multiple 1 -help\ "Names to search for, may contain glob chars (* ?) e.g *lib* If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. - eg name -> *name*" + eg name -> *name* + To search for an exact name prefix it with = + e.g =name -> name + " } proc search {args} { - set argd [punk::args::get_by_id punk::mix::commandset::loadedlib::search $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::loadedlib::search $args] set searchstrings [dict get $argd values searchstrings] set opts [dict get $argd opts] set opt_return [dict get $opts -return] @@ -55,7 +59,7 @@ namespace eval punk::mix::commandset::loadedlib { set packages [package names] set matches [list] foreach search $searchstrings { - if {[regexp {[?*]} $search]} { + if {[regexp {[?*\[]} $search]} { #caller has specified specific glob pattern - use it #todo - respect supplied case only if uppers present? require another flag? lappend matches {*}[lsearch -all -inline -nocase $packages $search] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 44627536..2079eb8c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -123,10 +123,11 @@ namespace eval punk::mix::commandset::module { #return all module templates with repeated ones suffixed with .2 .3 etc proc templates_dict {args} { set argspec { - *proc -name templates_dict -help "Templates from module and project paths" + @id -id ::punk::mix::commandset::module::templates_dict + @cmd -name templates_dict -help "Templates from module and project paths" -startdir -default "" -help "Project folder used in addition to module paths" -not -default "" -multiple 1 - *values + @values globsearches -default * -multiple 1 } set argd [punk::args::get_dict $argspec $args] @@ -141,8 +142,8 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] punk::args::definition [subst { - *id punk::mix::commandset::module::new - *proc -name "punk::mix::commandset::module::new" -help\ + @id -id ::punk::mix::commandset::module::new + @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. If the name given in the module argument is namespaced, the necessary subfolder(s) will be used or created." @@ -160,7 +161,7 @@ namespace eval punk::mix::commandset::module { If false (default) an error will be raised if there is a conflict." -quiet -default 0 -type boolean -help\ "Suppress information messages on stdout" - *values -min 1 -max 1 + @values -min 1 -max 1 module -type string -help\ "Name of module, possibly including a namespace and/or version number e.g mynamespace::mymodule-1.0" @@ -168,7 +169,7 @@ namespace eval punk::mix::commandset::module { proc new {args} { set year [clock format [clock seconds] -format %Y] # use \uFFFD because unicode replacement char should consistently render as 1 wide - set argd [punk::args::get_by_id punk::mix::commandset::module::new $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::module::new $args] lassign [dict values $argd] leaders opts values received set module [dict get $values module] 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 65a9fb77..98f171c7 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 @@ -1262,15 +1262,15 @@ namespace eval punk::mix::commandset::scriptwrap { # [list_begin arguments] # [arg_def string args] name-value pairs -scriptpath # [list_end] - *id punk::mix::commandset::scriptwrap - *proc -name punk::mix::commandset::get_wrapper_folders + @id -id ::punk::mix::commandset::scriptwrap + @cmd -name punk::mix::commandset::get_wrapper_folders - *opts -anyopts 0 + @opts -anyopts 0 -scriptpath -default "" -type directory\ -help "" #todo -help folder within a punk.templates provided area??? - *values -minvalues 0 -maxvalues 0 + @values -minvalues 0 -maxvalues 0 } $args] # -- --- --- --- --- --- --- --- --- 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 159c6f37..3f5f3a71 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 @@ -636,13 +636,14 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles + -stripbase -default 1 -type boolean + -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" + @values -min 0 -max -1 + } proc dirfiles {args} { - set argspecs { - -stripbase -default 1 -type boolean - -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" - *values -min 0 -max -1 - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] @@ -726,14 +727,14 @@ tcl::namespace::eval punk::nav::fs { # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied proc dirfiles_dict {args} { set argspecs { - *id punk::nav::fs::dirfiles_dict - *opts -any 0 + @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 + @values -min 0 -max -1 -type string } set argd [punk::args::get_dict $argspecs $args] lassign [dict values $argd] leaders opts vals @@ -991,16 +992,17 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles_dict_as_lines + -stripbase -default 0 -type boolean + -formatsizes -default 1 -type boolean + @values -min 1 -max -1 -type dict + } + #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? proc dirfiles_dict_as_lines {args} { package require overtype - - set argspecs { - -stripbase -default 0 -type boolean - -formatsizes -default 1 -type boolean - *values -min 1 -max -1 -type dict - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles_dict_as_lines $args] lassign [dict values $argd] leaders opts vals set list_of_dicts [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 14b8f00d..f8a1e939 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 @@ -1608,7 +1608,7 @@ tcl::namespace::eval punk::ns { if {$word1 eq "punk::mix::base::_cli"} { #special case for punk deck - REVIEW #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set fq [lindex $tgt end] + set fq [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) @@ -1618,7 +1618,8 @@ tcl::namespace::eval punk::ns { set fq [nsjoin $location $c] } if {$has_punkargs} { - set id [string trimleft $fq :] + #set id [string trimleft $fq :] + set id $fq if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1892,110 +1893,188 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + if {[lsearch -exact $nscommands $querycommand] >= 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]] }]} { - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { #fully qualified command specified but doesn't exist - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { - set thispath [uplevel 1 [list ::nsthis $commandpath]] - set targetns [nsprefix $thispath] - set name [nstail $thispath] - set targetparts [nsparts $targetns] - if {[lsearch $targetparts :*] >=0} { - #weird ns - set valid_ns [nsexists $targetns] + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand } 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 commandpath 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 + set thispath [uplevel 1 [list ::nsthis $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 + set numvals [expr {[llength $queryargs]+1}] + #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]] + + #set origin $querycommand + #set resolved $querycommand + } - } else { - #namespace doesn't seem to exist - but there still could be documentation for lazy loaded ns and command - set origin $commandpath - set resolved $commandpath - } - } - #set thiscmd [nsjoin $targetns $name] - #if {[info commands $thiscmd] eq ""} { - # set origin $thiscmd - # set resolved $thiscmd - #} else { - # set origin [nseval $targetns [list ::namespace origin $name]] - # set resolved [nseval $targetns [list ::namespace which $name]] - #} + } + } #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! - #considure using which_alias (wiki) + #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 fq [lindex $tgt end] + 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 fq $word1 + set targetword $word1 + 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]] } - set origin $fq + + + set origin $targetword #retest cmdtype on modified origin set cmdtype [punk::ns::cmdtype $origin] } else { @@ -2013,6 +2092,83 @@ tcl::namespace::eval punk::ns { } } + + set id $origin + if {[info commands ::punk::args::id_exists] ne ""} { + #cycle through longest first checking for id matching ::cmd ?subcmd..? + #REVIEW - this doesn't cater for prefix callable subcommands! + set argcopy $queryargs + while {[llength $argcopy]} { + if {[punk::args::id_exists [list $id {*}$argcopy]]} { + return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$argcopy]]] + } + lpop argcopy + } + + #didn't find any exact matches + #traverse from other direction taking prefixes into account + + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set def [punk::args::get_def $id] + if {[llength $queryargs]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + foreach q $queryargs { + if {[llength [dict get $def leader_names]]} { + set subitems [dict get $def leader_names] + if {[llength $subitems]} { + set next [lindex $subitems 0] + set arginfo [dict get $def arg_info $next] + + 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 ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices {*}$clist + } + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + 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 numvals [expr {[llength $queryargs]+1}] + return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] + } + #check if subcommands so far have a custom args def + set currentid [list $querycommand {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set def [punk::args::get_def $currentid + } else { + #We can get no further with custom defs + break + } + } + } else { + #review + break + } + } + } else { + return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } + } + } + + if {[string match "(autodef)*" $origin]} { + #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) + set origin [string range $origin [string length (autodef)] end] + set resolved $origin + } + switch -- $cmdtype { object { #class is also an object @@ -2025,19 +2181,19 @@ tcl::namespace::eval punk::ns { #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - if {[llength $commandargs]} { - set c1 [lindex $commandargs 0] + if {[llength $queryargs]} { + set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { switch -- $c1 { new { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} new" - *proc -name "${$origin} new" -help\ + @id -id "(autodef)${$origin} new" + @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 { @@ -2054,17 +2210,17 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin new"] + return [punk::args::usage {*}$opts "(autodef)$origin new"] } create { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} create" - *proc -name "${$origin} create" -help\ + @id -id "(autodef)${$origin} create" + @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" }] @@ -2083,20 +2239,20 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin create"] + return [punk::args::usage {*}$opts "(autodef)$origin create"] } destroy { #review - generally no doc # but we may want notes about a specific destructor set argspec [punk::lib::tstr -return string { - *id "${$origin} destroy" - *proc -name "destroy" -help\ + @id -id "(audodef)${$origin} destroy" + @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." - *values -min 0 -max 0 + @values -min 0 -max 0 }] punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin destroy"] + return [punk::args::usage {*}$opts "(autodef)$origin destroy"] } default { #use info object call to resolve callchain @@ -2111,20 +2267,24 @@ tcl::namespace::eval punk::ns { lassign $impl generaltype mname location methodtype switch -- $generaltype { method - private { - + #objects being dynamic systems - we should always reinspect. + #Don't use the cached (autodef) def + #If there is a custom def override - use it (should really be -dynamic - but we don't check) if {$location eq "object"} { - set id "[string trimleft $origin :] $c1" ;# " " + set idcustom "$origin $c1" + #set id "[string trimleft $origin :] $c1" ;# " " if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info object definition $origin $c1] } else { - set id "[string trimleft $location :] $c1" ;# " " + #set id "[string trimleft $location :] $c1" ;# " " + set idcustom "$location $c1" if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info class definition $location $c1] @@ -2138,12 +2298,15 @@ tcl::namespace::eval punk::ns { } } if {$def ne ""} { + #assert - if we pre + set autoid "(autodef)$location $c1" set arglist [lindex $def 0] set argspec [punk::lib::tstr -return string { - *id "${$location} ${$c1}" - *proc -name "${$location} ${$c1}" -help\ - "arglist:${$arglist}" - *values + @id -id "${$autoid}" + @cmd -name "${$location} ${$c1}" -help\ + "(autogenerated) + arglist:${$arglist}" + @values }] set i 0 foreach a $arglist { @@ -2166,7 +2329,7 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$location $c1"] + return [punk::args::usage {*}$opts $autoid] } else { return "unable to resolve $origin method $c1" } @@ -2189,9 +2352,11 @@ tcl::namespace::eval punk::ns { switch -- $generaltype { method - private { if {$location eq "object"} { - set id "[string trimleft $origin :] $cmd" ;# " " + #set id "[string trimleft $origin :] $cmd" ;# " " + set id "$origin $cmd" } else { - set id "[string trimleft $location :] $cmd" ;# " " + #set id "[string trimleft $location :] $cmd" ;# " " + set id "$location $cmd" } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { @@ -2212,15 +2377,16 @@ tcl::namespace::eval punk::ns { set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" + set idauto "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -name "Object: ${$origin}" -help\ - "Instance of class: ${$class}" - *values -min 1 + @id -id ${$idauto} + @cmd -name "Object: ${$origin}" -help\ + "Instance of class: ${$class} (info autogenerated)" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $idauto] } privateObject { return "Command is a privateObject - no info currently available" @@ -2287,11 +2453,11 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] - if {[llength $commandargs]} { - set match [tcl::prefix::match $subcommands [lindex $commandargs 0]] + 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 $commandargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + 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") } } @@ -2307,9 +2473,9 @@ tcl::namespace::eval punk::ns { 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] + lappend have_usageinfo {*}[dict get $nsinfo usageinfo] + lappend is_ensemble {*}[dict get $nsinfo ensembles] + lappend is_object {*}[dict get $nsinfo ooobjects] } set choicelabeldict [dict create] @@ -2324,14 +2490,17 @@ tcl::namespace::eval punk::ns { } set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set autoid "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -help "ensemble: ${$origin}" - *values -min 1 + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + ensemble: ${$origin}" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2364,12 +2533,6 @@ tcl::namespace::eval punk::ns { } } - set id [string trimleft $origin :] - if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] - } - } set origin_ns [nsprefix $origin] set parts [nsparts $origin_ns] set weird_ns 0 @@ -2379,24 +2542,42 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set argl {} set tail [nstail $origin] - foreach a [nseval_ifexists $origin_ns [list info args $tail]] { - if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { - lappend a $def + set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] + if {$cmdtype eq "proc"} { + foreach a [nseval_ifexists $origin_ns [list info args $tail]] { + if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } else { - set argl {} - foreach a [info args $origin] { - if {[info default $origin $a def]} { - lappend a $def + set cmdtype [punk::ns::cmdtype $origin] + if {$cmdtype eq "proc"} { + set argl {} + set infoargs [info args $origin] + foreach a $infoargs { + if {[info default $origin $a def]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } - set msg "No argument processor detected" - append msg \n "function signature: $resolved $argl" + if {[llength $queryargs]} { + #todo - something better + set msg "Undocumented or nonexistant subcommand $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" + } else { + set msg "Undocumented command $origin. Type: $cmdtype" + } + } return $msg } @@ -2738,8 +2919,8 @@ tcl::namespace::eval punk::ns { interp alias "" use "" punk::ns::pkguse punk::args::definition { - *id punk::ns::nsimport_noclobber - *proc -name punk::ns::nsimport_noclobber -help\ + @id -id ::punk::ns::nsimport_noclobber + @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, or that specified in -targetnamespace. Return list of imported commands, ignores failures due to name conflicts" @@ -2750,14 +2931,14 @@ tcl::namespace::eval punk::ns { If not supplied, caller's namespace is used." -prefix -optional 1 -help\ "string prefix for command names in target namespace" - *values -min 1 -max 1 + @values -min 1 -max 1 sourcepattern -type string -optional 0 -help\ "Glob pattern for source namespace. Globbing only active in the tail segment. e.g ::mynamespace::*" } proc nsimport_noclobber {args} { - lassign [dict values [punk::args::get_by_id punk::ns::nsimport_noclobber $args]] leaders opts values received + lassign [dict values [punk::args::get_by_id ::punk::ns::nsimport_noclobber $args]] leaders opts values received set sourcepattern [dict get $values sourcepattern] set source_ns [tcl::namespace::qualifiers $sourcepattern] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm index d3431188..65ede7c8 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm @@ -645,14 +645,14 @@ namespace eval punk::path { } punk::args::definition { - *id punk::path::treefilenames + @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." -call-depth-internal -default 0 -type integer -antiglob_paths -default {} -help\ "list of path patterns to exclude may include * and ** path segments e.g /usr/**" - *values -min 0 -max -1 -optional 1 -type string + @values -min 0 -max -1 -optional 1 -type string tailglobs -multiple 1 -help\ "Patterns to match against filename portion (last segment) of each file path within the directory tree being searched." @@ -671,7 +671,7 @@ namespace eval punk::path { #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para]no natsorting - so order is dependent on filesystem - set argd [punk::args::get_by_id punk::path::treefilenames $args] + set argd [punk::args::get_by_id ::punk::path::treefilenames $args] lassign [dict values $argd] leaders opts values received set tailglobs [dict values $values] # -- --- --- --- --- --- --- 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 28a7271b..98bc04ef 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 @@ -62,6 +62,73 @@ package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- namespace eval punk::repo { + variable PUNKARGS + variable PUNKARGS_aliases + + proc get_fossil_usage {} { + set allcmds [runout -n fossil help -a] + set mainhelp [runout -n fossil help] + set maincommands [list] + foreach ln [split $mainhelp \n] { + set ln [string trim $ln] + if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { + continue + } + lappend maincommands {*}$ln + } + set othercmds [punk::lib::ldiff $allcmds $maincommands] + + set result "@leaders -min 0\n" + + append result [tstr -return string { + subcommand -type string -choicecolumns 8 -choicegroups { + "frequently used commands" {${$maincommands}} + "" {${$othercmds}} + } + }] + + return $result + } + + + #lappend PUNKARGS [list -dynamic 1 { + # @id -id ::punk::repo::fossil_proxy + # @cmd -name fossil -help "fossil executable + # " + # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # } ""] + + lappend PUNKARGS [list -dynamic 1 { + @id -id ::punk::repo::fossil_proxy + @cmd -name fossil -help "fossil executable" + ${[punk::repo::get_fossil_usage]} + } ] + + + + #experiment + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + #TODO + #lappend PUNKARGS [list -dynamic 1 { + # @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]}} + # } ""] + lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} + lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} + #Todo - investigate proper way to install a client-side commit hook in the fossil project #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used @@ -137,7 +204,7 @@ namespace eval punk::repo { puts stderr "fossil command not found. Please install fossil" } } - interp alias "" fossil "" punk::repo::fossil_proxy + # --- # Calling auto_execok on an external tool can be too slow to do during package load (e.g could be 150ms) @@ -153,6 +220,7 @@ namespace eval punk::repo { # ---------- # + #uppercase FOSSIL to bypass fossil as alias to fossil_proxy proc establish_FOSSIL {args} { if {![info exists ::auto_execs(FOSSIL)]} { @@ -161,7 +229,6 @@ namespace eval punk::repo { interp alias "" FOSSIL "" ;#delete establishment alias FOSSIL {*}$args } - interp alias "" FOSSIL "" punk::repo::establish_FOSSIL # ---------- proc askuser {question} { @@ -1577,6 +1644,8 @@ namespace eval punk::repo { } } + interp alias "" fossil "" punk::repo::fossil_proxy + interp alias "" FOSSIL "" punk::repo::establish_FOSSIL interp alias {} is_fossil {} ::punk::repo::is_fossil interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root @@ -1609,6 +1678,17 @@ namespace eval punk::repo::lib { } + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +if {![info exists ::punk::args::register::NAMESPACES]} { + namespace eval ::punk::args::register { + set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace + } +} +lappend ::punk::args::register::NAMESPACES ::punk::repo +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::repo [namespace eval punk::repo { 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 311a8025..11ae9ab2 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 @@ -180,10 +180,11 @@ tcl::namespace::eval punk::zip { #}] set argd [punk::args::get_dict { - *proc -name punk::zip::walk + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -excludes -default "" -help "list of glob expressions to match against files and exclude" -subpath -default "" - *values -min 1 -max -1 + @values -min 1 -max -1 base fileglobs -default {*} -multiple 1 } $args] @@ -373,11 +374,12 @@ tcl::namespace::eval punk::zip { #[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 { - *proc -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + @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 + @opts -comment -default "" -help "An optional comment specific to the added file" - *values -min 3 -max 4 + @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" @@ -525,9 +527,10 @@ tcl::namespace::eval punk::zip { #[para] Call 'punk::zip::mkzip' with no arguments for usage display. set argd [punk::args::get_dict { - *proc -name punk::zip::mkzip\ + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ -help "Create a zip archive in 'filename'" - *opts + @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. @@ -557,7 +560,7 @@ tcl::namespace::eval punk::zip { it must be a parent of -directory or the same path as -directory" -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - *values -min 1 -max -1 + @values -min 1 -max -1 filename -type file -default ""\ -help "name of zipfile to create" globs -default {*} -multiple 1\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm index 3651c0f0..dcc023ec 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.2.tm @@ -123,12 +123,12 @@ tcl::namespace::eval textblock { set choicemsg " (unavailable packages: $unavailable)" } set argd [punk::args::get_dict [tstr -return string { - *id textblock::use_hash - *proc -name "textblock::use_hash" -help\ + @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 + @values -min 0 -max 1 hash_algorithm -choices {${$choices}} -optional 1 -help\ "algorithm choice ${$choicemsg}" }] $args] @@ -423,7 +423,6 @@ tcl::namespace::eval textblock { } } } - my configure {*}$o_opts_table #foreach {k v} $args { # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. @@ -453,6 +452,7 @@ tcl::namespace::eval textblock { -minheight 1\ -maxheight ""\ ] + my configure {*}$o_opts_table } method width_algorithm {{alg ""}} { @@ -593,7 +593,7 @@ tcl::namespace::eval textblock { tcl::dict::set o_opts_table_effective -framelimits_header $hlims return [tcl::dict::create body $blims header $hlims] } - method configure args { + method configure {args} { #*** !doctools #[call class::table [method configure] [arg args]] #[para] get or set various table-level properties @@ -781,6 +781,14 @@ tcl::namespace::eval textblock { } } } + -title { + set twidth [punk::ansi::printing_length $v] + if {[my width] < [expr {$twidth+2}]} { + set o_calculated_column_widths [list] + tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] + } + tcl::dict::set o_opts_table -title $v + } default { tcl::dict::set o_opts_table $k $v } @@ -3943,14 +3951,13 @@ tcl::namespace::eval textblock { if {$header_build eq "" && ![llength $body_blocks]} { set header_build $nextcol_header - lappend body_blocks $nextcol_body } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] } - lappend body_blocks $nextcol_body #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } + lappend body_blocks $nextcol_body incr padwidth $bodywidth incr colposn } @@ -4096,8 +4103,8 @@ tcl::namespace::eval textblock { } punk::args::definition { - *id textblock::periodic - *proc -name textblock::periodic -help "A rudimentary periodic table + @id -id ::textblock::periodic + @cmd -name textblock::periodic -help "A rudimentary periodic table This is primarily a test of textblock::class::table" -return -default table\ @@ -4109,13 +4116,13 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id textblock::periodic $args] opts] + set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -4345,7 +4352,10 @@ tcl::namespace::eval textblock { set FRAMETYPES [textblock::frametypes] punk::args::definition [punk::lib::tstr -return string { - *id textblock::list_as_table + @id -id ::textblock::list_as_table + @cmd -name "textblock::list_as_table" -help\ + "Display a list in a bordered table + " -return -default table -choices {table tableobject} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ @@ -4376,13 +4386,13 @@ tcl::namespace::eval textblock { -help "Number of table columns Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 + @values -min 0 -max 1 datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" }] proc list_as_table {args} { set FRAMETYPES [textblock::frametypes] - set argd [punk::args::get_by_id textblock::list_as_table $args] + set argd [punk::args::get_by_id ::textblock::list_as_table $args] set opts [dict get $argd opts] set datalist [dict get $argd values datalist] @@ -4894,7 +4904,7 @@ tcl::namespace::eval textblock { #review!? #-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line - set usage "pad ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" + set usage "pad block ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" foreach {k v} $args { switch -- $k { -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { @@ -5420,16 +5430,21 @@ tcl::namespace::eval textblock { return [punk::lib::list_as_lines -- $outlines] } + + punk::args::definition { + @id -id ::textblock::join_basic + @cmd -name textblock::join_basic -help\ + "Join blocks of text 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 + " + -- -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 + } + #join without regard to each line length in a block (no padding added to make each block uniform) proc ::textblock::join_basic {args} { - #*proc -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 { - -- -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 argd [punk::args::get_by_id ::textblock::join_basic $args] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5466,7 +5481,7 @@ tcl::namespace::eval textblock { return [::join $outlines \n] } proc ::textblock::join_basic2 {args} { - #*proc -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + #@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 { @@ -6046,8 +6061,8 @@ tcl::namespace::eval textblock { if {$bad_option || [llength $values] == 0} { #no framedef supplied, or unrecognised opt seen set spec [string map [list $::textblock::frametypes] { - *id textblock::framedef - *proc -name textblock::framedef\ + @id -id ::textblock::framedef + @cmd -name textblock::framedef\ -help "Return a dict of the elements that make up a frame border. May return a subset of available elements based on memberglob values." @@ -6058,7 +6073,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - *values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -7438,17 +7453,17 @@ tcl::namespace::eval textblock { set frame_cache [tcl::dict::create] punk::args::definition { - *id textblock::frame_cache - *proc -name textblock::frame_cache -help\ + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ "Display or clear the frame cache." -action -default {} -choices {clear} -help\ "Clear the textblock::frame_cache dictionary" -pretty -default 1 -help\ "Use 'pdict textblock::frame_cache */*' for prettier output" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc frame_cache {args} { - set argd [punk::args::get_by_id textblock::frame_cache $args] + set argd [punk::args::get_by_id ::textblock::frame_cache $args] set action [dict get $argd opts -action] if {$action ni [list clear ""]} { @@ -7490,13 +7505,40 @@ tcl::namespace::eval textblock { } + variable FRAMETYPES set FRAMETYPES [textblock::frametypes] + variable EG set EG [a+ brightblack] + variable RST set RST [a] + + proc frame_samples {} { + set FRAMETYPELABELS [dict create] + if {[info commands ::textblock::frame] ne ""} { + foreach ft [frametypes] { + dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] + } + } + set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] + return $FRAMETYPELABELS + } + #proc EG {} "return {[a+ brightblack]}" + #make EG fetch from SGR cache so as to abide by colour off/on + proc EG {} { + a+ brightblack + } + #proc RST {} "return {\x1b\[m}" + proc RST {} { + return "\x1b\[m" + } + + #catch 22 for -choicelabels - need some sort of lazy evaluation + # ${[textblock::frame_samples]} + #todo punk::args alias for centre center etc? - punk::args::definition [punk::lib::tstr -return string { - *id textblock::frame - *proc -name "textblock::frame"\ + punk::args::definition -dynamic 1 { + @id -id ::textblock::frame + @cmd -name "textblock::frame"\ -help "Frame a block of text with a border." -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and @@ -7504,18 +7546,21 @@ tcl::namespace::eval textblock { Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." - -type -default light -choices {${$FRAMETYPES}} -choicerestricted 0 -type dict\ + -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ + -choicelabels { + ${[textblock::frame_samples]} + }\ -help "Type of border for frame." -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. passing an empty string will result in no box, but title/subtitle will still appear if supplied. - ${$EG}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${$RST}" + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. May contain ANSI - no trailing reset required. - ${$EG}e.g 1: frame -title My[a+ green]Green[a]Thing - e.g 2: frame -title [a+ red underline]MyThing${$RST}" + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" -subtitle -default "" -type string -regexprefail {\n}\ -help "Frame subtitle placed on bottombar - no newlines May contain Ansi - no trailing reset required." @@ -7526,8 +7571,8 @@ tcl::namespace::eval textblock { -help "Height of resulting frame including borders." -ansiborder -default "" -type ansistring\ -help "Ansi escape sequence to set border attributes. - ${$EG}e.g 1: frame -ansiborder [a+ web-red] contents - e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${$RST}" + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" -ansibase -default "" -type ansistring\ -help "Default ANSI attributes within frame." -blockalign -default centre -choices {left right centre}\ @@ -7547,13 +7592,13 @@ tcl::namespace::eval textblock { Frame width doesn't adapt and content may be truncated so -width may need to be manually set to display more." - *values -min 0 -max 1 + @values -min 0 -max 1 contents -default "" -type string\ -help "Frame contents - may be a block of text containing newlines and ANSI. Text may be 'ragged' - ie unequal line-lengths. No trailing ANSI reset required. - ${$EG}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${$RST}" - }] + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } #options before content argument - which is allowed to be absent #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. @@ -7638,7 +7683,7 @@ tcl::namespace::eval textblock { #only use punk::args if check_args is true or our basic checks failed #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { - set argd [punk::args::get_by_id textblock::frame $args] + set argd [punk::args::get_by_id ::textblock::frame $args] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8346,18 +8391,18 @@ tcl::namespace::eval textblock { } } punk::args::definition { - *id textblock::gcross + @id -id ::textblock::gcross -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block Only cross sizes that divide the size of the overall block will be used. e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. " - *values -min 0 -max 1 + @values -min 0 -max 1 size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id textblock::gcross $args] + set argd [punk::args::get_by_id ::textblock::gcross $args] set size [dict get $argd values size] set opts [dict get $argd opts] diff --git a/src/vendormodules/overtype-1.6.5.tm b/src/vendormodules/overtype-1.6.5.tm index f0e34919..0d9cd0bc 100644 --- a/src/vendormodules/overtype-1.6.5.tm +++ b/src/vendormodules/overtype-1.6.5.tm @@ -402,7 +402,10 @@ tcl::namespace::eval overtype { set looplimit [expr {[tcl::string::length $overblock] + 10}] } - set scheme 3 + #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height + #lassign [blocksize $overblock] _w overblock_width _h overblock_height + + set scheme 4 switch -- $scheme { 0 { #one big chunk @@ -443,11 +446,18 @@ tcl::namespace::eval overtype { set inputchunks [lindex [list $lflines [unset lflines]] 0] } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks [string cat $ln \n] + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + } + } } - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height set replay_codes_underlay [tcl::dict::create 1 ""] @@ -495,7 +505,7 @@ tcl::namespace::eval overtype { } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderargs [list -experimental $opt_experimental\ + set renderopts [list -experimental $opt_experimental\ -cp437 $opt_cp437\ -info 1\ -crm_mode [tcl::dict::get $vtstate crm_mode]\ @@ -510,11 +520,8 @@ tcl::namespace::eval overtype { -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ - $undertext\ - $overtext\ ] - set LASTCALL $renderargs - set rinfo [renderline {*}$renderargs] + set rinfo [renderline {*}$renderopts $undertext $overtext] set instruction [tcl::dict::get $rinfo instruction] tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] @@ -1237,8 +1244,8 @@ tcl::namespace::eval overtype { append debugmsg "looplimit $looplimit reached\n" append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $LASTCALL -cursor_column]\n" + append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" + append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" tcl::dict::for {k v} $rinfo { append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n } 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 b9081528..367f0a68 100644 --- a/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm @@ -277,8 +277,9 @@ 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::get_dict { - *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" - *opts -anyopts 0 + @id -id ::argparsingtest::test1_punkargs + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string -show_edge -default \uFFEF -type string @@ -290,15 +291,15 @@ namespace eval argparsingtest { -1 -default 1 -type boolean -2 -default 2 -type integer -3 -default 3 -type integer - *values + @values } $args] return [tcl::dict::get $argd opts] } punk::args::definition { - *id argparsingtest::test1_punkargs2 - *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" - *opts -anyopts 0 + @id -id ::test1_punkargs_by_id + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 -return -default string -type string -frametype -default \uFFEF -type string -show_edge -default \uFFEF -type string @@ -310,18 +311,41 @@ namespace eval argparsingtest { -1 -default 1 -type boolean -2 -default 2 -type integer -3 -default 3 -type integer - *values + @values + } + proc test1_punkargs_by_id {args} { + set argd [punk::args::get_by_id ::test1_punkargs_by_id $args] + return [tcl::dict::get $argd opts] + } + + punk::args::definition { + @id -id ::argparsingtest::test1_punkargs2 + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 + -return -default string -type string + -frametype -default \uFFEF -type string + -show_edge -default \uFFEF -type string + -show_seps -default \uFFEF -type string + -join -type none -multiple 1 + -x -default "" -type string + -y -default b -type string + -z -default c -type string + -1 -default 1 -type boolean + -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] + set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] return [tcl::dict::get $argd opts] } proc test1_punkargs_validate_ansistripped {args} { set argd [punk::args::get_dict { - *proc -name argtest4 -help "test of punk::args::get_dict comparative performance" - *opts -anyopts 0 + @id -id ::argparsingtest::test1_punkargs_validate_ansistripped + @cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" + @opts -anyopts 0 -return -default string -type string -choices {string object} -help "return type" -frametype -default \uFFEF -type string -show_edge -default \uFFEF -type string @@ -333,7 +357,7 @@ namespace eval argparsingtest { -1 -default 1 -type boolean -validate_ansistripped true -2 -default 2 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true - *values + @values } $args] return [tcl::dict::get $argd opts] } diff --git a/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm b/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm index f0e34919..0d9cd0bc 100644 --- a/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm +++ b/src/vfs/_vfscommon.vfs/modules/overtype-1.6.5.tm @@ -402,7 +402,10 @@ tcl::namespace::eval overtype { set looplimit [expr {[tcl::string::length $overblock] + 10}] } - set scheme 3 + #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height + #lassign [blocksize $overblock] _w overblock_width _h overblock_height + + set scheme 4 switch -- $scheme { 0 { #one big chunk @@ -443,11 +446,18 @@ tcl::namespace::eval overtype { set inputchunks [lindex [list $lflines [unset lflines]] 0] } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks [string cat $ln \n] + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + } + } } - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height set replay_codes_underlay [tcl::dict::create 1 ""] @@ -495,7 +505,7 @@ tcl::namespace::eval overtype { } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderargs [list -experimental $opt_experimental\ + set renderopts [list -experimental $opt_experimental\ -cp437 $opt_cp437\ -info 1\ -crm_mode [tcl::dict::get $vtstate crm_mode]\ @@ -510,11 +520,8 @@ tcl::namespace::eval overtype { -expand_right $opt_expand_right\ -cursor_column $col\ -cursor_row $row\ - $undertext\ - $overtext\ ] - set LASTCALL $renderargs - set rinfo [renderline {*}$renderargs] + set rinfo [renderline {*}$renderopts $undertext $overtext] set instruction [tcl::dict::get $rinfo instruction] tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] @@ -1237,8 +1244,8 @@ tcl::namespace::eval overtype { append debugmsg "looplimit $looplimit reached\n" append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $LASTCALL -cursor_column]\n" + append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" + append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" tcl::dict::for {k v} $rinfo { append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n } diff --git a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm index 124ce3b7..4f13a121 100644 --- a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm @@ -112,10 +112,10 @@ proc TCL {args} { } punk::args::definition { -*id ">punk . poses" -*proc -name ">punk . poses" -help "Show or list the poses for the Punk mascot" --censored -default 1 -type boolean -help "Set true to include mild toilet humour poses" --return -default table -choices {list table} + @id -id ">punk . poses" + @cmd -name ">punk . poses" -help "Show or list the poses for the Punk mascot" + -censored -default 1 -type boolean -help "Set true to include mild toilet humour poses" + -return -default table -choices {list table} } >punk .. Method poses {args} { set argd [punk::args::get_by_id ">punk . poses" $args] @@ -344,7 +344,8 @@ v_ /|\/ / package require punk::args set standard_frame_types [textblock::frametypes] set argd [punk::args::get_dict [tstr -return string { - *proc -name "deck" -help "Punk Deck mascot" + @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 -boxlimits -default {hl vl tlc blc trc brc} -help "Limit the border box to listed elements." @@ -353,7 +354,7 @@ v_ /|\/ / } -title -default "PATTERN" -type string -subtitle -default "PUNK" -type string - *values -max 0 + @values -max 0 }] $args] set frame_type [dict get $argd opts -frame] set box_map [dict get $argd opts -boxmap] @@ -367,7 +368,7 @@ v_ /|\/ / #TODO - reuse textblock::gcross arguments - but reorder for error display >punk .. Method gcross {{size 1} args} { package require textblock - set argd [punk::args::get_by_id textblock::gcross [list {*}$args $size]] + set argd [punk::args::get_by_id ::textblock::gcross [list {*}$args $size]] textblock::gcross {*}$args $size } diff --git a/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm index 149f18fc..5affa204 100644 --- a/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm @@ -199,19 +199,19 @@ tcl::namespace::eval poshinfo { } punk::args::definition { - *id poshinfo::themes - *proc -name poshinfo::themes + @id -id ::poshinfo::themes + @cmd -name poshinfo::themes -format -default all -multiple 1 -choices {all yaml json}\ - -help "File format of posh theme - based on file extension" - -type -default all -multiple 1\ - -help "e.g omp" - -as -default "table" -choices {list showlist dict showdict table tableobject plaintext}\ - -help "return type of result" - *values -min 0 - globs -multiple 1 -default * -help "" + -help "File format of posh theme - based on file extension" + -type -default all -multiple 1\ + -help "e.g omp" + -as -default "table" -choices {list showlist dict showdict table tableobject plaintext}\ + -help "return type of result" + @values -min 0 + globs -multiple 1 -default * -help "" } proc themes {args} { - set argd [punk::args::get_by_id poshinfo::themes $args] + set argd [punk::args::get_by_id ::poshinfo::themes $args] set return_as [dict get $argd opts -as] set formats [dict get $argd opts -format] ;#multiple if {"yaml" in $formats} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 9440ae9c..1a9ab766 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -306,10 +306,11 @@ namespace eval punk { #get last command result that was run through the repl proc ::punk::get_runchunk {args} { set argd [punk::args::get_dict { - *opts + @id -id ::punk::get_runchunk + @opts -1 -optional 1 -type none -2 -optional 1 -type none - *values -min 0 -max 0 + @values -min 0 -max 0 } $args] #todo - make this command run without truncating previous runchunks set runchunks [tsv::array names repl runchunks-*] @@ -7152,8 +7153,8 @@ namespace eval punk { } punk::args::definition { - *id punk::inspect - *proc -name punk::inspect -help\ + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ "Function to display values - used pimarily in a punk pipeline. The raw value arguments (not options) are always returned to pass forward in the pipeline. @@ -7227,9 +7228,9 @@ namespace eval punk { Does not affect return value." -- -type none -help\ "End of options marker. - It is advisable to use this, as data in a pipeline may often being with -" + It is advisable to use this, as data in a pipeline may often begin with -" - *values -min 0 -max -1 + @values -min 0 -max -1 arg -type string -optional 1 -multiple 1 -help\ "value to display" } @@ -7261,7 +7262,7 @@ namespace eval punk { foreach {k v} $flags { if {$k ni [dict keys $defaults]} { #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" - punk::args::get_by_id punk::inspect $args + punk::args::get_by_id ::punk::inspect $args } } set opts [dict merge $defaults $flags] 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 452092e7..a3f9c0b5 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 @@ -134,27 +134,27 @@ tcl::namespace::eval punk::ansi::class { } lappend ::punk::ansi::class::PUNKARGS [list { - *id "punk::ansi::class::class_ansi render_to_input_line" - *proc -name "punk::ansi::class::class_ansi render_to_input_line" -help\ + @id -id "::punk::ansi::class::class_ansi render_to_input_line" + @cmd -name "punk::ansi::class::class_ansi render_to_input_line" -help\ "render string from line 0 to line (experimental/debug)" -dimensions -type string -help\ "WxH where W is integer width >= 1 and H is integer heigth >= 1" -minus -type integer -help\ "number of chars to exclude from end" - *values -min 1 -max 1 + @values -min 1 -max 1 line -type indexexpression }] method render_to_input_line {args} { if {[llength $args] < 1} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } set opts [tcl::dict::create\ -dimensions 80x24\ @@ -167,7 +167,7 @@ tcl::namespace::eval punk::ansi::class { } default { puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::get_by_id "punk::ansi::class::class_ansi render_to_input_line" $args + punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args } } } @@ -588,20 +588,20 @@ tcl::namespace::eval punk::ansi { } lappend PUNKARGS [list -dynamic 1 { - *id punk::ansi::example - *proc -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console + @id -id ::punk::ansi::example + @cmd -name punk::ansi::example -help "Display .ans image files in a grid that will fit in console " -colwidth -default 82 -help "Width of each column - default of 82 will fit a standard 80wide ansi image (when framed) You can specify a narrower width to truncate images on the right side" -folder -default "${[punk::ansi::Get_ansifolder]}" -help "Base folder for files if relative paths are used. Defaults to /src/testansi - where projectbase is determined from current directory. " - *values -min 0 -max -1 + @values -min 0 -max -1 files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help "List of filenames - leave empty to display 4 defaults" } ""] proc example {args} { - set argd [punk::args::get_by_id punk::ansi::example $args] + set argd [punk::args::get_by_id ::punk::ansi::example $args] set colwidth [dict get $argd opts -colwidth] set ansifolder [file normalize [dict get $argd opts -folder]] set fnames [dict get $argd values files] @@ -2355,21 +2355,21 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #sgr_cache clear called by punk::console::ansi when set to off #punk::args depends on punk::ansi - REVIEW + lappend PUNKARGS [list { + @id -id ::punk::ansi::sgr_cache + @cmd -name punk::ansi::sgr_cache -help\ + "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) + " + -action -default "" -choices "clear" -help\ + "-action clear will unset the keys in the punk::ansi::sgr_cache dict + This is called automatically when setting 'colour false' in the console" + + -pretty -default 1 -type boolean -help\ + "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" + @values -min 0 -max 0 + }] proc sgr_cache {args} { - set argdef { - *id punk::ansi::sgr_cache - *proc -name punk::ansi::sgr_cache -help\ - "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) - " - -action -default "" -choices "clear" -help\ - "-action clear will unset the keys in the punk::ansi::sgr_cache dict - This is called automatically when setting 'colour false' in the console" - - -pretty -default 1 -type boolean -help\ - "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" - *values -min 0 -max 0 - } - set argd [punk::args::get_dict $argdef $args] + set argd [punk::args::get_by_id ::punk::ansi::sgr_cache $args] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] @@ -2412,34 +2412,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return [join $lines \n] } - lappend PUNKARGS [list { - *id punk::ansi::a+ - *proc -name "punk::ansi::a+" -help\ - "Returns an ANSI sgr escape sequence based on the list of supplied codes. - Unlike punk::ansi::a - it is not prefixed with an ANSI reset. - " - *values -min 0 -max -1 - } [string map [list [dict keys $SGR_map]] { - code -type string -optional 1 -multiple 1 -choices {} -choiceprefix 0 -choicerestricted 0 -help\ - "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. - A leading capital letter indicates a codename applies to the background colour. - Other accepted codes are: - term- Term- foreground/background where int is 0-255 terminal color - term- Term- foreground/background - rgb--- Rgb--- foreground/background where are the - 0-255 int values for red, green and blue. - rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 - web- Web- - - The acceptable values for and can be queried using - punk::ansi::a? term - and - punk::ansi::a? web - - Example to set foreground red and background cyan followed by a reset: - set str \"[a+ red Cyan]sample text[a]\" - " - }]] + #PUNKARGS doc performed below, after we create the proc proc a+ {args} { #*** !doctools #[call [fun a+] [opt {ansicode...}]] @@ -2907,6 +2880,41 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $result } + set SGR_samples [dict create] + foreach k [dict keys $SGR_map] { + dict set SGR_samples $k "[punk::ansi::a+ $k]sample\x1b\[m" + } + lappend PUNKARGS [list { + @id -id ::punk::ansi::a+ + @cmd -name "punk::ansi::a+" -help\ + "Returns an ANSI sgr escape sequence based on the list of supplied codes. + Unlike punk::ansi::a - it is not prefixed with an ANSI reset. + " + @values -min 0 -max -1 + } [string map [list [dict keys $SGR_map] $SGR_samples] { + code -type string -optional 1 -multiple 1 -choices {}\ + -choicelabels {}\ + -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ + "SGR code from the list below, or an integer corresponding to the code e.g 31 = red. + A leading capital letter indicates a codename applies to the background colour. + Other accepted codes are: + term- Term- foreground/background where int is 0-255 terminal color + term- Term- foreground/background + rgb--- Rgb--- foreground/background where are the + 0-255 int values for red, green and blue. + rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 + web- Web- + + The acceptable values for and can be queried using + punk::ansi::a? term + and + punk::ansi::a? web + + Example to set foreground red and background cyan followed by a reset: + set str \"[a+ red Cyan]sample text[a]\" + " + }]] + proc a {args} { #*** !doctools #[call [fun a] [opt {ansicode...}]] @@ -4281,6 +4289,7 @@ tcl::namespace::eval punk::ansi { } 4 { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines + #e.g hyper on windows if {[llength $paramsplit] == 1} { tcl::dict::set codestate underline 4 } else { @@ -4634,6 +4643,8 @@ tcl::namespace::eval punk::ansi::ta { #[list_begin definitions] tcl::namespace::path ::punk::ansi + variable PUNKARGS + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position @@ -4706,15 +4717,31 @@ tcl::namespace::eval punk::ansi::ta { #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect + lappend PUNKARGS [list -dynamic 0 { + @id -id ::punk::ansi::ta::detect + @cmd -name punk::ansi::ta::detect -help\ + "Return a boolean indicating whether Ansi codes were detected in text. + Important caveat: + When text is a tcl list made from splitting (or lappending) some ansi string + - individual elements may be braced or have certain chars escaped. + (one example is if a list element contains an unbalanced brace) + This can cause square brackets that form part of the ansi to be backslash escaped + - and the function can fail to match it as an Ansi code. + " + @values -min 1 + text -type string + } ] + + #*** !doctools + #[call [fun detect] [arg text]] + #[para]Return a boolean indicating whether Ansi codes were detected in text + #[para]Important caveat: + #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) + #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match + #detect any ansi escapes #review - only detect 'complete' codes - or just use the opening escapes for performance? proc detect {text} [string map [list [list $re_ansi_detect]] { - #*** !doctools - #[call [fun detect] [arg text]] - #[para]Return a boolean indicating whether Ansi codes were detected in text - #[para]Important caveat: - #[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace) - #[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match regexp $text }] @@ -7405,7 +7432,7 @@ if {![info exists ::punk::args::register::NAMESPACES]} { set NAMESPACES [list] } } -lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class +lappend ::punk::args::register::NAMESPACES ::punk::ansi ::punk::ansi::class ::punk::ansi::ta # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm index 5a589fe3..2c9c77fa 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm @@ -50,14 +50,14 @@ #[example { # proc dofilestuff {args} { # lassign [dict values [punk::args::get_dict { -# *proc -help "do some stuff with files e.g dofilestuff " -# *opts -type string +# @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 +# @values -min 1 -max -1 # } $args]] leaders opts values # # puts "translation is [dict get $opts -translation]" @@ -67,8 +67,8 @@ # } #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for *values -#[para]valid * lines being with *proc *leaders *opts *values +#[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: @@ -81,7 +81,7 @@ # -directory -default "" # -translation -default binary # -nocomplain -type none -# *values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 # } $args]] leaders opts values @@ -89,7 +89,7 @@ # 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]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 @@ -279,11 +279,140 @@ tcl::namespace::eval punk::args { #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 - lappend PUNKARGS [list { - *id punk::args::definition - *proc -name punk::args::definition -help\ + 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::definition + #todo @preamble -help "move large block outside of table?" + @cmd -name punk::args::definition -help\ "Accepts a line-based definition of command arguments. - The definition should usually contain a line of the form: *id someid + This can be used purely for documentation or called within a function to parse a mix + of leading values, switches/flags and trailing values. + + The overhead is favourably comparable with other argument processors - but none are + as fast as minimal code with a switch statement. For toplevel commands where a few + 10s of microseconds is immaterial, the validation and automated error formatting in + a table can be well worthwhile. For inner procs requiring utmost speed, the call can + be made only on the unhappy path when basic processing determines a mismatch - or it + can be left entirely as documentation for interactive use with: i ... + + The definition should usually contain an initial line of the form: @id -id ::somecmd + + Blank lines are ignored at the top level, ie if they are not part of another structure. + Similarly - lines at the top level begginning with the # character are ignored. + All other toplevel lines must consist of a leading word followed by paired arguments. + The arguments can be spread over multiple lines and contain lines of near-arbitrary + text if they are properly braced or double quoted and Tcl escaping for inner quotes + or unbalanced braces is maintained. + The line continuation character + (\\ at the end of the line) can be used to continue the set of arguments for + a leading word. + Leading words beginning with the @ character are directives controlling argument + parsing and help display. + directives include: + %B%@id%N% ?opt val...? + options: -id + %B%@cmd%N% ?opt val...? + options -name -help + %B%@leaders%N% ?opt val...? + options -min -max + (used for leading args that come before switches/opts) + %B%@opts%N% ?opt val...? + options -any + %B%@values%N% ?opt val...? + options -min -max + (used for trailing args that come after switches/opts) + %B%@argdisplay%N% ?opt val...? + options -header (text for header row of table) + -body (text to replace entirety of autogenerated docs) + %B%@doc%N% ?opt val...? + options -name -url + + 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 + 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 value or option. + + 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 options: + + -type + defaults to string. If no other restrictions + are specified, choosing string does the least validation. + recognised types: + none + (used for switches only. Indicates this is + a 'solo' flag ie accepts no value) + int|integer + list + dict + double + bool|boolean + char + file + directory + string + ansistring + globstring + (any of the types accepted by 'string is') + + These all perform some validation checks + + and more.. (todo - document here) + + -optional + (defaults to true for flags/switches false otherwise) + -default + -multiple (for leaders & values defines whether + subsequent received values are stored agains the same + argument name - only applies to final leader or value) + (for options/flags this allows the opt-val pair or solo + flag to appear multiple times - no necessarily contiguously) + -choices {} + A list of allowable values for an argument. + The -default value doesn't have to be in the list. + If a -type is specified - it doesn't apply to choice members. + It will only be used for validation if the -choicerestricted + option is set to false. + -choicerestricted + Whether values not specified in -choices or -choicegroups are + allowed. Defaults to true. + -choiceprefix + This specifies whether unique prefixes are able to be used + instead of the complete string. This is calculated using + tcl::prefix::match - and will display in the autogenerated + usage output. Defaults to true. + -choiceprefixdenylist {} + These choices should match exactly a choice entry in one of + the settings -choices or -choicegroups. + These will still be used in prefix calculation - but the full + choice argument must be entered to select the choice. + -choicegroups {} + Generally this would be used instead of -choices to allow + usage display of choices grouped by some name. + See for example the output if 'i zlib' where choices of the + next subcommand are grouped by the names compression,channel, + streaming and checksumming. The -choices list is equivalent + to a -choicegroups dict entry where the key (groupname) is + the empty string. + -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\} @@ -292,20 +421,20 @@ tcl::namespace::eval punk::args { 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 not usually significant, perhaps on the order of a few hundred uS, - but -dynamic true might be less desirable if the command is used in inner - loops in more performance-sensitive code. + 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 + @values -min 1 -max -1 text -type string -multiple 1 -help\ "Block(s) of text representing the argument specification 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. - e.g + e.g the following definition passes 2 blocks as text arguments definition { - *id myns::myfunc - *proc -name myns::myfunc -help\\ + @id -id ::myns::myfunc + @cmd -name myns::myfunc -help\\ \"Description of command\" #The following option defines an option-value pair @@ -314,13 +443,13 @@ tcl::namespace::eval punk::args { -flag1 -default 0 -type none -help\\ \"Info about flag1\" - *values -min 1 -max -1 + @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 definition {args} { variable argdata_cache variable argdefcache_by_id @@ -482,6 +611,7 @@ tcl::namespace::eval punk::args { 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]} { @@ -522,9 +652,10 @@ tcl::namespace::eval punk::args { set linebuild "" } } - set proc_info {} + set cmd_info {} set id_info {} ;#e.g -children ?? set doc_info {} + set argdisplay_info {} ;#optional override of autogenerated 'Arg Type Default Multi Help' table set parser_info {} set leader_min "" #set leader_min 0 @@ -543,27 +674,50 @@ tcl::namespace::eval punk::args { "" - # {continue} } set linespecs [lassign $trimln argname] - if {$argname ne "*id" && [llength $linespecs] % 2} { - error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs'" + if {[llength $linespecs] % 2 != 0} { + error "punk::args::definition - bad optionspecs line for record '$argname' Remaining items on line must be in paired option-value format - received '$linespecs' id:$spec_id" } set firstchar [tcl::string::index $argname 0] set secondchar [tcl::string::index $argname 1] - if {$firstchar eq "*" && $secondchar ne "*"} { - set starspecs $linespecs + if {$firstchar eq "@" && $secondchar ne "@"} { + set at_specs $linespecs + switch -- [tcl::string::range $argname 1 end] { id { - #id line must have single entry - a unique id assigned by the user - an id will be allocated if no id line present or the value is "auto" - if {[llength $starspecs] == 0} { - error "punk::args::definition - *id line must have at least a single entry following *id." - } + #id An id will be allocated if no id line present or the -id value is "auto" if {$spec_id ne ""} { - #disallow duplicate *id line - error "punk::args::definition - *id already set. Existing value $spec_id" + #disallow duplicate @id line + error "punk::args::definition - @id already set. Existing value $spec_id" } - set spec_id [lindex $starspecs 0] - set id_info [lrange $starspecs 1 end] - if {[llength $id_info] %2} { - error "punk::args::definition - bad *id line. Remaining items on line after *id must be in paired option-value format - received '$linespecs'" + if {[dict exists $at_specs -id]} { + set spec_id [dict get $at_specs -id] + } else { + set spec_id auto + } + set id_info $at_specs + } + default { + #copy from an identified set of defaults (another argspec id) can be multiple + if {[dict exists $at_specs -id]} { + set copyfrom [get_def [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] + } + 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??? + } } } parser { @@ -596,27 +750,32 @@ tcl::namespace::eval punk::args { # 1 anykeys {0 info} # } #todo - set parser_info $starspecs + set parser_info $at_specs } - proc { + cmd { #allow arbitrary - review - set proc_info $starspecs + set cmd_info [dict merge $cmd_info $at_specs] } doc { - set doc_info $starspecs + 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 { if {$argspace eq "values"} { - error "punk::args::definition - *opts declaration must come before *values - received '$linespecs'" + error "punk::args::definition - @opts declaration must come before @values - received '$linespecs' id:$spec_id" } set argspace "options" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -any - -anyopts { set opt_any $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } @@ -662,26 +821,26 @@ tcl::namespace::eval punk::args { tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + set known { -any -anyopts -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *opts line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @opts line. Known keys: $known id:$spec_id" } } } } leaders { if {$argspace in [list options values]} { - error "punk::args::definition - *leaders declaration must come before all options and values" + error "punk::args::definition - @leaders declaration must come before all options and values id:$spec_id" } - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is 0. got $v id:$spec_id" } set leader_min $v #if {$leader_max == 0} { @@ -691,15 +850,16 @@ tcl::namespace::eval punk::args { -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *leaders line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @leaders line is -1 (indicating unlimited). got $v id:$spec_id" } set leader_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set leaderspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + #-choicegroups? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset leaderspec_defaults $k2 @@ -741,12 +901,12 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *leaders line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @leaders line. Known keys: $known @id:$spec_id" } } } @@ -754,27 +914,28 @@ tcl::namespace::eval punk::args { } values { set argspace "values" - foreach {k v} $starspecs { + foreach {k v} $at_specs { switch -- $k { -min - -minvalues { if {$v < 0} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is 0. got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is 0. got $v @id:$spec_id" } set val_min $v } -max - -maxvalues { if {$v < -1} { - error "punk::args::definition - minimum acceptable value for key '$k' in *opts line is -1 (indicating unlimited). got $v" + error "punk::args::definition - minimum acceptable value for key '$k' in @opts line is -1 (indicating unlimited). got $v @id:$spec_id" } set val_max $v } - -minsize - -maxsize - -range - -choices - -choicelabels - -choiceprefix - -choicerestricted - -nocase { + -minsize - -maxsize - -range - -choices - -choicegroups - -choicecolumns - -choicelabels - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } -nominsize - -nomaxsize - -norange - -nochoices - -nochoicelabels { + # -choicegoups ?? if {$v} { set k2 -[string range $k 3 end] ;#strip 'no' tcl::dict::unset valspec_defaults $k2 @@ -816,19 +977,19 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minsize -maxsize -range -choices -choicelabels -choiceprefix -choicerestricted -nocase\ + -minsize -maxsize -range -choices -choicegroups -choicecolumns -choicelabels -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::definition - unrecognised key '$k' in *values line. Known keys: $known" + error "punk::args::definition - unrecognised key '$k' in @values line. Known keys: $known @id:$spec_id" } } } } default { - error "punk::args::definition - unrecognised * line in '$ln'. Expected *proc *leaders *opts or *values - use **name if paramname needs to be *name" + error "punk::args::definition - unrecognised @ line in '$ln'. Expected @id @cmd @leaders @opts or @values - use @@name if paramname needs to be @name @id:$spec_id" } } continue @@ -836,15 +997,15 @@ tcl::namespace::eval punk::args { if {$argspace eq "leaders"} { set argspace "options" } elseif {$argspace eq "values"} { - error "punk::args::definition - invalid placement of line '$ln' - must come before *values" + error "punk::args::definition - invalid placement of line '$ln' - must come before @values @id:$spec_id" } set argspecs $linespecs tcl::dict::set argspecs -ARGTYPE option lappend opt_names $argname set is_opt 1 } else { - if {$firstchar eq "*"} { - #allow basic ** escaping for literal argname that begins with * + if {$firstchar eq "@"} { + #allow basic @@ escaping for literal argname that begins with @ set argname [tcl::string::range $argname 1 end] } set argspecs $linespecs @@ -898,7 +1059,7 @@ tcl::namespace::eval punk::args { lappend opt_solos $argname } else { #-solo only valid for flags - error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname'" + error "punk::args::definition - invalid -type 'none' for positional argument positional argument '$argname' @id:$spec_id" } } any - anything { @@ -916,18 +1077,18 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choiceprefix - -choicerestricted - -choicelabels - -minsize - -maxsize - -nocase - -optional - -multiple - + -default - -solo - -range - -choices - -choicegroups - -choicecolumns - -choiceprefix - -choiceprefixdenylist - -choicerestricted - -choicelabels - -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 + #inverses '-noxxx' (e.g -nochoices -nominsize etc) don't apply to specific args - only to @leaders @opts @values lines #review -solo 1 vs -type none ? conflicting values? tcl::dict::set spec_merged $spec $specval } -validationtransform { #string is dict only 8.7/9+ if {[llength $specval] % 2} { - error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary" + error "punk::args::definition - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$spec_id" } dict for {tk tv} $specval { switch -- $tk { @@ -935,18 +1096,18 @@ tcl::namespace::eval punk::args { } default { set known_transform_keys [list -function -type -minsize -maxsize -range] ;#-choices etc? - error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys" + error "punk::args::definition - invalid subkey $tk for key '$spec' in specifications for argument '$argname' must be one of: $known_transform_keys @id:$spec_id" } } } } default { - set known_argspecs [list -default -type -range -minsize -maxsize -choices -choiceprefix -choicerestricted\ + set known_argspecs [list -default -type -range -minsize -maxsize -choices -choicegroups -choicecolumns -choiceprefix -choiceprefixdenylist -choicerestricted\ -nocase -optional -multiple -validate_ansistripped -allow_ansi -strip_ansi -help\ -regexprepass -regexprefail -regexprefailmsg -validationtransform\ ] - error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" + error "punk::args::definition - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs @id:$spec_id" } } } @@ -983,6 +1144,11 @@ tcl::namespace::eval punk::args { } } + if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { + variable id_counter + set spec_id "autoid_[incr id_counter]" + } + # REVIEW #if {[llength $val_names] || $val_min > 0} { # #some values are specified @@ -995,23 +1161,19 @@ tcl::namespace::eval punk::args { #no values specified - we can allow last leader to be multiple foreach leadername [lrange $leader_names 0 end-1] { if {[tcl::dict::get $arg_info $leadername -multiple]} { - error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple" + error "bad key -multiple on argument spec for leader '$leadername'. Only the last leader argument specification can be marked -multiple @id:$spec_id" } } #} #confirm any valnames before last don't have -multiple key foreach valname [lrange $val_names 0 end-1] { if {[tcl::dict::get $arg_info $valname -multiple]} { - error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple" + error "bad key -multiple on argument spec for value '$valname'. Only the last value argument specification can be marked -multiple @id:$spec_id" } } - if {$spec_id eq "" || [tcl::string::tolower $spec_id] eq "auto"} { - variable id_counter - set spec_id "autoid_[incr id_counter]" - } - #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) + #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) set leader_checks_defaults [tcl::dict::remove $leaderspec_defaults -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize @@ -1043,8 +1205,9 @@ tcl::namespace::eval punk::args { val_max $val_max\ valspec_defaults $valspec_defaults\ val_checks_defaults $val_checks_defaults\ - proc_info $proc_info\ + cmd_info $cmd_info\ doc_info $doc_info\ + argdisplay_info $argdisplay_info\ id_info $id_info\ ] tcl::dict::set argdata_cache $cache_key $argdata_dict @@ -1081,7 +1244,6 @@ tcl::namespace::eval punk::args { return $result } } - return } proc get_spec_values {id {patternlist *}} { variable argdefcache_by_id @@ -1098,6 +1260,7 @@ tcl::namespace::eval punk::args { set def [dict remove $def -ARGTYPE] append result \n "$v $def" } + return $result } else { foreach pat $patternlist { set matches [dict keys $arg_info $pat] @@ -1111,19 +1274,28 @@ tcl::namespace::eval punk::args { return $result } } - return } #proc get_spec_leaders ?? #proc get_spec_opts ?? + proc get_def {id} { + if {[id_exists $id]} { + return [definition {*}[get_spec $id]] + } + } + proc is_dynamic {id} { + set spec [get_spec $id] + return [expr {[lindex $spec 0] eq "-dynamic" && [lindex $spec 1]} ] + } + variable aliases set aliases [dict create] lappend PUNKARGS [list { - *id punk::args::get_ids - *proc -name punk::args::get_ids -help\ + @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 + @values -min 0 -max 1 match -default * -help\ "exact id or glob pattern for ids" }] @@ -1182,23 +1354,37 @@ tcl::namespace::eval punk::args { set loaded_packages [list] proc update_definitions {} { + #needs to run quickly - especially when no package namespaces to be scanned for argdefs + #e.g - get's 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 variable loaded_packages upvar ::punk::args::register::NAMESPACES pkgs if {[llength $loaded_packages] == [llength $pkgs]} { #the only valid mechanism to add to 'loaded_packages' is with this function - so if lengths are equal, nothing to do. return {} } + # -- --- --- --- --- --- + set unloaded [punklib_ldiff $pkgs $loaded_packages] set newloaded [list] foreach pkgns $unloaded { + #puts -nonewline stderr . ;#debugging - see actual loads if {![catch { if {[info exists ${pkgns}::PUNKARGS]} { foreach deflist [set ${pkgns}::PUNKARGS] { namespace eval $pkgns [list punk::args::definition {*}$deflist] } } + if {[info exists ${pkgns}::PUNKARGS_aliases]} { + foreach adef [set ${pkgns}::PUNKARGS_aliases] { + punk::args::set_alias {*}$adef + } + } } errMsg]} { - lappend loaded_pkgs $pkgns + lappend loaded_packages $pkgns lappend newloaded $pkgns } else { puts stderr "punk::args::update_definitions error - failed to load PUNKARGS definitions for $pkgns\nerr:$errMsg" @@ -1273,7 +1459,8 @@ tcl::namespace::eval punk::args { set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error dict for {k v} $args { - switch -- $k { + set fullk [tcl::prefix::match -error "" {-badarg -aserror -return} $k] + switch -- $fullk { -badarg { set badarg $v } @@ -1285,7 +1472,7 @@ tcl::namespace::eval punk::args { set as_error $v } -return { - if {$v ni {string table tableobject}} { + 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" } @@ -1293,7 +1480,7 @@ tcl::namespace::eval punk::args { } default { set arg_error_isrunning 0 - error "arg_error invalid option $k. Known_options: -badarg -return" + error "arg_error invalid option $k. Known_options: -badarg -return -aserror" } } } @@ -1328,14 +1515,22 @@ tcl::namespace::eval punk::args { append errmsg \n } } - set procname [Dict_getdef $spec_dict proc_info -name ""] - set prochelp [Dict_getdef $spec_dict proc_info -help ""] + set procname [Dict_getdef $spec_dict cmd_info -name ""] + set prochelp [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 ""] + set blank_header_col [list] if {$procname ne ""} { lappend blank_header_col "" set procname_display [a+ brightwhite]$procname[a] @@ -1344,7 +1539,8 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { lappend blank_header_col "" - set prochelp_display [a+ brightwhite]$prochelp[a] + #set prochelp_display [a+ brightwhite]$prochelp[a] + set prochelp_display [textblock::ansibase_lines $prochelp [a+ white]] } else { set prochelp_display "" } @@ -1354,18 +1550,32 @@ tcl::namespace::eval punk::args { } else { set docurl_display "" } + if {$argdisplay_header ne ""} { + lappend blank_header_col "" + } if {$use_table} { set t [textblock::class::table new [a+ brightyellow]Usage[a]] $t add_column -headers $blank_header_col -minwidth 3 $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $t add_column -headers $blank_header_col - $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 {$procname ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list PROC/METHOD: $procname_display] + $t configure_header $h -colspans $arg_colspans -values [list PROC/METHOD: $procname_display] } else { lappend errlines "PROC/METHOD: $procname_display" } @@ -1373,7 +1583,7 @@ tcl::namespace::eval punk::args { } if {$prochelp ne ""} { if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list Description: $prochelp_display] + $t configure_header $h -colspans $arg_colspans -values [list Description: $prochelp_display] } else { lappend errlines "Description: $prochelp_display" } @@ -1384,225 +1594,352 @@ tcl::namespace::eval punk::args { set docurl [punk::ansi::hyperlink $docurl] } if {$use_table} { - $t configure_header $h -colspans {1 4 0 0 0} -values [list $docname $docurl_display] + $t configure_header $h -colspans $arg_colspans -values [list $docname $docurl_display] } else { lappend errlines "$docname $docurl_display" } incr h } if {$use_table} { - $t configure_header $h -values {Arg Type Default Multi Help} + 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-- " } - - set RST [a] - #set A_DEFAULT [a+ brightwhite Brightgreen] - set A_DEFAULT "" - set A_BADARG [a+ brightred] - set greencheck [a+ brightgreen]\u2713[a] ;#green tick - set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX [a+ green] ;#use a+ so colour off can apply - if {$A_PREFIX eq ""} { - set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + 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_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] - $trie destroy - foreach c [dict get $spec_dict opt_names] { - set id [dict get $idents $c] - #REVIEW - if {$id eq $c} { - set prefix $c - set tail "" - } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] - } - lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail - #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] - lappend opt_names $c - } + + set RST [a] + #set A_DEFAULT [a+ brightwhite Brightgreen] + set A_DEFAULT "" + set A_BADARG [a+ brightred] + set greencheck [a+ brightgreen]\u2713[a] ;#green tick + set soloflag [a+ brightcyan]\u2690[a] ;#flag - may be replacement char in old dos prompt (?) + set A_PREFIX [a+ green] ;#use a+ so colour off can apply + if {$A_PREFIX eq ""} { + 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 opt_names [dict get $spec_dict opt_names] - set opt_names_display $opt_names - } - } - set leading_val_names [dict get $spec_dict leader_names] - set trailing_val_names [dict get $spec_dict val_names] - - #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { - # if {![string match -* $argname]} { - # lappend leading_val_names [lpop trailing_val_names 0] - # } else { - # break - # } - #} - #if {![llength $leading_val_names] && ![llength $opt_names]} { - # #all vals were actually trailing - no opts - # set trailing_val_names $leading_val_names - # set leading_val_names {} - #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names - - #display options first then values - foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { - lassign $argumentset argnames_display argnames - - foreach argshow $argnames_display arg $argnames { - set arginfo [dict get $spec_dict arg_info $arg] - if {[dict exists $arginfo -default]} { - set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" + set A_PREFIXEND $RST + } + + set opt_names [list] + set opt_names_display [list] + if {[llength [dict get $spec_dict opt_names]]} { + if {![catch {package require punk::trie}]} { + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + #todo - check opt_prefixdeny + + $trie destroy + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + #REVIEW + if {$id eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $id] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail + #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] + lappend opt_names $c + } } else { - set default "" + set opt_names [dict get $spec_dict opt_names] + set opt_names_display $opt_names } - set help [Dict_getdef $arginfo -help ""] - if {[dict exists $arginfo -choices]} { - if {$help ne ""} {append help \n} - if {[dict get $arginfo -nocase]} { - set casemsg " (case insensitive)" + } + set leading_val_names [dict get $spec_dict leader_names] + set trailing_val_names [dict get $spec_dict val_names] + + #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { + # if {![string match -* $argname]} { + # lappend leading_val_names [lpop trailing_val_names 0] + # } else { + # break + # } + #} + #if {![llength $leading_val_names] && ![llength $opt_names]} { + # #all vals were actually trailing - no opts + # set trailing_val_names $leading_val_names + # set leading_val_names {} + #} + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names + + #display options first then values + foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { + lassign $argumentset argnames_display argnames + + foreach argshow $argnames_display arg $argnames { + set arginfo [dict get $spec_dict arg_info $arg] + if {[dict exists $arginfo -default]} { + set default "'$A_DEFAULT[dict get $arginfo -default]$RST'" } else { - set casemsg " (case sensitive)" + set default "" } - if {[dict get $arginfo -choiceprefix]} { - set prefixmsg " (choice prefix allowed)" + set help [Dict_getdef $arginfo -help ""] + set allchoices_originalcase [list] + set choices [Dict_getdef $arginfo -choices {}] + set choicegroups [Dict_getdef $arginfo -choicegroups {}] + set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] + set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] + if {[dict exists $choicegroups ""]} { + dict lappend choicegroups "" {*}$choices } else { - set prefixmsg "" + set choicegroups [dict merge [dict create "" $choices] $choicegroups] } - set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] - set formattedchoices [list] - append help " Choices$prefixmsg$casemsg" - if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + dict for {groupname clist} $choicegroups { + lappend allchoices_originalcase {*}$clist + } + set has_choices [expr {[dict exists $arginfo -choices] || [dict exists $arginfo -choicegroups]}] + + if {$has_choices} { + if {$help ne ""} {append help \n} + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + set allchoices_test [string tolower $allchoices_originalcase] + } else { + set casemsg " (case sensitive)" + set allchoices_test $allchoices_originalcase + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + set choicelabeldict [Dict_getdef $arginfo -choicelabels {}] + set formattedchoices [dict create] ;#use dict rather than array to preserve order + append help " Choices$prefixmsg$casemsg" + if {![dict get $arginfo -choiceprefix] || [catch {package require punk::trie}]} { + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } } - lappend formattedchoices $cdisplay + } else { + set formattedchoices $choicegroups + #set formattedchoices [dict get $arginfo -choices] } } else { - set formattedchoices [dict get $arginfo -choices] - } - } else { - if {[catch { - set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] - set idents [dict get [$trie shortest_idents ""] scanned] - $trie destroy - foreach c [dict get $arginfo -choices] { - set id [dict get $idents $c] - if {$id eq $c} { - set prefix $c - set tail "" + if {[catch { + set trie [punk::trie::trieclass new {*}$allchoices_test] + set idents [dict get [$trie shortest_idents ""] scanned] + if {[dict get $arginfo -nocase]} { + #idents were calculated on lcase - remap keys in idents to original casing + set actual_idents $idents + foreach ch $allchoices_originalcase { + if {![dict exists $idents $ch]} { + #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting + #The actual testing is done in get_dict + dict set actual_idents $ch [dict get $idents [string tolower $ch]] + } + } + set idents $actual_idents + #puts "-----" + #puts "idents $idents" + } + + $trie destroy + dict for {groupname clist} $choicegroups { + foreach c $clist { + if {$c in $choiceprefixdenylist} { + set shortestid $c + } else { + set shortestid [dict get $idents $c] + } + if {$shortestid eq $c} { + set prefix $c + set tail "" + } else { + set idlen [string length $shortestid] + set prefix [string range $c 0 $idlen-1] + set tail [string range $c $idlen end] + } + set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } + } errM]} { + #this failure can happen if -nocase is true and there are ambiguous entries + #e.g -nocase 1 -choices {x X} + puts stderr "prefix marking failed\n$errM" + #append help "\n " [join [dict get $arginfo -choices] "\n "] + if {[dict size $choicelabeldict]} { + dict for {groupname clist} $choicegroups { + foreach c $clist { + set cdisplay $c + if {[dict exists $choicelabeldict $c]} { + append cdisplay \n [dict get $choicelabeldict $c] + } + dict lappend formattedchoices $groupname $cdisplay + } + } } else { - set idlen [string length $id] - set prefix [string range $c 0 $idlen-1] - set tail [string range $c $idlen end] + set formattedchoices $choicegroups } - set cdisplay "$A_PREFIX[ansistring VIEW $prefix]$A_PREFIXEND[ansistring VIEW $tail]" - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + + } + } + 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 [a+ cyan]$groupname + #append help \n[textblock::join -- " " [$choicetableobj print]] + } else { + if {$groupname ne ""} { + #bold as well as brightcolour in case colour off. + append help \n \n "[a+ brightyellow bold]Group: $groupname[a]" + } else { + append help \n + } + append help \n [join $formatted \n] } - lappend formattedchoices $cdisplay - } - } errM]} { - puts stderr "prefix marking failed\n$errM" - #append help "\n " [join [dict get $arginfo -choices] "\n "] - if {[dict size $choicelabeldict]} { - foreach c [dict get $arginfo -choices] { - set cdisplay $c - if {[dict exists $choicelabeldict $c]} { - append cdisplay \n [dict get $choicelabeldict $c] + } 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 "" " [a+ red](no choices defined for main group)[a]" + } else { + dict set choicetable_footers $groupname " [a+ red](no choices defined for group $groupname)[a]" + } + } else { + if {$groupname eq ""} { + append help \n " " [a+ red](no choices defined)[a] + } else { + append help \n " " [a+ red](no choices defined for group $groupname)[a] } - lappend formattedchoices $cdisplay } + } + } + 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]} { + if {[dict get $arginfo -type] eq "string"} { + append help "\n (values not in defined choices are allowed)" } else { - set formattedchoices [dict get $arginfo -choices] + append help "\n (values not in defined choices are allowed but must by of type: [dict get $arginfo -type])" } - } } - set numcols 4 ;#todo - dynamic? - if {[llength $formattedchoices] < $numcols} { - #don't show blank cells if single line of results - set numcols [llength $formattedchoices] - } - if {$numcols > 0} { - if {$use_table} { - #risk of recursing - set choicetable [textblock::list_as_table -show_hseps 1 -show_edge 1 -columns $numcols $formattedchoices] - append help \n[textblock::join -- " " $choicetable] - } else { - append help \n [join $formattedchoices \n] - } + if {[Dict_getdef $arginfo -multiple 0]} { + set multiple $greencheck } 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. - append help \n " " [a+ red](no choices defined)[a] + set multiple "" } - - #review. use -type to restrict additional choices - may be different to values in the -choices - if {![dict get $arginfo -choicerestricted]} { - 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]} { + 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 {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck - } else { - set multiple "" - } - if {[Dict_getdef $arginfo -optional 0] == 1 || [dict exists $arginfo -default]} { - 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 + if {$use_table} { + $t add_row [list $argshow $typeshow $default $multiple $help] + if {$arg eq $badarg} { + $t configure_row [expr {[$t row_count]-1}] -ansibase $A_BADARG + } + } else { + #review - formatting will be all over the shop due to newlines in typesshow, help + set arghelp "[a+ bold]$argshow[a] TYPE:$typeshow DEFAULT:$default MULTI:$multiple\n" + foreach ln [split $help \n] { + append arghelp " $ln" \n + } + lappend errlines $arghelp } - } else { - #review - formatting will be all over the shop due to newlines in typesshow, help - lappend errlines "$argshow TYPE:$typeshow DEFAULT:$default MULTI:$multiple HELP:$help\n" } } - } + } ;#end is_custom_argdisplay if {$use_table} { $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] $t configure -maxwidth 80 ;#review - append errmsg [$t print] if {$returntype ne "tableobject"} { + append errmsg [$t print] #returntype of table means just the text of the table $t destroy } @@ -1640,19 +1977,26 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::usage - *proc -name punk::args::usage -help\ - "return usage information as a string - in table form." + @id -id ::punk::args::usage + @cmd -name punk::args::usage -help\ + "Return usage information for a command. + This will only work for commands where a punk::args definition exists + for the command and an id has been defined for it. + Many commands (such as ensembles and oo objects) may have argument + documentation generated dynamically and not have an id. + 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 this as necessary. + " -return -default table -choices {string table tableobject} - *values -min 0 -max 1 + @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::get_by_id ::punk::args::usage $args]] leaders opts values received set id [dict get $values id] set speclist [get_spec $id] if {[llength $speclist] == 0} { @@ -1662,9 +2006,9 @@ tcl::namespace::eval punk::args { } lappend PUNKARGS [list { - *id punk::args::get_by_id - *proc -name punk::args::get_by_id - *values -min 1 + @id -id ::punk::args::get_by_id + @cmd -name punk::args::get_by_id + @values -min 1 id arglist -default "" -type list -help\ "list containing arguments to be parsed as per the @@ -1703,8 +2047,8 @@ tcl::namespace::eval punk::args { #[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 *proc *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. + #[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. @@ -1713,12 +2057,12 @@ tcl::namespace::eval punk::args { #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { - # *opts + # @opts # -opt1 -default {} # -opt2 -default { # etc # } - # *values -multiple 1 + # @values -multiple 1 #} $args #if {[llength $args] == 0} { @@ -2014,7 +2358,7 @@ tcl::namespace::eval punk::args { } if {$opt_any} { set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to *opt -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set arg_info $a $optspec_defaults ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $opt_checks_defaults if {[tcl::dict::get $arg_info $a -type] ne "none"} { @@ -2023,7 +2367,6 @@ tcl::namespace::eval punk::args { } else { tcl::dict::set opts $a $newval } - lappend flagsreceived $a ;#adhoc flag as supplied if {[incr i] > $maxidx} { arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a } @@ -2041,11 +2384,12 @@ tcl::namespace::eval punk::args { } incr vals_remaining_possible -1 } + lappend flagsreceived $a ;#adhoc flag as supplied } else { if {[llength $opt_names]} { set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": must be one of: $opt_names" } else { - set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while *opts -any 0" + set errmsg "bad options for [Get_caller]. Unexpected option \"$a\": No options defined while @opts -any 0" } arg_error $errmsg $argspecs -badarg $fullopt } @@ -2096,6 +2440,7 @@ tcl::namespace::eval punk::args { } 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 arg_info $positionalidx $leaderspec_defaults @@ -2132,7 +2477,8 @@ tcl::namespace::eval punk::args { } else { if {$in_multiple ne ""} { tcl::dict::lappend values_dict $in_multiple $val - #name already seen + #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 arg_info $positionalidx $valspec_defaults @@ -2228,7 +2574,7 @@ tcl::namespace::eval punk::args { set defaultval [tcl::dict::get $thisarg -default] } set type [tcl::dict::get $thisarg -type] - set has_choices [tcl::dict::exists $thisarg -choices] + 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] @@ -2259,10 +2605,22 @@ tcl::namespace::eval punk::args { if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set choiceprefix [tcl::dict::get $thisarg -choiceprefix] - set choicerestricted [tcl::dict::get $thisarg -choicerestricted] - set nocase [tcl::dict::get $thisarg -nocase] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set choiceprefixdenylist [Dict_getdef $thisarg -choiceprefixdenylist {}] + set choicerestricted [tcl::dict::get $thisarg -choicerestricted] + 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 clist} $choicegroups { + lappend allchoices {*}$clist + } + } + #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 @@ -2275,7 +2633,7 @@ tcl::namespace::eval punk::args { } } set idx 0 ;# - #opts/values_dict $argname membmer has been populated with the actual entered choices - which might be prefixes + #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] @@ -2283,44 +2641,95 @@ tcl::namespace::eval punk::args { foreach e $vlist e_check $vlist_check { if {$nocase} { set casemsg " (case insensitive)" - set choices_test [tcl::string::tolower $choices] + 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 $e_check] } else { set casemsg " (case sensitive)" set v_test $e_check - set choices_test $choices + set choices_test $allchoices } set choice_in_list 0 set matches_default [expr {$has_default && $e eq $defaultval}] if {!$matches_default} { if {$choiceprefix} { - set chosen [tcl::prefix::match -error "" $choices_test $v_test] - if {$chosen ne ""} { + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice_exact_match 0 + if {$e_check in $allchoices} { + #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing + set chosen $e_check set choice_in_list 1 - #can we handle empty string as a choice? It should just work - REVIEW/test - #must use exact in case glob chars present e.g * ? [] (also ansi has square brackets) - set choice [lsearch -exact -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + set choice_exact_match 1 + } elseif {$v_test in $choices_test} { + set chosen $v_test + 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] $e_check] + if {$bestmatch eq ""} { + set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] + set choice_in_list [expr {$chosen ne ""}] + #we + } else { + set chosen $bestmatch + set choice_in_list 1 + } + } else { + set chosen [tcl::prefix::match -error "" [lsort -unique $allchoices] $e_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 "" + } + } + + if {$choice_in_list && !$choice_exact_match} { if {$is_multiple} { set existing [tcl::dict::get [set $dname] $argname] - lset existing $idx $choice + lset existing $idx $chosen tcl::dict::set $dname $argname $existing } else { - tcl::dict::set $dname $argname $choice + tcl::dict::set $dname $argname $chosen } } } 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 - } + #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 $e lappend vlist_check_validate $e_check } else { @@ -2330,13 +2739,13 @@ tcl::namespace::eval punk::args { } else { set prefixmsg "" } - arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs -badarg $argname } } 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 + #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 } @@ -2354,7 +2763,7 @@ tcl::namespace::eval punk::args { 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 + #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 @@ -2376,7 +2785,7 @@ tcl::namespace::eval punk::args { #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 + #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 { @@ -2690,6 +3099,10 @@ tcl::namespace::eval punk::args { } 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] } @@ -2702,12 +3115,12 @@ tcl::namespace::eval punk::args { lappend PUNKARGS [list { - *id punk::args::TEST - *opts -optional 0 + @id -id ::punk::args::TEST + @opts -optional 0 -o1 -default 111 -help "opt 1 mandatory" - *opts -optional 1 + @opts -optional 1 -o2 -default 222 -help "opt 2 optional" - *values -min 0 -max 1 + @values -min 0 -max 1 v -help\ "v1 optional" }] @@ -2762,16 +3175,18 @@ tcl::namespace::eval punk::args::lib { #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 punk::args::lib::tstr - *proc -name punk::args::lib::tstr -help\ + @id -id ::punk::args::lib::tstr + @cmd -name punk::args::lib::tstr -help\ "A rough equivalent of js template literals" -allowcommands -default 0 -type none -help\ - "if -allowcommands is present, placeholder can contain commands e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" + "if -allowcommands is present, placeholder can contain commands + e.g {\$\{plaintext0 [lindex $var 0] plaintext2\}}" -return -default list -choices {dict list string args}\ -choicelabels { dict\ "Return a dict with keys - 'template' and 'params'" + 'template', 'params' and + 'errors'" string\ "Return a single result being the string with @@ -2791,7 +3206,7 @@ tcl::namespace::eval punk::args::lib { args\ "Return a list where the first element is a list of template - plaintext secions as per the + plaintext sections as per the 'list' return mechanism, but the placeholder items are individual items in the returned list. @@ -2808,7 +3223,7 @@ tcl::namespace::eval punk::args::lib { contained variables in that case should be braced, 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 + @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 @@ -2820,7 +3235,7 @@ tcl::namespace::eval punk::args::lib { 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 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] @@ -2838,7 +3253,12 @@ tcl::namespace::eval punk::args::lib { dict set opts -allowcommands 1 } if {[llength $arglist] % 2 != 0} { - error "punk::args::lib::tstr expected option/value pairs prior to last argument" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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 -return -eval} $k] @@ -2847,12 +3267,20 @@ tcl::namespace::eval punk::args::lib { dict set opts $fullk $v } default { - error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" + if {[info commands ::punk::args::get_by_id] ne ""} { + punk::args::get_by_id ::punk::args::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_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] @@ -2871,6 +3299,7 @@ tcl::namespace::eval punk::args::lib { #set expressions [list] set params [list] set idx 0 + set errors [dict create] foreach {pt expression} $parts { lappend textchunks $pt incr idx ;#pt incr @@ -2881,17 +3310,32 @@ tcl::namespace::eval punk::args::lib { } #lappend expressions $expression if {$opt_eval} { - lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] + if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { + lappend params [string cat \$\{ $expression \}] + dict set errors [expr {[llength $params]-1}] $result + } else { + lappend params $result + } + #lappend params [uplevel 1 [list ::subst {*}$nocommands $expression]] } else { lappend params $expression } incr idx ;#expression incr } - switch -- $opt_return { - dict { - return [dict create template $textchunks params $params] + + 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 } + puts stderr "tstr errors:\n$einfo\n]" + } + + switch -- $opt_return { list { return [list $textchunks $params] } @@ -2906,20 +3350,18 @@ tcl::namespace::eval punk::args::lib { } return $out } - default { - } } } #test single placeholder tstr args where single placeholder must be an int proc tstr_test_one {args} { set argd [punk::args::get_dict { - *proc -name tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + @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 + @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" 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 3ae7850b..ec174d19 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,29 +141,219 @@ tcl::namespace::eval punk::args::tclcore { variable PUNKARGS + # -- --- --- --- --- + #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] + # -- --- --- --- --- + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- # library commands loaded via auto_index # -- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { - *id parray - *proc -name "Builtin: parray" -help\ + @id -id ::parray + @cmd -name "Builtin: parray" -help\ "Prints on standard output the names and values of all the elements in the array arrayName, or just the names that match pattern (using the matching rules of string_match) and their values if pattern is given. ArrayName must be an array accessible to the caller of parray. It may either be local or global. The result of this command is the empty string. (loaded via auto_index)" - *values -min 1 -max 2 + @values -min 1 -max 2 arrayName -type string -help\ "variable name of an array" pattern -type string -optional 1 -help\ "Match pattern possibly containing glob characters" - } "*doc -name Manpage: -url [manpage_tcl library]" ] + } "@doc -name Manpage: -url [manpage_tcl library]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + #categorise array subcommands based on currently known groupings. + #we do this dynamically because Tcl ensembles (even some core ones) can have subcommands added at runtime. + proc array_subcommands {} { + package require punk::ns + set subdict [punk::ns::ensemble_subcommands array] + set expected_searchcmds {startsearch anymore nextelement donesearch} + set searchcmds [list] + foreach sc $expected_searchcmds { + if {$sc in [dict keys $subdict]} { + lappend searchcmds $sc + } + } + set argdef "" + append argdef "subcommand -choicegroups \{" \n + append argdef " \"\" \{" \n + append argdef " [dict keys [dict remove $subdict {*}$searchcmds]]" \n + append argdef " \}" \n + append argdef " \"search\" \{" \n + append argdef " $searchcmds" \n + append argdef " \}" \n + append argdef " \} -choicecolumns 4 " \n + + return $argdef + } + + lappend PUNKARGS [list -dynamic 1 { + @id -id ::array + @cmd -name "Builtin: array" -help\ + "Manipulate array variables" + @values + ${[punk::args::tclcore::array_subcommands]} + + } "@doc -name Manpage: -url [manpage_tcl array]" ] + + #todo - make generic - take command and known_groups_dict + proc info_subcommands {} { + package require punk::ns + set subdict [punk::ns::ensemble_subcommands info] + set allsubs [dict keys $subdict] + dict set groups "system" {hostname library nameofexecutable patchlevel script sharedlibextension tclversion} + dict set groups "{proc introspection}" {args body default} + dict set groups "variables" {constant consts exists globals locals vars} + dict set groups "{oo object introspection}" {class object} + + set allgrouped [list] + dict for {g members} $groups { + lappend allgrouped {*}$members + } + set others [list] + foreach sc $allsubs { + if {$sc ni $allgrouped} { + lappend others $sc + } + } + + set argdef "" + append argdef "subcommand -choicegroups \{" \n + append argdef " \"\" \{$others\}" \n + dict for {g members} $groups { + append argdef " $g \{$members\}" \n + } + append argdef " \}" \n + + return $argdef + } + lappend PUNKARGS [list -dynamic 1 { + @id -id ::info + @cmd -name "Builtin: info" -help\ + "Information about the state of the Tcl interpreter" + @values + ${[punk::args::tclcore::info_subcommands]} + + } "@doc -name Manpage: -url [manpage_tcl array]" ] + + + + #An idiom for sharing common features - incomplete - todo work out what happens with (default)::id that has leaders,opts,values + #todo @cmd -help+ text (append to existing help that came from a default?) + lappend PUNKARGS [list { + @id -id "(default)::tcl::binary::*::base64" + @cmd -help\ + "The base64 binary encoding is commonly used in mail messages and XML documents, + and uses mostly upper and lower case letters and digits. It has the distinction + of being able to be rewrapped arbitrarily without losing information. + " + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::encode::base64" + @default -id (default)::tcl::binary::*::base64 + @cmd -name "binary encode base64" + -maxlen -type integer -help\ + "Indicates that the output should be split into lines of no more than length + characters. By default, lines are not split." + -wrapchar -type character -default \n -help\ + "Indicates that, when lines are split because of the -maxlen option, character + should be used to separate lines. By default, this is a newline character, \"\\n\"." + @values -min 1 -max 1 + data -type string + } ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::decode::base64" + @cmd -name "binary decode base64" + -strict -type none -help\ + "Instructs the decoder to throw an error if it encounters any characters that + are not strictly part of the encoding itself. Otherwise it ignores them. + RFC 2045 calls for base64 decoders to be non-strict." + @values -min 1 -max 1 + data -type string + } ] + + + lappend PUNKARGS [list { + @id -id "(default)::tcl::binary::*::hex" + @cmd -help\ + "The hex binary encoding converts each byte to a pair of hexadecimal digits + that represent the byte value as a hexadecimal integer. When encoding, lower + characters are used. When decoding, upper and lower characters are accepted." + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::encode::hex" + @default -id (default)::tcl::binary::*::hex + @cmd -name "binary encode hex" + @values -min 1 -max 1 + data -type string + } ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::decode::hex" + @default -id (default)::tcl::binary::*::hex + @cmd -name "binary encode hex" + -strict -type none -help\ + "Instructs the decoder to throw an error if it encounters whitespace + characters. Otherwise it ignores them." + @values -min 1 -max 1 + data -type string + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + + + lappend PUNKARGS [list { + @id -id "(default)::tcl::binary::*::uuencode" + @cmd -help\ + "The uuencode binary encoding used to be common for transfer of data between Unix + systems and on USENT, but is less common these days, having been largely + superseded by the base64 binary encoding. + Note that neither the encoder nor the decoder handle the header and footer of the + uuencode format." + } "@doc -name Manpage: -url [manpage_tcl binary]" ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::encode::uuencode" + @default -id (default)::tcl::binary::*::uuencode + #todo @cmd -help+ "Changing the options may produce files that other implementations of decoders cannot process" + @cmd -name "binary encode uuencode" + -maxlen -type integer -default 61 -range {5 85} -help\ + "Indicates the maximum number of characters to produce for each encoded line. + The valid range is 5 to 85. Line lengths outside that range cannot be + accommodated by the encoding format." + -wrapchar -type string -default \n -help\ + "Indicates the character(s) to use to mark the end of each encoded line. + Acceptable values are a sequence of zero or more character from the set + { \\x09 (TAB), \\x0B (VT), \\x0C (FF), \\x0D (CR) } followed by zero or + one newline \\x0A (LF). Any other values are rejected because they would + generate encoded text that could not be decoded. The default value is a + single newline. + " + @values -min 1 -max 1 + data -type string + } ] + lappend PUNKARGS [list { + @id -id "::tcl::binary::decode::uuencode" + @default -id (default)::tcl::binary::*::uuencode + @cmd -name "binary decode uuencode" + -strict -type none -help\ + "Instructs the decoder to throw an error if it encounters anything outside + of the standard encoding format. Without this option, the decoder tolerates + some deviations, mostly to forgive reflows of lines between the encoder and + decoder." + @values -min 1 -max 1 + data -type string + } ] + + lappend PUNKARGS [list { - *id time - *proc -name "Builtin: time" -help\ + @id -id ::time + @cmd -name "Builtin: time" -help\ "Calls the Tcl interpreter count times to evaluate script (or once if count is not specified). It will then return a string of the form @@ -172,46 +362,129 @@ tcl::namespace::eval punk::args::tclcore { iteration, in microseconds. Time is measured in elapsed time, not CPU time. (see also: timerate)" - *values -min 1 -max 2 + @values -min 1 -max 2 script -type script count -type integer -default 1 -optional 1 - } "*doc -name Manpage: -url [manpage_tcl time]" ] + } "@doc -name Manpage: -url [manpage_tcl time]" ] + + + lappend PUNKARGS [list { + @id -id ::tcl::chan::tell + @cmd -name "Builtin: tcl::chan::tell" -help\ + "Returns a number giving the current access position within the underlying + data stream for the channel named channel. This value returned is a byte + offset that can be passed to ${[a+ bold]}chan seek${[a normal]} in order + 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 + channel -help \ + "" + } "@doc -name Manpage: -url [manpage_tcl chan]" ] + + + 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::namespace::origin + @cmd -name "Builtin: tcl::namespace::origin" -help\ + "Returns the fully-qualified name of the original command to which the + imported command command refers. When a command is imported into a + namespace, a new command is created in that namespace that points to the + actual command in the exporting namespace. If a command is imported into + a sequence of namespaces a,b,...,n where each successive namespace just + imports the command from the previous namespace, this command returns + the fully-qualified name of the original command in the first namespace, a. + If command does not refer to an imported command, the command's own + fully-qualified name is returned + " + @values + command + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] lappend PUNKARGS [list { - *id tcl::namespace::path - *proc -name "Builtin: tcl::namespace::path" -help\ + @id -id ::tcl::namespace::path + @cmd -name "Builtin: tcl::namespace::path" -help\ "Returns the command resolution path of the current namespace. If namespaceList is specified as a list of named namespaces, the current namespace's command resolution path is set to those namespaces and returns the empty list. The default command resolution path is always empty. See the section NAME_RESOLUTION in the manpage for an explanation of the rules regarding name resolution." - *values -min 0 -max 1 + @values -min 0 -max 1 namespaceList -type list -optional 1 -help\ "List of existing namespaces" - } "*doc -name Manpage: -url [manpage_tcl namespace]" ] - + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] lappend PUNKARGS [list { - *id tcl::namespace::unknown - *proc -name "Builtin: tcl::namespace::unknown" -help\ + @id -id ::tcl::namespace::unknown + @cmd -name "Builtin: tcl::namespace::unknown" -help\ "Sets or returns the unknown command handler for the current namespace. The handler is invoked when a command called from within the namespace cannot be found in the current namespace, the namespace's path nor in the global namespace. When the handler is invoiked, the full invocation line will be appended to the script and the result evaluated in the context of the namespace. - The default handler for all namespaces is [a+ italic]::unknown[a]. + The default handler for all namespaces is ${[a+ italic]}::unknown${[a+ noitalic]}. If no argument is given, it returns the handler for the current namespace." - *values -min 0 -max 1 + @values -min 0 -max 1 script -type script -optional 1 -help\ "A well formed list representing a command name and optional arguments." - } "*doc -name Manpage: -url [manpage_tcl namespace]" ] + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] + lappend PUNKARGS [list { + @id -id ::tcl::namespace::which + @cmd -name "Builtin: tcl::namespace::which" -help\ + "Looks up name as either a command or variable and returns its fully-qulified name. + For example, if name does not exist in the current namespace but does exist in the + global namespace, this command returns a fully-qualified name in the global namespace. + If the command or variable does not exist, this command returns an empty string. If + the variable has been created but not defined, such as with the variable command or + through a trace on the variable, this command will return the fully-qualified name + of the variable. If no flag is given, name is treated as a command name. + See the section NAME RESOLUTION in the manpage for an explanation of the rules + regarding name resolution. + " + @opts + -command + -variable + @values -min 1 -max 1 + name + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] - set I [a+ italic] - set NI [a+ noitalic] lappend PUNKARGS [list { - *id tcl::process::status - *proc -name "Builtin: tcl::process::status" -help\ + @id -id ::tcl::process::status + @cmd -name "Builtin: tcl::process::status" -help\ "Returns a dictionary mapping subprocess PIDs to their respective status. if ${$I}pids${$NI} is specified as a list of PIDs then the command only returns the status of the matching subprocesses if they exist, and @@ -243,43 +516,43 @@ tcl::namespace::eval punk::args::tclcore { -- -type none -optional 1 -help\ "Marks the end of switches. The argument following this one will be treated as the first arg even if it starts with a -." - *values -min 0 -max 1 + @values -min 0 -max 1 pids -type list -optional 1 -help\ "A list of PIDs" - } "*doc -name Manpage: -url [manpage_tcl namespace]" ] + } "@doc -name Manpage: -url [manpage_tcl namespace]" ] lappend PUNKARGS [list { - *id lappend - *proc -name "builtin: lappend" -help\ + @id -id ::lappend + @cmd -name "builtin: lappend" -help\ "Append list elements onto a variable. " - *values -min 1 -max -1 + @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]"] + } "@doc -name Manpage: -url [manpage_tcl lappend]"] punk::args::definition { - *id ledit - *proc -name "builtin: ledit" -help\ + @id -id ::ledit + @cmd -name "builtin: ledit" -help\ "Replace elements of a list stored in variable " - *values -min 3 -max -1 + @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]" + } "@doc -name Manpage: -url [manpage_tcl ledit]" punk::args::definition { - *id lpop - *proc -name "builtin: lpop" -help\ + @id -id ::lpop + @cmd -name "builtin: lpop" -help\ "Get and remove an element in a list " - *values -min 1 -max -1 + @values -min 1 -max -1 varName -type string -help\ "Existing list variable name" index -type indexexpression -default end -optional 1 -multiple 1 -help\ @@ -292,11 +565,11 @@ tcl::namespace::eval punk::args::tclcore { 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]" + } "@doc -name Manpage: -url [manpage_tcl lpop]" punk::args::definition { - *id lrange - *proc -name "builtin: lrange" -help\ + @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 @@ -304,20 +577,20 @@ tcl::namespace::eval punk::args::tclcore { indices relative to the end of the list. e.g lrange {a b c} 0 end-1 " - *values -min 3 -max 3 + @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 lrange]" punk::args::definition { - *id tcl::string::cat + @id -id ::tcl::string::cat - *proc -name "builtin: tcl::string::cat" -help\ + @cmd -name "builtin: tcl::string::cat" -help\ "Concatente the given strings just like placing them directly next to each other and return the resulting compound string. If no strings are present, the result is an empty string. @@ -326,14 +599,14 @@ tcl::namespace::eval punk::args::tclcore { to return -level 0, and is more efficient than building a list of arguments and using join with an empty join string." - *values -min 0 -max -1 + @values -min 0 -max -1 string -type string -optional 1 -multiple 1 - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::compare + @id -id ::tcl::string::compare - *proc -name "builtin: tcl::string::compare" -help\ + @cmd -name "builtin: tcl::string::compare" -help\ "Perform a character-by-character comparison of strings string1 and string2. Returns -1, 0, or 1, dpending on whether string1 is lexicographically lessthan, equal to, or greater than string2" @@ -345,15 +618,15 @@ tcl::namespace::eval punk::args::tclcore { "If -length is specified, then only the first length characters are used in the comparison. If -length is negative, it is ignored." - *values -min 2 -max 2 + @values -min 2 -max 2 string1 -type string string2 -type string - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::equal + @id -id ::tcl::string::equal - *proc -name "builtin: tcl::string::equal" -help\ + @cmd -name "builtin: tcl::string::equal" -help\ "Perform a character-by-character comparison of strings string1 and string2. Returns 1 if string1 and string2 are identical, or 0 when not." @@ -364,30 +637,30 @@ tcl::namespace::eval punk::args::tclcore { "If -length is specified, then only the first length characters are used in the comparison. If -length is negative, it is ignored." - *values -min 2 -max 2 + @values -min 2 -max 2 string1 -type string string2 -type string - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::first - *proc -name "builtin: tcl::string::first" -help\ + @id -id ::tcl::string::first + @cmd -name "builtin: tcl::string::first" -help\ "Search haystackString for a sequence of characters that exactly match the characters in needleString. If found, return the index of the first character in the first such match within haystackString. If there is no match, then return -1. If startIndex is specified (in any of the forms described in STRING_INDICES), then the search is constrained to start with the character in haystackString specified by the index. " - *values -min 2 -max 3 + @values -min 2 -max 3 needleString -type string haystackString -type string startIndex -type indexexpression -optional 1 -help\ "integer or simple expression." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::insert - *proc -name "builtin: tcl::string::insert" -help\ + @id -id ::tcl::string::insert + @cmd -name "builtin: tcl::string::insert" -help\ "Returns a copy of string with insertString inserted at the index'th character. If index is start-relative, the first character inserted in the returned string will be at the specified index. @@ -398,43 +671,43 @@ tcl::namespace::eval punk::args::tclcore { If index is at or after the end of the string (e.g., index is end), insertString is appended to string." - *values -min 3 -max 3 + @values -min 3 -max 3 string -type string index -type indexexpression -help\ "The index may be specified as described in the STRING_INDICES section" insertString -type string - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::last - *proc -name "builtin: tcl::string::last" -help\ + @id -id ::tcl::string::last + @cmd -name "builtin: tcl::string::last" -help\ "Search haystackString for a sequence of characters that exactly match the characters in needleString. If found, return the index of the first character in the last such match within haystackString. If there is no match, then return -1. If lastIndex is specified (in any of the forms described in STRING_INDICES), then only the characters in haystackString at or before the specified lastIndex will be considered by the search " - *values -min 2 -max 3 + @values -min 2 -max 3 needleString -type string haystackString -type string lastIndex -type indexexpression -optional 1 -help\ "integer or simple expression." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::repeat - *proc -name "builtin: tcl::string::repeat" -help\ + @id -id ::tcl::string::repeat + @cmd -name "builtin: tcl::string::repeat" -help\ "Returns a string consisting of string concatenated with itself count times." - *values -min 2 -max 2 + @values -min 2 -max 2 string -type string count -type int -help\ "If count is 0, the empty string will be returned." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::replace - *proc -name "builtin: tcl::string::replace" -help\ + @id -id ::tcl::string::replace + @cmd -name "builtin: tcl::string::replace" -help\ "Removes a range of consecutive characters from string, starting with the character whose index is first and ending with the character whose index is last (Using the forms described in STRING_INDICES). An index of 0 refers to the first @@ -444,68 +717,68 @@ 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 3 string -type string first -type indexexpression last -type indexexpression newstring -type string -optional 1 -help\ "If newstring is specified, then it is placed in the removed character range." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::totitle - *proc -name "builtin: tcl::string::totitle" -help\ + @id -id ::tcl::string::totitle + @cmd -name "builtin: tcl::string::totitle" -help\ "Returns a value equal to string except that the first character in string is converted to it's Unicode title case variant (or upper case if there is no title case variant) and the rest of the string is converted to lower case." - *values -min 1 -max 1 + @values -min 1 -max 1 string -type string first -type indexexpression -optional 1 -help\ "If first is specified, it refers to the first char index in the string to start modifying." last -type indexexpression -optional 1 -help\ "If last is specified, it refers to the char index in the string to stop at (inclusive)." - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::wordend - *proc -name "builtin: tcl::string::wordend" -help\ + @id -id ::tcl::string::wordend + @cmd -name "builtin: tcl::string::wordend" -help\ "Returns the index of the character just after the last one in the word containing character charIndex of string. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) or underscore (Unicode connector punctuation) characters, or any single character other than these." - *values -min 2 -max 2 + @values -min 2 -max 2 string -type string charIndex -type indexexpression -help\ "integer or simple expresssion. e.g end e.g end-1 e.g M+N" - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition { - *id tcl::string::wordstart - *proc -name "builtin: tcl::string::wordstart" -help\ + @id -id ::tcl::string::wordstart + @cmd -name "builtin: tcl::string::wordstart" -help\ "Returns the index of the first character in the word containing character charIndex of string. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) or underscore (Unicode connector punctuation) characters, or any single character other than these. " - *values -min 2 -max 2 + @values -min 2 -max 2 string -type string charIndex -type indexexpression -help\ "integer or simple expresssion. e.g end e.g end-1 e.g M+N" - } "*doc -name Manpage: -url [manpage_tcl string]" + } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::definition [punk::lib::tstr -return string { - *id tcl::string::is - *proc -name "builtin: tcl::string::is" -help\ + @id -id ::tcl::string::is + @cmd -name "builtin: tcl::string::is" -help\ "Returns 1 if string is a valid member of the specified character class, otherwise returns 0. " - *leaders -min 1 -max 1 + @leaders -min 1 -max 1 class -type string\ -choices { alnum @@ -649,15 +922,56 @@ tcl::namespace::eval punk::args::tclcore { varname will always be set to 0, due to the varied nature of a valid boolean value" -strict -type none -help\ - "If -strictis specified, then an empty string returns 0, + "If -strict is specified, then an empty string returns 0, 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." - *values -min 1 -max 1 + @values -min 1 -max 1 string -type string -optional 0 - }] "*doc -name Manpage: -url [manpage_tcl string]" + }] "@doc -name Manpage: -url [manpage_tcl string]" + + punk::args::definition { + @id -id ::zlib + @cmd -name "builtin: ::zlib" -help\ + "zlib - compression and decompression operations + " + @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?" + } + + } "@doc -name Manpage: -url [manpage_tcl zlib]" + punk::args::definition { + @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]" + + #*** !doctools #[subsection {Namespace punk::args::tclcore}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm index be4a5cf1..e6257866 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm @@ -120,17 +120,17 @@ tcl::namespace::eval punk::blockletter { set logo_letter_colours [list Red Green Blue Purple Yellow] punk::args::definition [tstr -return string { - *id punk::blockletter::logo + @id -id ::punk::blockletter::logo -frametype -default {${$default_frametype}} -outlinecolour -default "web-white" -backgroundcolour -default {} -help "e.g Web-white This argument is the name as accepted by punk::ansi::a+" - *values -min 0 -max 0 + @values -min 0 -max 0 }] proc logo {args} { variable logo_letter_colours variable default_frametype - set argd [punk::args::get_by_id punk::blockletter::logo $args] + set argd [punk::args::get_by_id ::punk::blockletter::logo $args] set f [dict get $argd opts -frametype] set bd [dict get $argd opts -outlinecolour] set bgansi [dict get $argd opts -backgroundcolour] ;#we use ta::detect to see if already ansi and apply as necessary @@ -219,17 +219,17 @@ tcl::namespace::eval punk::blockletter { } punk::args::definition [tstr -return string { - *id punk::blockletter::text + @id -id ::punk::blockletter::text -bgcolour -default "Web-red" -bordercolour -default "web-white" -frametype -default {${$default_frametype}} - *values -min 1 -max 1 + @values -min 1 -max 1 str -help "Text to convert to blockletters Requires terminal font to support relevant block characters" " }] proc text {args} { - set argd [punk::args::get_by_id punk::blockletter::text $args] + set argd [punk::args::get_by_id ::punk::blockletter::text $args] set opts [dict get $argd opts] set str [dict get $argd values str] set str [string map {\r\n \n} $str] @@ -281,17 +281,17 @@ tcl::namespace::eval punk::blockletter::lib { punk::args::definition [tstr -return string { - *id punk::blockletter::block + @id -id ::punk::blockletter::block -height -default 2 -width -default 4 -frametype -default {${$::punk::blockletter::default_frametype}} -bgcolour -default "Web-red" -bordercolour -default "web-white" - *values -min 0 -max 0 + @values -min 0 -max 0 }] proc block {args} { upvar ::punk::blockletter::default_frametype ft - set argd [punk::args::get_by_id punk::blockletter::block $args] + set argd [punk::args::get_by_id ::punk::blockletter::block $args] set bg [dict get $argd opts -bgcolour] set bd [dict get $argd opts -bordercolour] set h [dict get $argd opts -height] 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 eacc6619..5624ec58 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 @@ -254,8 +254,9 @@ namespace eval punk::cap::handlers::templates { } method folders {args} { set argd [punk::args::get_dict { + @id -id "::punk::cap::handlers::templates::class::api folders" -startdir -default "" - *values -max 0 + @values -max 0 } $args] set opts [dict get $argd opts] @@ -471,10 +472,11 @@ namespace eval punk::cap::handlers::templates { } method get_itemdict_projectlayouts {args} { set argd [punk::args::get_dict { - *opts -anyopts 1 + @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 + @values -maxvalues -1 } $args] set opt_startdir [dict get $argd opts -startdir] @@ -648,14 +650,15 @@ namespace eval punk::cap::handlers::templates { #and a name determining command -command_get_item_name method _get_itemdict {args} { set argd [punk::args::get_dict { - *proc -name _get_itemdict - *opts -anyopts 0 + @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 + @values -maxvalues -1 globsearches -default * -multiple 1 } $args] set opts [dict get $argd opts] 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 493ea5aa..fbce0905 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm @@ -362,10 +362,10 @@ tcl::namespace::eval punk::config { proc configure {args} { set argdef { - *id punk::config::configure - *proc -name punk::config::configure -help\ + @id -id ::punk::config::configure + @cmd -name punk::config::configure -help\ "UNIMPLEMENTED" - *values -min 1 -max 1 + @values -min 1 -max 1 whichconfig -type string -choices {startup running stop} } set argd [punk::args::get_dict $argdef $args] @@ -388,15 +388,15 @@ tcl::namespace::eval punk::config { #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration proc copy {args} { set argdef { - *id punk::config::copy - *proc -name punk::config::copy -help\ + @id -id ::punk::config::copy + @cmd -name punk::config::copy -help\ "Copy a partial or full configuration from one config to another If a target config has additional settings, then the source config can be considered to be partial with regards to the target. " -type -default "" -choices {replace merge} -help\ "Defaults to merge when target is running-config Defaults to replace when source is running-config" - *values -min 2 -max 2 + @values -min 2 -max 2 fromconfig -help\ "running or startup or file name (not fully implemented)" toconfig -help\ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm index c27503c3..d2c08e8b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm @@ -875,7 +875,7 @@ namespace eval punk::console { } } - punk::args::set_alias punk::console::code_a+ punk::ansi::a+ + punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ proc code_a+ {args} { variable ansi_wanted if {$ansi_wanted <= 0} { @@ -1187,14 +1187,14 @@ namespace eval punk::console { #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::definition { - *id punk::console::cell_size + @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list - *values -min 0 -max 1 + @values -min 0 -max 1 newsize -default "" -help\ "character cell pixel dimensions WxH" } proc cell_size {args} { - set argd [punk::args::get_by_id punk::console::cell_size $args] + set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] set newsize [dict get $argd values newsize] 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 9f74d2d5..adb47eff 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 @@ -563,9 +563,10 @@ namespace eval punk::du { variable win_reparse_tags_by_int set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 iteminfo -help "iteminfo dict as set by 'twapi::find_file_next iteminfo'" } $args] set opts [dict get $argd opts] @@ -621,10 +622,11 @@ namespace eval punk::du { proc attributes_twapi {args} { set argd [punk::args::get_dict { + @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 + @values -min 1 -max 1 path -help "path to file or folder for which to retrieve attributes" } $args] set opts [dict get $argd opts] 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 04f3487b..6de20bff 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 @@ -1252,14 +1252,14 @@ namespace eval punk::fileline { #[list_begin definitions] punk::args::definition { - *id punk::fileline::get_textinfo - *proc -name punk::fileline::get_textinfo -help\ + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ "return: textinfo object instance" -file -default {} -type existingfile -translation -default iso8859-1 -encoding -default "\uFFFF" -includebom -default 0 - *values -min 0 -max 1 + @values -min 0 -max 1 } proc get_textinfo {args} { #*** !doctools @@ -1276,7 +1276,7 @@ namespace eval punk::fileline { #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. - lassign [dict values [punk::args::get_by_id punk::fileline::get_textinfo $args]] opts values + lassign [dict values [punk::args::get_by_id ::punk::fileline::get_textinfo $args]] opts values # -- --- --- --- set opt_file [dict get $opts -file] set opt_translation [dict get $opts -translation] 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 6fabbba7..353d1f65 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 @@ -1009,13 +1009,13 @@ namespace eval punk::lib { set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " } set argspec [string map [list %sep% $sep] { - *id punk::lib::pdict - *proc -name pdict -help\ + @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 + @opts -any 1 #default separator to provide similarity to tcl's parray function -separator -default "%sep%" @@ -1023,7 +1023,7 @@ namespace eval punk::lib { -substructure -default {} -channel -default stdout -help "existing channel - or 'none' to return as string" - *values -min 1 -max -1 + @values -min 1 -max -1 dictvar -type string -help "name of variable. Can be a dict, list or array" @@ -1095,14 +1095,16 @@ namespace eval punk::lib { package require textblock set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { - *id punk::lib::showdict - *proc -name punk::lib::showdict -help "display dictionary keys and values" + @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 - " + -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" @@ -1114,7 +1116,7 @@ namespace eval punk::lib { -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 + @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" }] $args] @@ -2816,7 +2818,7 @@ namespace eval punk::lib { #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 { -joinchar -default \n - *values -min 1 -max 1 + @values -min 1 -max 1 } $args]] leaders opts values puts "opts:$opts" puts "values:$values" @@ -2857,7 +2859,7 @@ namespace eval punk::lib { #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 { - *opts -any 1 + @opts -any 1 -block -default {} } $args]] leaderdict opts valuedict tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] 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 8d68b28a..6b1923b1 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 @@ -168,9 +168,10 @@ namespace eval punk::mix::commandset::doc { } proc validate {args} { set argd [punk::args::get_dict { + @id -id ::punk::mix::commandset::doc::validate -- -type none -optional 1 -help "end of options marker --" -individual -type boolean -default 1 - *values -min 0 -max -1 + @values -min 0 -max -1 patterns -default {*.man} -type any -multiple 1 } $args] set opt_individual [tcl::dict::get $argd opts -individual] 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 a31da91a..47c75d33 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 @@ -34,7 +34,8 @@ namespace eval punk::mix::commandset::layout { #per layout functions proc files {{layout ""}} { set argd [punk::args::get_dict { - *values -min 1 -max 1 + @id -id ::punk::mix::commandset::layout::files + @values -min 1 -max 1 layout -type string -minsize 1 } [list $layout]] @@ -88,7 +89,8 @@ namespace eval punk::mix::commandset::layout { proc _default {args} { punk::args::get_dict [subst { - *proc -name ::punk::mix::commandset::layout::collection::_default + @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 diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm index f5a5491e..f427f29f 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -27,20 +27,24 @@ namespace eval punk::mix::commandset::loadedlib { namespace export * #search automatically wrapped in * * - can contain inner * ? globs punk::args::definition { - *id punk::mix::commandset::loadedlib::search - *proc -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" + @id -id ::punk::mix::commandset::loadedlib::search + @cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" -return -type string -default table -choices {table tableobject list lines} -present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\ - "(unimplemented) Display only those that are 0:absent 1:present 2:both" - -highlight -type boolean -default 1 -help "Highlight which version is present with ansi underline and colour" + "(unimplemented) Display only those that are 0:absent 1:present 2:either" + -highlight -type boolean -default 1 -help\ + "Highlight which version is present with ansi underline and colour" -refresh -default 0 -type boolean -help "Re-scan the tm and library folders" searchstrings -default * -multiple 1 -help\ "Names to search for, may contain glob chars (* ?) e.g *lib* If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. - eg name -> *name*" + eg name -> *name* + To search for an exact name prefix it with = + e.g =name -> name + " } proc search {args} { - set argd [punk::args::get_by_id punk::mix::commandset::loadedlib::search $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::loadedlib::search $args] set searchstrings [dict get $argd values searchstrings] set opts [dict get $argd opts] set opt_return [dict get $opts -return] @@ -55,7 +59,7 @@ namespace eval punk::mix::commandset::loadedlib { set packages [package names] set matches [list] foreach search $searchstrings { - if {[regexp {[?*]} $search]} { + if {[regexp {[?*\[]} $search]} { #caller has specified specific glob pattern - use it #todo - respect supplied case only if uppers present? require another flag? lappend matches {*}[lsearch -all -inline -nocase $packages $search] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm index 44627536..2079eb8c 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm @@ -123,10 +123,11 @@ namespace eval punk::mix::commandset::module { #return all module templates with repeated ones suffixed with .2 .3 etc proc templates_dict {args} { set argspec { - *proc -name templates_dict -help "Templates from module and project paths" + @id -id ::punk::mix::commandset::module::templates_dict + @cmd -name templates_dict -help "Templates from module and project paths" -startdir -default "" -help "Project folder used in addition to module paths" -not -default "" -multiple 1 - *values + @values globsearches -default * -multiple 1 } set argd [punk::args::get_dict $argspec $args] @@ -141,8 +142,8 @@ namespace eval punk::mix::commandset::module { set moduletypes [punk::mix::cli::lib::module_types] punk::args::definition [subst { - *id punk::mix::commandset::module::new - *proc -name "punk::mix::commandset::module::new" -help\ + @id -id ::punk::mix::commandset::module::new + @cmd -name "punk::mix::commandset::module::new" -help\ "Create a new module file in the appropriate folder within src/modules. If the name given in the module argument is namespaced, the necessary subfolder(s) will be used or created." @@ -160,7 +161,7 @@ namespace eval punk::mix::commandset::module { If false (default) an error will be raised if there is a conflict." -quiet -default 0 -type boolean -help\ "Suppress information messages on stdout" - *values -min 1 -max 1 + @values -min 1 -max 1 module -type string -help\ "Name of module, possibly including a namespace and/or version number e.g mynamespace::mymodule-1.0" @@ -168,7 +169,7 @@ namespace eval punk::mix::commandset::module { proc new {args} { set year [clock format [clock seconds] -format %Y] # use \uFFFD because unicode replacement char should consistently render as 1 wide - set argd [punk::args::get_by_id punk::mix::commandset::module::new $args] + set argd [punk::args::get_by_id ::punk::mix::commandset::module::new $args] lassign [dict values $argd] leaders opts values received set module [dict get $values module] 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 65a9fb77..98f171c7 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 @@ -1262,15 +1262,15 @@ namespace eval punk::mix::commandset::scriptwrap { # [list_begin arguments] # [arg_def string args] name-value pairs -scriptpath # [list_end] - *id punk::mix::commandset::scriptwrap - *proc -name punk::mix::commandset::get_wrapper_folders + @id -id ::punk::mix::commandset::scriptwrap + @cmd -name punk::mix::commandset::get_wrapper_folders - *opts -anyopts 0 + @opts -anyopts 0 -scriptpath -default "" -type directory\ -help "" #todo -help folder within a punk.templates provided area??? - *values -minvalues 0 -maxvalues 0 + @values -minvalues 0 -maxvalues 0 } $args] # -- --- --- --- --- --- --- --- --- 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 159c6f37..3f5f3a71 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 @@ -636,13 +636,14 @@ tcl::namespace::eval punk::nav::fs { # c:/repo/jn/punk/../../blah #dirfiles assumes we don't have glob chars in the filenames or paths - dirfiles_dict can be called directly with explicit -tailglob in the rare case that assumption doesn't hold # dirfiles will test last segment (tail) of supplied searchspecs for fileness vs folderness (when no globchars present in tail) so that it can pass the appropriate flags downstream + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles + -stripbase -default 1 -type boolean + -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" + @values -min 0 -max -1 + } proc dirfiles {args} { - set argspecs { - -stripbase -default 1 -type boolean - -formatsizes -default 1 -type boolean -help "Format file size numbers for clarity" - *values -min 0 -max -1 - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] @@ -726,14 +727,14 @@ tcl::namespace::eval punk::nav::fs { # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied proc dirfiles_dict {args} { set argspecs { - *id punk::nav::fs::dirfiles_dict - *opts -any 0 + @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 + @values -min 0 -max -1 -type string } set argd [punk::args::get_dict $argspecs $args] lassign [dict values $argd] leaders opts vals @@ -991,16 +992,17 @@ tcl::namespace::eval punk::nav::fs { return [dict merge $listing $updated] } + punk::args::definition { + @id -id ::punk::nav::fs::dirfiles_dict_as_lines + -stripbase -default 0 -type boolean + -formatsizes -default 1 -type boolean + @values -min 1 -max -1 -type dict + } + #todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing? proc dirfiles_dict_as_lines {args} { package require overtype - - set argspecs { - -stripbase -default 0 -type boolean - -formatsizes -default 1 -type boolean - *values -min 1 -max -1 -type dict - } - set argd [punk::args::get_dict $argspecs $args] + set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles_dict_as_lines $args] lassign [dict values $argd] leaders opts vals set list_of_dicts [dict values $vals] 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 14b8f00d..f8a1e939 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 @@ -1608,7 +1608,7 @@ tcl::namespace::eval punk::ns { if {$word1 eq "punk::mix::base::_cli"} { #special case for punk deck - REVIEW #e.g punk::mix::base::_cli -extension ::punk::mix::cli - set fq [lindex $tgt end] + set fq [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options } else { #todo - alias may have prefilled some leading args - so usage report should reflect that??? #(currying) @@ -1618,7 +1618,8 @@ tcl::namespace::eval punk::ns { set fq [nsjoin $location $c] } if {$has_punkargs} { - set id [string trimleft $fq :] + #set id [string trimleft $fq :] + set id $fq if {[::punk::args::id_exists $id]} { lappend usageinfo $c } else { @@ -1892,110 +1893,188 @@ tcl::namespace::eval punk::ns { } } |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} = 0} { + if {[lsearch -exact $nscommands $querycommand] >= 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]] }]} { - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { #fully qualified command specified but doesn't exist - set origin $commandpath - set resolved $commandpath + set origin $querycommand + set resolved $querycommand } } else { - set thispath [uplevel 1 [list ::nsthis $commandpath]] - set targetns [nsprefix $thispath] - set name [nstail $thispath] - set targetparts [nsparts $targetns] - if {[lsearch $targetparts :*] >=0} { - #weird ns - set valid_ns [nsexists $targetns] + #relative comandpath + if {[string match (autodef)* $querycommand]} { + #pass through - should be found with id lookup + set origin $querycommand + set resolved $querycommand } 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 commandpath 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 + set thispath [uplevel 1 [list ::nsthis $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 + set numvals [expr {[llength $queryargs]+1}] + #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]] + + #set origin $querycommand + #set resolved $querycommand + } - } else { - #namespace doesn't seem to exist - but there still could be documentation for lazy loaded ns and command - set origin $commandpath - set resolved $commandpath - } - } - #set thiscmd [nsjoin $targetns $name] - #if {[info commands $thiscmd] eq ""} { - # set origin $thiscmd - # set resolved $thiscmd - #} else { - # set origin [nseval $targetns [list ::namespace origin $name]] - # set resolved [nseval $targetns [list ::namespace which $name]] - #} + } + } #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! - #considure using which_alias (wiki) + #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 fq [lindex $tgt end] + 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 fq $word1 + set targetword $word1 + 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]] } - set origin $fq + + + set origin $targetword #retest cmdtype on modified origin set cmdtype [punk::ns::cmdtype $origin] } else { @@ -2013,6 +2092,83 @@ tcl::namespace::eval punk::ns { } } + + set id $origin + if {[info commands ::punk::args::id_exists] ne ""} { + #cycle through longest first checking for id matching ::cmd ?subcmd..? + #REVIEW - this doesn't cater for prefix callable subcommands! + set argcopy $queryargs + while {[llength $argcopy]} { + if {[punk::args::id_exists [list $id {*}$argcopy]]} { + return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$argcopy]]] + } + lpop argcopy + } + + #didn't find any exact matches + #traverse from other direction taking prefixes into account + + if {[punk::args::id_exists $id]} { + #cycle forward through leading values + set def [punk::args::get_def $id] + if {[llength $queryargs]} { + set nextqueryargs [list] ;#build a list of prefix-resolved queryargs + set queryargs_untested $queryargs + foreach q $queryargs { + if {[llength [dict get $def leader_names]]} { + set subitems [dict get $def leader_names] + if {[llength $subitems]} { + set next [lindex $subitems 0] + set arginfo [dict get $def arg_info $next] + + 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 ""]} { + dict lappend choicegroups "" {*}$choices + } else { + set choicegroups [dict merge [dict create "" $choices] $choicegroups] + } + dict for {groupname clist} $choicegroups { + lappend allchoices {*}$clist + } + set resolved_q [tcl::prefix::match -error "" $allchoices $q] + if {$resolved_q eq ""} { + 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 numvals [expr {[llength $queryargs]+1}] + return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] + } + #check if subcommands so far have a custom args def + set currentid [list $querycommand {*}$nextqueryargs] + if {[punk::args::id_exists $currentid]} { + set def [punk::args::get_def $currentid + } else { + #We can get no further with custom defs + break + } + } + } else { + #review + break + } + } + } else { + return [uplevel 1 [list punk::args::usage {*}$opts $id]] + } + } + } + + if {[string match "(autodef)*" $origin]} { + #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) + set origin [string range $origin [string length (autodef)] end] + set resolved $origin + } + switch -- $cmdtype { object { #class is also an object @@ -2025,19 +2181,19 @@ tcl::namespace::eval punk::ns { #set class_methods [info class methods $class] #set object_methods [info object methods $origin] - if {[llength $commandargs]} { - set c1 [lindex $commandargs 0] + if {[llength $queryargs]} { + set c1 [lindex $queryargs 0] if {$c1 in $public_methods} { switch -- $c1 { new { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} new" - *proc -name "${$origin} new" -help\ + @id -id "(autodef)${$origin} new" + @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 { @@ -2054,17 +2210,17 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin new"] + return [punk::args::usage {*}$opts "(autodef)$origin new"] } create { set constructorinfo [info class constructor $origin] set arglist [lindex $constructorinfo 0] set argspec [punk::lib::tstr -return string { - *id "${$origin} create" - *proc -name "${$origin} create" -help\ + @id -id "(autodef)${$origin} create" + @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" }] @@ -2083,20 +2239,20 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin create"] + return [punk::args::usage {*}$opts "(autodef)$origin create"] } destroy { #review - generally no doc # but we may want notes about a specific destructor set argspec [punk::lib::tstr -return string { - *id "${$origin} destroy" - *proc -name "destroy" -help\ + @id -id "(audodef)${$origin} destroy" + @cmd -name "destroy" -help\ "delete object, calling destructor if any. destroy accepts no arguments." - *values -min 0 -max 0 + @values -min 0 -max 0 }] punk::args::definition $argspec - return [punk::args::usage {*}$opts "$origin destroy"] + return [punk::args::usage {*}$opts "(autodef)$origin destroy"] } default { #use info object call to resolve callchain @@ -2111,20 +2267,24 @@ tcl::namespace::eval punk::ns { lassign $impl generaltype mname location methodtype switch -- $generaltype { method - private { - + #objects being dynamic systems - we should always reinspect. + #Don't use the cached (autodef) def + #If there is a custom def override - use it (should really be -dynamic - but we don't check) if {$location eq "object"} { - set id "[string trimleft $origin :] $c1" ;# " " + set idcustom "$origin $c1" + #set id "[string trimleft $origin :] $c1" ;# " " if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info object definition $origin $c1] } else { - set id "[string trimleft $location :] $c1" ;# " " + #set id "[string trimleft $location :] $c1" ;# " " + set idcustom "$location $c1" if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] + if {[punk::args::id_exists $idcustom]} { + return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] } } set def [::info class definition $location $c1] @@ -2138,12 +2298,15 @@ tcl::namespace::eval punk::ns { } } if {$def ne ""} { + #assert - if we pre + set autoid "(autodef)$location $c1" set arglist [lindex $def 0] set argspec [punk::lib::tstr -return string { - *id "${$location} ${$c1}" - *proc -name "${$location} ${$c1}" -help\ - "arglist:${$arglist}" - *values + @id -id "${$autoid}" + @cmd -name "${$location} ${$c1}" -help\ + "(autogenerated) + arglist:${$arglist}" + @values }] set i 0 foreach a $arglist { @@ -2166,7 +2329,7 @@ tcl::namespace::eval punk::ns { incr i } punk::args::definition $argspec - return [punk::args::usage {*}$opts "$location $c1"] + return [punk::args::usage {*}$opts $autoid] } else { return "unable to resolve $origin method $c1" } @@ -2189,9 +2352,11 @@ tcl::namespace::eval punk::ns { switch -- $generaltype { method - private { if {$location eq "object"} { - set id "[string trimleft $origin :] $cmd" ;# " " + #set id "[string trimleft $origin :] $cmd" ;# " " + set id "$origin $cmd" } else { - set id "[string trimleft $location :] $cmd" ;# " " + #set id "[string trimleft $location :] $cmd" ;# " " + set id "$location $cmd" } if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} { @@ -2212,15 +2377,16 @@ tcl::namespace::eval punk::ns { set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review #puts stderr "--->$vline" + set idauto "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -name "Object: ${$origin}" -help\ - "Instance of class: ${$class}" - *values -min 1 + @id -id ${$idauto} + @cmd -name "Object: ${$origin}" -help\ + "Instance of class: ${$class} (info autogenerated)" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $idauto] } privateObject { return "Command is a privateObject - no info currently available" @@ -2287,11 +2453,11 @@ tcl::namespace::eval punk::ns { set subcommands [lsort [dict keys $subcommand_dict]] - if {[llength $commandargs]} { - set match [tcl::prefix::match $subcommands [lindex $commandargs 0]] + 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 $commandargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") + 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") } } @@ -2307,9 +2473,9 @@ tcl::namespace::eval punk::ns { 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] + lappend have_usageinfo {*}[dict get $nsinfo usageinfo] + lappend is_ensemble {*}[dict get $nsinfo ensembles] + lappend is_object {*}[dict get $nsinfo ooobjects] } set choicelabeldict [dict create] @@ -2324,14 +2490,17 @@ tcl::namespace::eval punk::ns { } set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] + set autoid "(autodef)$origin" set argspec [punk::lib::tstr -return string { - *id ${$origin} - *proc -help "ensemble: ${$origin}" - *values -min 1 + @id -id ${$autoid} + @cmd -help\ + "(autogenerated) + ensemble: ${$origin}" + @values -min 1 }] append argspec \n $vline punk::args::definition $argspec - return [punk::args::usage {*}$opts $origin] + return [punk::args::usage {*}$opts $autoid] } #check for tepam help @@ -2364,12 +2533,6 @@ tcl::namespace::eval punk::ns { } } - set id [string trimleft $origin :] - if {[info commands ::punk::args::id_exists] ne ""} { - if {[punk::args::id_exists $id]} { - return [uplevel 1 [list punk::args::usage {*}$opts $id]] - } - } set origin_ns [nsprefix $origin] set parts [nsparts $origin_ns] set weird_ns 0 @@ -2379,24 +2542,42 @@ tcl::namespace::eval punk::ns { if {$weird_ns} { set argl {} set tail [nstail $origin] - foreach a [nseval_ifexists $origin_ns [list info args $tail]] { - if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { - lappend a $def + set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] + if {$cmdtype eq "proc"} { + foreach a [nseval_ifexists $origin_ns [list info args $tail]] { + if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } else { - set argl {} - foreach a [info args $origin] { - if {[info default $origin $a def]} { - lappend a $def + set cmdtype [punk::ns::cmdtype $origin] + if {$cmdtype eq "proc"} { + set argl {} + set infoargs [info args $origin] + foreach a $infoargs { + if {[info default $origin $a def]} { + lappend a $def + } + lappend argl $a } - lappend argl $a } } - set msg "No argument processor detected" - append msg \n "function signature: $resolved $argl" + if {[llength $queryargs]} { + #todo - something better + set msg "Undocumented or nonexistant subcommand $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" + } else { + set msg "Undocumented command $origin. Type: $cmdtype" + } + } return $msg } @@ -2738,8 +2919,8 @@ tcl::namespace::eval punk::ns { interp alias "" use "" punk::ns::pkguse punk::args::definition { - *id punk::ns::nsimport_noclobber - *proc -name punk::ns::nsimport_noclobber -help\ + @id -id ::punk::ns::nsimport_noclobber + @cmd -name punk::ns::nsimport_noclobber -help\ "Import exported commands from a namespace into either the current namespace, or that specified in -targetnamespace. Return list of imported commands, ignores failures due to name conflicts" @@ -2750,14 +2931,14 @@ tcl::namespace::eval punk::ns { If not supplied, caller's namespace is used." -prefix -optional 1 -help\ "string prefix for command names in target namespace" - *values -min 1 -max 1 + @values -min 1 -max 1 sourcepattern -type string -optional 0 -help\ "Glob pattern for source namespace. Globbing only active in the tail segment. e.g ::mynamespace::*" } proc nsimport_noclobber {args} { - lassign [dict values [punk::args::get_by_id punk::ns::nsimport_noclobber $args]] leaders opts values received + lassign [dict values [punk::args::get_by_id ::punk::ns::nsimport_noclobber $args]] leaders opts values received set sourcepattern [dict get $values sourcepattern] set source_ns [tcl::namespace::qualifiers $sourcepattern] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm index d3431188..65ede7c8 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm @@ -645,14 +645,14 @@ namespace eval punk::path { } punk::args::definition { - *id punk::path::treefilenames + @id -id ::punk::path::treefilenames -directory -type directory -help\ "folder in which to begin recursive scan for files." -call-depth-internal -default 0 -type integer -antiglob_paths -default {} -help\ "list of path patterns to exclude may include * and ** path segments e.g /usr/**" - *values -min 0 -max -1 -optional 1 -type string + @values -min 0 -max -1 -optional 1 -type string tailglobs -multiple 1 -help\ "Patterns to match against filename portion (last segment) of each file path within the directory tree being searched." @@ -671,7 +671,7 @@ namespace eval punk::path { #[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** #[para]no natsorting - so order is dependent on filesystem - set argd [punk::args::get_by_id punk::path::treefilenames $args] + set argd [punk::args::get_by_id ::punk::path::treefilenames $args] lassign [dict values $argd] leaders opts values received set tailglobs [dict values $values] # -- --- --- --- --- --- --- 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 28a7271b..98bc04ef 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 @@ -62,6 +62,73 @@ package require punk::mix::util ;#do_in_path # -- --- --- --- --- --- --- --- --- --- --- namespace eval punk::repo { + variable PUNKARGS + variable PUNKARGS_aliases + + proc get_fossil_usage {} { + set allcmds [runout -n fossil help -a] + set mainhelp [runout -n fossil help] + set maincommands [list] + foreach ln [split $mainhelp \n] { + set ln [string trim $ln] + if {$ln eq "" || [regexp {^[A-Z]+} $ln]} { + continue + } + lappend maincommands {*}$ln + } + set othercmds [punk::lib::ldiff $allcmds $maincommands] + + set result "@leaders -min 0\n" + + append result [tstr -return string { + subcommand -type string -choicecolumns 8 -choicegroups { + "frequently used commands" {${$maincommands}} + "" {${$othercmds}} + } + }] + + return $result + } + + + #lappend PUNKARGS [list -dynamic 1 { + # @id -id ::punk::repo::fossil_proxy + # @cmd -name fossil -help "fossil executable + # " + # @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} + # } ""] + + lappend PUNKARGS [list -dynamic 1 { + @id -id ::punk::repo::fossil_proxy + @cmd -name fossil -help "fossil executable" + ${[punk::repo::get_fossil_usage]} + } ] + + + + #experiment + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + lappend PUNKARGS [list -dynamic 1 { + @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]}} + } ""] + #TODO + #lappend PUNKARGS [list -dynamic 1 { + # @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]}} + # } ""] + lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} + lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} + #Todo - investigate proper way to install a client-side commit hook in the fossil project #Then we may still use this proxy to check the hook - but the required checks will occur when another shell used @@ -137,7 +204,7 @@ namespace eval punk::repo { puts stderr "fossil command not found. Please install fossil" } } - interp alias "" fossil "" punk::repo::fossil_proxy + # --- # Calling auto_execok on an external tool can be too slow to do during package load (e.g could be 150ms) @@ -153,6 +220,7 @@ namespace eval punk::repo { # ---------- # + #uppercase FOSSIL to bypass fossil as alias to fossil_proxy proc establish_FOSSIL {args} { if {![info exists ::auto_execs(FOSSIL)]} { @@ -161,7 +229,6 @@ namespace eval punk::repo { interp alias "" FOSSIL "" ;#delete establishment alias FOSSIL {*}$args } - interp alias "" FOSSIL "" punk::repo::establish_FOSSIL # ---------- proc askuser {question} { @@ -1577,6 +1644,8 @@ namespace eval punk::repo { } } + interp alias "" fossil "" punk::repo::fossil_proxy + interp alias "" FOSSIL "" punk::repo::establish_FOSSIL interp alias {} is_fossil {} ::punk::repo::is_fossil interp alias {} is_fossil_root {} ::punk::repo::is_fossil_root @@ -1609,6 +1678,17 @@ namespace eval punk::repo::lib { } + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +if {![info exists ::punk::args::register::NAMESPACES]} { + namespace eval ::punk::args::register { + set ::punk::args::register::NAMESPACES [list] ;#use fully qualified so 8.6 doesn't find existing var in global namespace + } +} +lappend ::punk::args::register::NAMESPACES ::punk::repo +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::repo [namespace eval punk::repo { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm index 38994f5c..90851b29 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm @@ -366,7 +366,7 @@ tcl::namespace::eval punk::safe { #REVIEW set autoPath {} } - set argd [punk::args::get_by_id punk::safe::interpCreate $args] + set argd [punk::args::get_by_id ::punk::safe::interpCreate $args] set child [dict get $argd leaders child] set autoPath [dict get $argd opts -autoPath] punk::safe::lib::RejectExcessColons $child @@ -387,7 +387,7 @@ tcl::namespace::eval punk::safe { if {$AutoPathSync} { set autoPath {} } - set argd [punk::args::get_by_id punk::safe::interpIC $args] + set argd [punk::args::get_by_id ::punk::safe::interpIC $args] set child [dict get $argd leaders child] set autoPath [dict get $argd opts -autoPath] if {![::interp exists $child]} { @@ -437,7 +437,7 @@ tcl::namespace::eval punk::safe { # we know that "child" is our given argument because it also # checks for the "-help" option. #TODO! - set argd [punk::args::get_by_id punk::safe::interpIC $args] + set argd [punk::args::get_by_id ::punk::safe::interpIC $args] set child [dict get $argd leaders child] CheckInterp $child @@ -501,7 +501,7 @@ tcl::namespace::eval punk::safe { } default { #return -code error "unknown flag $name. Known options: $opt_names" - punk::args::get_by_id punk::safe::interpIC [list $child $arg] + punk::args::get_by_id ::punk::safe::interpIC [list $child $arg] } } } @@ -509,7 +509,7 @@ tcl::namespace::eval punk::safe { # Otherwise we want to parse the arguments like init and create did #set Args [::tcl::OptKeyParse ::safe::interpIC $args] - set argd [punk::args::get_by_id punk::safe::interpIC $args] + set argd [punk::args::get_by_id ::punk::safe::interpIC $args] set child [dict get $argd leaders child] CheckInterp $child namespace upvar ::punk::safe::system [VarName $child] state @@ -742,8 +742,8 @@ tcl::namespace::eval punk::safe::system { variable AutoPathSync set OPTS { - *id punk::safe::OPTS - *opts -optional 1 + @id -id ::punk::safe::OPTS + @opts -optional 1 -accessPath -type list -default {} -help\ "access path for the child" -noStatics -type none -default 0 -help\ @@ -765,27 +765,27 @@ tcl::namespace::eval punk::safe::system { set optlines [punk::args::get_spec punk::safe::OPTS -*] set INTERPCREATE { - *id punk::safe::interpCreate - *proc -name punk::safe::interpCreate -help\ + @id -id ::punk::safe::interpCreate + @cmd -name punk::safe::interpCreate -help\ "Create a safe interpreter with punk::safe specific aliases Returns the interpreter name" - *leaders + @leaders child -type string -default "" -regexprefail "^-" -regexprefailmsg "" -optional 1 -help\ "name of the child (optional)" } append INTERPCREATE \n $optlines - append INTERPCREATE \n {*values -max 0} + append INTERPCREATE \n {@values -max 0} punk::args::definition $INTERPCREATE set INTERPIC { - *id punk::safe::interpIC - *leaders + @id -id ::punk::safe::interpIC + @leaders child -type string -optional 0 -regexprefail "^-" -regexprefailmsg "" -help\ "name of the child" } append INTERPIC \n $optlines - append INTERPIC \n {*values -max 0} + append INTERPIC \n {@values -max 0} punk::args::definition $INTERPIC diff --git a/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm index be42f571..62596f5d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm @@ -142,21 +142,21 @@ tcl::namespace::eval punk::sixel { #we will for now consume all to final ST #TODO - sixel row/col info is dependent on terminal - pass in -terminalobject or -inoutchannels (for use with punk::console::cell_size) punk::args::definition { - *id punk::sixel::get_info - *proc -name punk::sixel::get_info -help\ + @id -id ::punk::sixel::get_info + @cmd -name punk::sixel::get_info -help\ "return a dict of information about the supplied sixelstring" -cache -default 1 -type boolean -help\ "Cached result based on sha1 hash." -cell_size -default "" -help\ "override terminal cell_size. If left empty, attempt to use value from querying terminal." - *values -min 1 -max 1 + @values -min 1 -max 1 sixelstring -type string -help "A single sixel image - currently only 7-bit supported" } variable sixelinfo_cache set sixelinfo_cache [dict create] proc get_info {args} { - set argd [punk::args::get_by_id punk::sixel::get_info $args] + set argd [punk::args::get_by_id ::punk::sixel::get_info $args] set sixelstring [dict get $argd values sixelstring] set do_cache [dict get $argd opts -cache] set cell_size_override [dict get $argd opts -cell_size] 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 311a8025..11ae9ab2 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 @@ -180,10 +180,11 @@ tcl::namespace::eval punk::zip { #}] set argd [punk::args::get_dict { - *proc -name punk::zip::walk + @id -id ::punk::zip::walk + @cmd -name punk::zip::walk -excludes -default "" -help "list of glob expressions to match against files and exclude" -subpath -default "" - *values -min 1 -max -1 + @values -min 1 -max -1 base fileglobs -default {*} -multiple 1 } $args] @@ -373,11 +374,12 @@ tcl::namespace::eval punk::zip { #[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 { - *proc -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' + @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 + @opts -comment -default "" -help "An optional comment specific to the added file" - *values -min 3 -max 4 + @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" @@ -525,9 +527,10 @@ tcl::namespace::eval punk::zip { #[para] Call 'punk::zip::mkzip' with no arguments for usage display. set argd [punk::args::get_dict { - *proc -name punk::zip::mkzip\ + @id -id ::punk::zip::mkzip + @cmd -name punk::zip::mkzip\ -help "Create a zip archive in 'filename'" - *opts + @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. @@ -557,7 +560,7 @@ tcl::namespace::eval punk::zip { it must be a parent of -directory or the same path as -directory" -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} - *values -min 1 -max -1 + @values -min 1 -max -1 filename -type file -default ""\ -help "name of zipfile to create" globs -default {*} -multiple 1\ diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm index 3651c0f0..dcc023ec 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.2.tm @@ -123,12 +123,12 @@ tcl::namespace::eval textblock { set choicemsg " (unavailable packages: $unavailable)" } set argd [punk::args::get_dict [tstr -return string { - *id textblock::use_hash - *proc -name "textblock::use_hash" -help\ + @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 + @values -min 0 -max 1 hash_algorithm -choices {${$choices}} -optional 1 -help\ "algorithm choice ${$choicemsg}" }] $args] @@ -423,7 +423,6 @@ tcl::namespace::eval textblock { } } } - my configure {*}$o_opts_table #foreach {k v} $args { # #todo - convert to literal switch using tcl::string::map so we don't have to define o_opts_table_defaults here. @@ -453,6 +452,7 @@ tcl::namespace::eval textblock { -minheight 1\ -maxheight ""\ ] + my configure {*}$o_opts_table } method width_algorithm {{alg ""}} { @@ -593,7 +593,7 @@ tcl::namespace::eval textblock { tcl::dict::set o_opts_table_effective -framelimits_header $hlims return [tcl::dict::create body $blims header $hlims] } - method configure args { + method configure {args} { #*** !doctools #[call class::table [method configure] [arg args]] #[para] get or set various table-level properties @@ -781,6 +781,14 @@ tcl::namespace::eval textblock { } } } + -title { + set twidth [punk::ansi::printing_length $v] + if {[my width] < [expr {$twidth+2}]} { + set o_calculated_column_widths [list] + tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] + } + tcl::dict::set o_opts_table -title $v + } default { tcl::dict::set o_opts_table $k $v } @@ -3943,14 +3951,13 @@ tcl::namespace::eval textblock { if {$header_build eq "" && ![llength $body_blocks]} { set header_build $nextcol_header - lappend body_blocks $nextcol_body } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] } - lappend body_blocks $nextcol_body #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } + lappend body_blocks $nextcol_body incr padwidth $bodywidth incr colposn } @@ -4096,8 +4103,8 @@ tcl::namespace::eval textblock { } punk::args::definition { - *id textblock::periodic - *proc -name textblock::periodic -help "A rudimentary periodic table + @id -id ::textblock::periodic + @cmd -name textblock::periodic -help "A rudimentary periodic table This is primarily a test of textblock::class::table" -return -default table\ @@ -4109,13 +4116,13 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli - set opts [dict get [punk::args::get_by_id textblock::periodic $args] opts] + set opts [dict get [punk::args::get_by_id ::textblock::periodic $args] opts] set opt_return [tcl::dict::get $opts -return] if {[tcl::dict::get $opts -forcecolour]} { set fc forcecolour @@ -4345,7 +4352,10 @@ tcl::namespace::eval textblock { set FRAMETYPES [textblock::frametypes] punk::args::definition [punk::lib::tstr -return string { - *id textblock::list_as_table + @id -id ::textblock::list_as_table + @cmd -name "textblock::list_as_table" -help\ + "Display a list in a bordered table + " -return -default table -choices {table tableobject} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ @@ -4376,13 +4386,13 @@ tcl::namespace::eval textblock { -help "Number of table columns Will default to 2 if not using an existing -table object" - *values -min 0 -max 1 + @values -min 0 -max 1 datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value" }] proc list_as_table {args} { set FRAMETYPES [textblock::frametypes] - set argd [punk::args::get_by_id textblock::list_as_table $args] + set argd [punk::args::get_by_id ::textblock::list_as_table $args] set opts [dict get $argd opts] set datalist [dict get $argd values datalist] @@ -4894,7 +4904,7 @@ tcl::namespace::eval textblock { #review!? #-within_ansi means after a leading ansi code when doing left pad on all but last line #-within_ansi means before a trailing ansi code when doing right pad on all but last line - set usage "pad ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" + set usage "pad block ?-padchar |? ?-which right|left|centre? ?-known_hasansi \"\"|? ?-known_blockwidth \"\"|? ?-width auto|? ?-within_ansi 1|0?" foreach {k v} $args { switch -- $k { -padchar - -which - -known_hasansi - -known_samewidth - -known_blockwidth - -width - -overflow - -within_ansi { @@ -5420,16 +5430,21 @@ tcl::namespace::eval textblock { return [punk::lib::list_as_lines -- $outlines] } + + punk::args::definition { + @id -id ::textblock::join_basic + @cmd -name textblock::join_basic -help\ + "Join blocks of text 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 + " + -- -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 + } + #join without regard to each line length in a block (no padding added to make each block uniform) proc ::textblock::join_basic {args} { - #*proc -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 { - -- -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 argd [punk::args::get_by_id ::textblock::join_basic $args] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -5466,7 +5481,7 @@ tcl::namespace::eval textblock { return [::join $outlines \n] } proc ::textblock::join_basic2 {args} { - #*proc -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. + #@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 { @@ -6046,8 +6061,8 @@ tcl::namespace::eval textblock { if {$bad_option || [llength $values] == 0} { #no framedef supplied, or unrecognised opt seen set spec [string map [list $::textblock::frametypes] { - *id textblock::framedef - *proc -name textblock::framedef\ + @id -id ::textblock::framedef + @cmd -name textblock::framedef\ -help "Return a dict of the elements that make up a frame border. May return a subset of available elements based on memberglob values." @@ -6058,7 +6073,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - *values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -7438,17 +7453,17 @@ tcl::namespace::eval textblock { set frame_cache [tcl::dict::create] punk::args::definition { - *id textblock::frame_cache - *proc -name textblock::frame_cache -help\ + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ "Display or clear the frame cache." -action -default {} -choices {clear} -help\ "Clear the textblock::frame_cache dictionary" -pretty -default 1 -help\ "Use 'pdict textblock::frame_cache */*' for prettier output" - *values -min 0 -max 0 + @values -min 0 -max 0 } proc frame_cache {args} { - set argd [punk::args::get_by_id textblock::frame_cache $args] + set argd [punk::args::get_by_id ::textblock::frame_cache $args] set action [dict get $argd opts -action] if {$action ni [list clear ""]} { @@ -7490,13 +7505,40 @@ tcl::namespace::eval textblock { } + variable FRAMETYPES set FRAMETYPES [textblock::frametypes] + variable EG set EG [a+ brightblack] + variable RST set RST [a] + + proc frame_samples {} { + set FRAMETYPELABELS [dict create] + if {[info commands ::textblock::frame] ne ""} { + foreach ft [frametypes] { + dict set FRAMETYPELABELS $ft [textblock::frame -checkargs 0 -type $ft " "] + } + } + set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] + return $FRAMETYPELABELS + } + #proc EG {} "return {[a+ brightblack]}" + #make EG fetch from SGR cache so as to abide by colour off/on + proc EG {} { + a+ brightblack + } + #proc RST {} "return {\x1b\[m}" + proc RST {} { + return "\x1b\[m" + } + + #catch 22 for -choicelabels - need some sort of lazy evaluation + # ${[textblock::frame_samples]} + #todo punk::args alias for centre center etc? - punk::args::definition [punk::lib::tstr -return string { - *id textblock::frame - *proc -name "textblock::frame"\ + punk::args::definition -dynamic 1 { + @id -id ::textblock::frame + @cmd -name "textblock::frame"\ -help "Frame a block of text with a border." -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and @@ -7504,18 +7546,21 @@ tcl::namespace::eval textblock { Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." - -type -default light -choices {${$FRAMETYPES}} -choicerestricted 0 -type dict\ + -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ + -choicelabels { + ${[textblock::frame_samples]} + }\ -help "Type of border for frame." -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. passing an empty string will result in no box, but title/subtitle will still appear if supplied. - ${$EG}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${$RST}" + ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. May contain ANSI - no trailing reset required. - ${$EG}e.g 1: frame -title My[a+ green]Green[a]Thing - e.g 2: frame -title [a+ red underline]MyThing${$RST}" + ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing + e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" -subtitle -default "" -type string -regexprefail {\n}\ -help "Frame subtitle placed on bottombar - no newlines May contain Ansi - no trailing reset required." @@ -7526,8 +7571,8 @@ tcl::namespace::eval textblock { -help "Height of resulting frame including borders." -ansiborder -default "" -type ansistring\ -help "Ansi escape sequence to set border attributes. - ${$EG}e.g 1: frame -ansiborder [a+ web-red] contents - e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${$RST}" + ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents + e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" -ansibase -default "" -type ansistring\ -help "Default ANSI attributes within frame." -blockalign -default centre -choices {left right centre}\ @@ -7547,13 +7592,13 @@ tcl::namespace::eval textblock { Frame width doesn't adapt and content may be truncated so -width may need to be manually set to display more." - *values -min 0 -max 1 + @values -min 0 -max 1 contents -default "" -type string\ -help "Frame contents - may be a block of text containing newlines and ANSI. Text may be 'ragged' - ie unequal line-lengths. No trailing ANSI reset required. - ${$EG}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${$RST}" - }] + ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" + } #options before content argument - which is allowed to be absent #frame performance (noticeable with complex tables even of modest size) is improved somewhat by frame_cache - but is still (2024) a fairly expensive operation. @@ -7638,7 +7683,7 @@ tcl::namespace::eval textblock { #only use punk::args if check_args is true or our basic checks failed #never need to checkargs if only one argument supplied even if it looks like an option - as it will be treated as data to frame if {[llength $args] != 1 && (!$opts_ok || $check_args)} { - set argd [punk::args::get_by_id textblock::frame $args] + set argd [punk::args::get_by_id ::textblock::frame $args] set opts [dict get $argd opts] set contents [dict get $argd values contents] } @@ -8346,18 +8391,18 @@ tcl::namespace::eval textblock { } } punk::args::definition { - *id textblock::gcross + @id -id ::textblock::gcross -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block Only cross sizes that divide the size of the overall block will be used. e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. " - *values -min 0 -max 1 + @values -min 0 -max 1 size -default 1 -type integer } proc gcross {args} { - set argd [punk::args::get_by_id textblock::gcross $args] + set argd [punk::args::get_by_id ::textblock::gcross $args] set size [dict get $argd values size] set opts [dict get $argd opts]