Browse Source

bootsupport etc

master
Julian Noble 3 months ago
parent
commit
0e5e782dfc
  1. 50
      src/bootsupport/modules/punk-0.1.tm
  2. 45
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  3. 10862
      src/bootsupport/modules/punk/args-0.2.1.tm
  4. 3017
      src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  5. 4570
      src/bootsupport/modules/punk/lib-0.1.3.tm
  6. 4
      src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  7. 272
      src/bootsupport/modules/punk/ns-0.1.0.tm
  8. 2
      src/bootsupport/modules/punk/path-0.1.0.tm
  9. 125
      src/bootsupport/modules/textblock-0.1.3.tm
  10. 50
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm
  11. 45
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  12. 10862
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm
  13. 3017
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  14. 4570
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm
  15. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  16. 272
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  17. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
  18. 125
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  19. 50
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm
  20. 45
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  21. 10862
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm
  22. 3017
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  23. 4570
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm
  24. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm
  25. 272
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  26. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm
  27. 125
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  28. 4
      src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm
  29. 50
      src/vfs/_vfscommon.vfs/modules/punk-0.1.tm
  30. 45
      src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm
  31. 10862
      src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm
  32. 211
      src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm
  33. 3017
      src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm
  34. 70
      src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tkcore-0.1.1.tm
  35. 88
      src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm
  36. 2
      src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm
  37. 4570
      src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.3.tm
  38. 4
      src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm
  39. BIN
      src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.2.tm
  40. 155
      src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm
  41. 8
      src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm
  42. 272
      src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
  43. 2
      src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm
  44. BIN
      src/vfs/_vfscommon.vfs/modules/tarjar-2.4.3.tm
  45. BIN
      src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm
  46. BIN
      src/vfs/_vfscommon.vfs/modules/test/punk/lib-0.1.3.tm
  47. 125
      src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm

50
src/bootsupport/modules/punk-0.1.tm

@ -577,18 +577,18 @@ namespace eval punk {
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
-returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels { -returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels {
"matched"\ "matched"\
" Return only lines that matched." " Return only lines that matched."
"breaksandmatches"\ "breaksandmatches"\
" Return configured --break= lines in between non-consecutive matches" " Return configured --break= lines in between non-consecutive matches"
"all"\ "all"\
" Return all lines. " Return all lines.
This has a similar effect to the 'grep' trick of matching on 'pattern|$' This has a similar effect to the 'grep' trick of matching on 'pattern|$'
(The $ matches all lines that have an end; ie all lines, but there is no (The $ matches all lines that have an end; ie all lines, but there is no
associated character to which to apply highlighting) associated character to which to apply highlighting)
except that when instead using -returnlines all with --line-number, the * except that when instead using -returnlines all with --line-number, the *
indicator after the linenumber will only be highlighted for lines with matches, indicator after the linenumber will only be highlighted for lines with matches,
and the following matchcount will indicate zero for non-matching lines." and the following matchcount will indicate zero for non-matching lines."
} }
-B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num
-C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\ -C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\
@ -609,9 +609,9 @@ namespace eval punk {
" "
-ansistrip -type none -help\ -ansistrip -type none -help\
"Strip all ansi codes from the input string before processing. "Strip all ansi codes from the input string before processing.
This is not necessary for regex matching purposes, as the matching is always This is not necessary for regex matching purposes, as the matching is always
performed on the ansistripped characters anyway, but by stripping ANSI, the performed on the ansistripped characters anyway, but by stripping ANSI, the
result only has the ANSI supplied by the -highlight option." result only has the ANSI supplied by the -highlight option."
#-n|--line-number as per grep utility, except that we include a * for matches #-n|--line-number as per grep utility, except that we include a * for matches
-n|--line-number -type none -help\ -n|--line-number -type none -help\
@ -7153,8 +7153,8 @@ namespace eval punk {
-exclude_punctlines -default 1 -type boolean -exclude_punctlines -default 1 -type boolean
-show_largest -default 0 -type integer -help\ -show_largest -default 0 -type integer -help\
"Report the top largest linecount files. "Report the top largest linecount files.
The value represents the number of files The value represents the number of files
to report on." to report on."
} " } "
#we could map away whitespace and use string is punct - but not as flexible? review #we could map away whitespace and use string is punct - but not as flexible? review
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
@ -7384,7 +7384,7 @@ namespace eval punk {
#dict of list-len 2 is equiv to dict of dict with one keyval pair #dict of list-len 2 is equiv to dict of dict with one keyval pair
#-------------------------------- #--------------------------------
#!!!todo fix - linedict is unfinished and non-functioning #!!!todo fix - linedict is unfinished and non-functioning
#linedict based on indents #linedict based on indents
@ -7615,23 +7615,23 @@ namespace eval punk {
-showcount -type boolean -default 1 -help\ -showcount -type boolean -default 1 -help\
"Display a leading indicator in brackets showing the number of arg values present." "Display a leading indicator in brackets showing the number of arg values present."
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels {
0 "Strip ANSI codes from display 0 " Strip ANSI codes from display
of values. The disply output will of values. The disply output will
still be colourised if -ansibase has still be colourised if -ansibase has
not been set to empty string or not been set to empty string or
[a+ normal]. The stderr or stdout [a+ normal]. The stderr or stdout
channels may also have an ansi colour. channels may also have an ansi colour.
(see 'colour off' or punk::config)" (see 'colour off' or punk::config)"
1 "Leave value as is" 1 " Leave value as is"
2 "Display the ANSI codes and 2 " Display the ANSI codes and
other control characters inline other control characters inline
with replacement indicators. with replacement indicators.
e.g esc, newline, space, tab" e.g esc, newline, space, tab"
VIEW "Alias for 2" VIEW " Alias for 2"
3 "Display as per 2 but with 3 " Display as per 2 but with
colourised ANSI replacement codes." colourised ANSI replacement codes."
VIEWCODES "Alias for 3" VIEWCODES " Alias for 3"
4 "Display ANSI and control 4 " Display ANSI and control
chars in default colour, but chars in default colour, but
apply the contained ansi to apply the contained ansi to
the text portions so they display the text portions so they display

45
src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -3287,31 +3287,32 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#indent of 1 space is important for clarity in i -return string a+ output #indent of 1 space is important for clarity in i -return string a+ output
dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m" dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m"
} }
set SGR_help\ set SGR_help\
{SGR code from the list below, or an integer corresponding to the code e.g 31 = red. {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. A leading capital letter indicates a codename applies to the background colour.
Other accepted codes are: Other accepted codes are:
term-<int> Term-<int> foreground/background where int is 0-255 terminal color term-<int> Term-<int> foreground/background where int is 0-255 terminal color
term-<termcolour> Term-<termcolour> foreground/background term-<termcolour> Term-<termcolour> foreground/background
web-<webcolour> Web-<webcolour> web-<webcolour> Web-<webcolour>
x11-<xllcolour> X11-<x11colour> x11-<xllcolour> X11-<x11colour>
tk-<tkcolour> Tk-<tkcolour> tk-<tkcolour> Tk-<tkcolour>
rgb-<r>-<g>-<b> Rgb-<r>-<g>-<b> foreground/background where <r> <g> <b> are the rgb-<r>-<g>-<b> Rgb-<r>-<g>-<b> foreground/background where <r> <g> <b> are the
0-255 int values for red, green and blue. 0-255 int values for red, green and blue.
rgb#<hexcode> Rgb#<hexcode> where <hexcode> is a 6 char hex colour e.g rgb#C71585 rgb#<hexcode> Rgb#<hexcode> where <hexcode> is a 6 char hex colour e.g rgb#C71585
The acceptable values for colours can be queried using The acceptable values for colours can be queried using
punk::ansi::a? term punk::ansi::a? term
punk::ansi::a? web punk::ansi::a? web
punk::ansi::a? x11 punk::ansi::a? x11
punk::ansi::a? tk punk::ansi::a? tk
Example to set foreground red and background cyan followed by a reset: Example to set foreground red and background cyan followed by a reset:
set str \"[a+ red Cyan]sample text[a]\" set str \"[a+ red Cyan]sample text[a]\"
} }
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::punk::ansi::a+ @id -id ::punk::ansi::a+
@ -3325,6 +3326,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
-choicelabels {%choicelabels%}\ -choicelabels {%choicelabels%}\
-choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\
"%SGR_help%" "%SGR_help%"
#note SGR_help string has same level of indent as placeholder
}]] }]]
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -5835,8 +5837,11 @@ tcl::namespace::eval punk::ansi::ta {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::ansi::ta}] #[subsection {Namespace punk::ansi::ta}]
#[para] text ansi functions #[para] text ansi functions
#[para] based on but not identical to the Perl Text Ansi module: #[para] based on the API but not identical to the Perl Text Ansi module: Text::ANSI::Util
#[para] https://metacpan.org/pod/Text::ANSI::Util
#[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm
#[para] These functions are not based on the source code of the perl functions, but the documented input and output
#[para] so algorithms and performance may differ.
#[list_begin definitions] #[list_begin definitions]
tcl::namespace::path ::punk::ansi tcl::namespace::path ::punk::ansi
namespace export detect detect_in_list detect_sgr extract length split_codes split_at_codes split_codes_single namespace export detect detect_in_list detect_sgr extract length split_codes split_at_codes split_codes_single
@ -8137,7 +8142,7 @@ tcl::namespace::eval punk::ansi::ansistring {
#return empty string for each index that is out of range #return empty string for each index that is out of range
#review - this is possibly too slow to be very useful as is. #review - this is possibly too slow to be very useful as is.
# consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string
#see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. #see also punk::lib::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them.
proc INDEXABSOLUTE {string args} { proc INDEXABSOLUTE {string args} {
set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most) set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most)
set testindices [list] set testindices [list]
@ -8166,6 +8171,8 @@ tcl::namespace::eval punk::ansi::ansistring {
} else { } else {
set offset 0 set offset 0
} }
#2025 -BROKEN - doesn't handle indices with both + and -
#see updated punk::lib::lindex_resolve
#by now, if op = + then offset = 0 so we only need to handle the minus case #by now, if op = + then offset = 0 so we only need to handle the minus case
if {$payload_len == -1} { if {$payload_len == -1} {
set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal

10862
src/bootsupport/modules/punk/args-0.2.1.tm

File diff suppressed because it is too large Load Diff

3017
src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm

File diff suppressed because it is too large Load Diff

4570
src/bootsupport/modules/punk/lib-0.1.3.tm

File diff suppressed because it is too large Load Diff

4
src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -150,8 +150,8 @@ namespace eval punk::mix::commandset::module {
"Create a new module file in the appropriate folder within src/modules. "Create a new module file in the appropriate folder within src/modules.
If the name given in the module argument is namespaced, If the name given in the module argument is namespaced,
the necessary subfolder(s) will be used or created." the necessary subfolder(s) will be used or created."
-project -optional 1 -project -optional 1
-version -default "0.1.0" -help\ -version -type packageversion -default "0.1.0" -help\
"version to use if not specified as part of the module argument. "version to use if not specified as part of the module argument.
If a version is specified in the module argument as well as in -version If a version is specified in the module argument as well as in -version
the higher version number will be used. the higher version number will be used.

272
src/bootsupport/modules/punk/ns-0.1.0.tm

@ -491,42 +491,50 @@ tcl::namespace::eval punk::ns {
lassign $cindices cstart cend lassign $cindices cstart cend
append p [string range $nspath $s $cstart-1] append p [string range $nspath $s $cstart-1]
set numcolons [expr {$cend - $cstart + 1}] set numcolons [expr {$cend - $cstart + 1}]
if {$numcolons == 1} { #assert numcolons != 0 due to regexp +
#internal colon switch -exact -- $numcolons {
append p : 2 - 4 {
set s [expr {$cend+1}] #4 is a somewhat common case - could handle with default branch but may as well short circuit here.
continue
} elseif {$numcolons == 2} {
lappend parts $p
set p ""
set s [expr {$cend+1}]
continue
} elseif {($numcolons -1) % 3 == 0} {
set numcolons [expr {$numcolons -2}]
}
#assert numcolons >=3 and not in 4,7,10,13,16,19,22... sequence
if {$numcolons % 3 == 0} {
#if numcolons % 3 == 0 we have a leading colon left for next ns
#this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y
#we resolve with allowing leading colons only for each ns.
set singlec_count [expr {($numcolons /3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p lappend parts $p
set p ""
set s [expr {$cend+1}]
#continue
} }
set p ":" 1 {
set s [expr {$cend+1}] #internal colon
continue append p :
} else { set s [expr {$cend+1}]
set singlec_count [expr {(($numcolons +1)/3) -1}] #continue
if {$singlec_count > 0} { }
lappend parts $p {*}[lrepeat $singlec_count :] default {
} else { if {($numcolons -1) %3 == 0} {
lappend parts $p set numcolons [expr {$numcolons -2}]
}
#assert numcolons >=4 and not in 7,10,13,16,19,22... sequence
if {$numcolons % 3 == 0} {
#if numcolons % 3 == 0 we have a leading colon left for next ns
#this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y
#we resolve with allowing leading colons only for each ns.
set singlec_count [expr {($numcolons /3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p
}
set p ":"
set s [expr {$cend+1}]
#continue
} else {
set singlec_count [expr {(($numcolons +1)/3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p
}
set p ""
set s [expr {$cend+1}]
}
} }
set p ""
set s [expr {$cend+1}]
} }
} }
if {$cend < ([string length $nspath]-1)} { if {$cend < ([string length $nspath]-1)} {
@ -695,6 +703,39 @@ tcl::namespace::eval punk::ns {
} }
proc nsglob_as_re {glob} { proc nsglob_as_re {glob} {
#any segment that is not just * must match exactly one segment in the path
set pats [list]
foreach seg [nsparts_cached $glob] {
switch -exact -- $seg {
"" {
lappend pats ""
}
* {
#review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed
#lappend pats {[^:]*}
#negative lookahead
#any number of chars not followed by ::, followed by any number of non :
lappend pats {(?:.(?!::))*[^:]*}
}
** {
lappend pats {.*}
}
default {
set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
#set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg]
set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg]
lappend pats "$pat"
} else {
lappend pats "$seg"
}
}
}
}
return "^[join $pats ::]\$"
}
#obsolete
proc nsglob_as_re1 {glob} {
#any segment that is not just * must match exactly one segment in the path #any segment that is not just * must match exactly one segment in the path
set pats [list] set pats [list]
foreach seg [nsparts_cached $glob] { foreach seg [nsparts_cached $glob] {
@ -2984,7 +3025,7 @@ tcl::namespace::eval punk::ns {
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
#private? todo? #private? todo?
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
#dict set choiceinfodict $cmd {{doctype ooo}} #dict set choiceinfodict $cmd {{doctype ooo}}
@ -3042,9 +3083,10 @@ tcl::namespace::eval punk::ns {
@cmd -name "${$objtype}: ${$origin}" -help\ @cmd -name "${$objtype}: ${$origin}" -help\
"Instance of class: ${$class} (info autogenerated by generate_autodef) "Instance of class: ${$class} (info autogenerated by generate_autodef)
(see 'i punk::ns::Cmark' for symbols)" (see 'i punk::ns::Cmark' for symbols)"
@leaders -min 1 @leaders -min 1 -max 1
}] }]
append argdef \n $vline append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
@ -3148,15 +3190,15 @@ tcl::namespace::eval punk::ns {
dict for {sub subwhat} $subcommand_dict { dict for {sub subwhat} $subcommand_dict {
if {[llength $subwhat] > 1} { if {[llength $subwhat] > 1} {
#TODO - resolve using cmdinfo? #TODO - resolve using cmdinfo?
puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" puts stderr "generate_autodef warning: subcommand $sub points to multiword target $subwhat - TODO"
} }
set targetfirstword [lindex $subwhat 0] set targetfirstword [lindex $subwhat 0]
set targetinfo [cmdwhich $targetfirstword] set targetinfo [cmdwhich $targetfirstword]
set targetorigin [dict get $targetinfo origin] set targetorigin [dict get $targetinfo origin]
set targetcmdtype [dict get $targetinfo origintype] set targetcmdtype [dict get $targetinfo origintype]
set nstarget [nsprefix $targetorigin] set nstarget [nsprefix $targetorigin]
# -resolved-
dict set choiceinfodict $sub [list [list resolved $subwhat]] dict set choiceinfodict $sub [list [list ensemblesubtarget {*}$subwhat]]
dict lappend choiceinfodict $sub [list doctype $targetcmdtype] dict lappend choiceinfodict $sub [list doctype $targetcmdtype]
if {[punk::args::id_exists [list $origin $sub]]} { if {[punk::args::id_exists [list $origin $sub]]} {
@ -3183,17 +3225,18 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by generate_autodef) "(autogenerated by generate_autodef)
ensemble: ${$origin}" ensemble: ${$origin}"
@leaders -min 1
}] }]
#we must put a max on @leaders so that any subsequent arguments are not parsed as leaders for an ensemble root docid
if {[llength $parameters] == 0} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" append argdef \n "@leaders -min 1 -max 1"
} else { } else {
append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" append argdef \n "@leaders -min [expr {[llength $parameters]+1}] -max [expr {[llength $parameters]+1}]"
foreach p $parameters { foreach p $parameters {
append argdef \n "$p -type string -help { (leading ensemble parameter)}" append argdef \n "$p -type string -ensembleparameter 1 -help { (leading ensemble parameter)}"
} }
} }
append argdef \n $vline append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
proc { proc {
@ -3325,6 +3368,13 @@ tcl::namespace::eval punk::ns {
set cinfo [cmdwhich $finalcommand] set cinfo [cmdwhich $finalcommand]
set origin [dict get $cinfo origin] set origin [dict get $cinfo origin]
set cmdtype [dict get $cinfo origintype] set cmdtype [dict get $cinfo origintype]
if {$cmdtype eq "notfound" && [llength $finalcommand] > 1} {
#e.g see curried command produced by 'punk::netbox::man <apicontextid> new'
set next [list {*}$finalcommand {*}$remainingargs]
if {$next ne $args} {
return [cmdinfo {*}$next]
}
}
return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack] return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack]
} }
proc cmd_traverse {ns formid args} { proc cmd_traverse {ns formid args} {
@ -3493,6 +3543,7 @@ tcl::namespace::eval punk::ns {
#we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs. #we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs.
#(would not support shor-form prefix of subcommand - even if the proc implementation did) #(would not support shor-form prefix of subcommand - even if the proc implementation did)
set docid_exists 0 set docid_exists 0
set eparams [list]
if {[punk::args::id_exists "$origin [lindex $args $i]"]} { if {[punk::args::id_exists "$origin [lindex $args $i]"]} {
set a [lindex $args $i] set a [lindex $args $i]
#review - tests? #review - tests?
@ -3504,7 +3555,7 @@ tcl::namespace::eval punk::ns {
set origin [list $origin $a] set origin [list $origin $a]
incr i incr i
set queryargs [lrange $args $i end] set queryargs [lrange $args $i end]
set resolvedargs [list $a] ;#even though the set resolvedargs [list $a] ;#
set queryargs_untested $queryargs set queryargs_untested $queryargs
} elseif {[punk::args::id_exists $docid]} { } elseif {[punk::args::id_exists $docid]} {
set docid_exists 1 set docid_exists 1
@ -3543,6 +3594,12 @@ tcl::namespace::eval punk::ns {
set leadernames [dict get $spec FORMS $fid LEADER_NAMES] set leadernames [dict get $spec FORMS $fid LEADER_NAMES]
set optnames [dict get $spec FORMS $fid OPT_NAMES] set optnames [dict get $spec FORMS $fid OPT_NAMES]
set valnames [dict get $spec FORMS $fid VAL_NAMES] set valnames [dict get $spec FORMS $fid VAL_NAMES]
#review - see 'string is word' vs 'string is wordchar' behaviour due to documented common opts/vals in the parent ensemble-like command '::tcl::string::is'
#we should be preferring the most specific documentation
#Alternatively - we could adjust the 'string is' documentation to have @values -unnamed true
#and put the common info in the help for <unnamed> - but that would give us an inferior synopsis for 'string is'
if {![llength $optnames] && ![llength $valnames]} { if {![llength $optnames] && ![llength $valnames]} {
#set queryargs [lrange $args $i end] #set queryargs [lrange $args $i end]
@ -3574,8 +3631,26 @@ tcl::namespace::eval punk::ns {
if {$is_ensembleparam} { if {$is_ensembleparam} {
lappend resolvedargs $q lappend resolvedargs $q
lpop queryargs_untested 0 lpop queryargs_untested 0
lappend eparams $q
puts stderr "---> cmd_traverse ensembleparam $q ($lname)"
puts stderr "arginfo: $arginfo"
puts stderr "---> eparams: $eparams"
puts stderr "---> existing args: $args"
#ledit queryargs_untested 0 0 #ledit queryargs_untested 0 0
#review - add tests #review - add tests
#todo - put param in untested (multiple ensembleparams??)
#ledit queryargs_untested 1 0 $q ;#(linsert)
#set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand
#if {$posn_subcommand > 0} {
# set params [lrange $queryargs 0 $posn_subcommand-1]
# set remaining_queryargs [lrange $queryargs $posn_subcommand end]
#} else {
# set params [list]
# set remaining_queryargs $queryargs
#}
incr i
continue continue
} }
if {![llength $allchoices]} { if {![llength $allchoices]} {
@ -3585,7 +3660,7 @@ tcl::namespace::eval punk::ns {
#ledit queryargs_untested 0 0 #ledit queryargs_untested 0 0
#jjj #jjj
#continue #continue
return [list 3 $origin $resolvedargs $queryargs_untested $docid] return [list 3 $origin $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
break break
} }
set resolved_q [tcl::prefix::match -error "" $allchoices $q] set resolved_q [tcl::prefix::match -error "" $allchoices $q]
@ -3610,9 +3685,9 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
foreach inf $cinfo { foreach inf $cinfo {
switch -- [lindex $inf 0] { switch -- [lindex $inf 0] {
"resolved" { "subhelp" {
#punk::args::ensemble_subcommands_definition
set mapped_subcmd [lrange $inf 1 end] set mapped_subcmd [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3630,11 +3705,14 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" set docid ""
} }
#puts stderr "cmd_traverse 'resolved' $mapped_subcmd" #allow subhelp override - todo: review/document rationale/usecases
break
} }
"subhelp" { "ensemblesubtarget" {
# -resolved-
#punk::args::ensemble_subcommands_definition
#This could be a list representing some other ensemble or command with pre-included arguments
set mapped_subcmd [lrange $inf 1 end] set mapped_subcmd [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3652,8 +3730,16 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" set docid ""
} }
#allow subhelp override - todo: review/document rationale/usecases #puts stderr "cmd_traverse 'resolved' $mapped_subcmd"
break }
"doctype" {
set d [lindex $inf 1]
switch -- $d {
"classmethod" {
}
"coremethod" {
}
}
} }
} }
} }
@ -3668,23 +3754,9 @@ tcl::namespace::eval punk::ns {
set mapped_subcmd "$raw_origin $resolved_q" set mapped_subcmd "$raw_origin $resolved_q"
set docid $mapped_subcmd set docid $mapped_subcmd
} else { } else {
#REVIEW - there is no reason to assume a subcommand (even in an ensemble) #NOTE there is no reason to assume a subcommand (even in an ensemble)
#will be located at "${raw_origin}::$resolved_q" #will be located at "${raw_origin}::$resolved_q"
#ensemble -map could point resolved_q somewhere else entirely #ensemble -map could point resolved_q somewhere else entirely
#punk::args::update_definitions [list $raw_origin]
#if {[punk::args::id_exists "${raw_origin}::$resolved_q"]} {
# set mapped_subcmd "${raw_origin}::$resolved_q"
# set docid $mapped_subcmd
#} else {
# if {![punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# namespace eval $ns [list punk::ns::generate_autodef "${raw_origin}::$resolved_q"]
# }
# if {[punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# set mapped_subcmd ${raw_origin}::$resolved_q
# set docid (autodef)${raw_origin}::$resolved_q
# }
#}
} }
} }
#puts "----------$mapped_subcmd" #puts "----------$mapped_subcmd"
@ -3695,13 +3767,18 @@ tcl::namespace::eval punk::ns {
#punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] #punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {[llength $queryargs_untested] == 0} { if {[llength $queryargs_untested] == 0} {
return [list 6 $mapped_subcmd $resolvedargs $queryargs_untested $docid] return [list 6 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
} }
set origin [yield [list 0 $mapped_subcmd $resolvedargs $queryargs_untested $docid]] set origin [yield [list 0 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]]
#set resolvedargs [list] #set resolvedargs [list]
incr i [expr {-1 * [llength $resolvedargs]+1}] #incr i [expr {-1 * [llength $resolvedargs]+1}] ;#wrong e.g test trace add execution blah enterstep cmd
#puts stderr "... yield-result $origin i:$i" #JJJ
#puts stderr "... yield-result $origin i:$i args: $args"
ledit args $i+1 $i {*}$eparams
set eparams [list]
set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]] set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]]
set origin [dict get $whichinfo origin] set origin [dict get $whichinfo origin]
@ -3719,15 +3796,15 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
} }
break break ;#out of foreach q $queryargs ...
} else { } else {
#test with: i namespace which -v x #test with: i namespace which -v x
return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid] return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid]
} }
} } ;#end loop foreach q $queryargs lname $leadernames_matched
} else { } else {
#?? #??
puts stderr "cmdinfo.cmd_traverse returning 8 $origin $resolvedargs [lrange $args $i end] $docid" #puts stderr "cmdinfo.cmd_traverse returning 8 origin: $origin resolved: $resolvedargs remaining: [lrange $args $i end] docid: $docid"
return [list 8 $origin $resolvedargs [lrange $args $i end] $docid] return [list 8 $origin $resolvedargs [lrange $args $i end] $docid]
} }
} else { } else {
@ -3758,7 +3835,8 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::forms] set argd [::punk::args::parse $args withid ::punk::ns::forms]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context
set id [dict get $resolveinfo origin] #set id [dict get $resolveinfo origin]
set id [dict get $resolveinfo docid]
::punk::args::forms $id ::punk::args::forms $id
} }
@ -3778,8 +3856,10 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::eg] set argd [::punk::args::parse $args withid ::punk::ns::eg]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context
set resolved_id [dict get $resolveinfo origin] #set resolved_id [dict get $resolveinfo origin]
set result [::punk::args::eg $resolved_id] #set result [::punk::args::eg $resolved_id]
set docid [dict get $resolveinfo docid]
set result [::punk::args::eg $docid]
} }
@ -3849,7 +3929,30 @@ tcl::namespace::eval punk::ns {
#puts stderr [textblock::frame $syn] #puts stderr [textblock::frame $syn]
#set replaceuntil [expr {[llength $resolved_id]-1}] #set replaceuntil [expr {[llength $resolved_id]-1}]
set replaceuntil [expr {[llength $resolved_id]-1+$excess}] set replaceuntil [expr {[llength $resolved_id]-1+$excess}]
append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n #append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n ;#don't use join - will destroy braced sets
#e.g see s dict filter
#treating a somewhat arbitrary string $synline as a list here is a bit risky
#todo - consider always using 'punk::args::synopsis -return dict' and operating on that list to rebuild string - REVIEW
set adjusted_synline [lreplace $synline 0 $replaceuntil {*}$resolved_args] ;#don't use join - will destroy braced sets
#however - we don't want the extra bracing around ansi elements caused by list rep!
#::dict filter {dictionaryValue} script {keyVariable valueVariable} {script}
#vs
#::dict filter dictionaryValue script {keyVariable valueVariable} script
#(due to ansi in dictionaryValue and trailing script)
#manually join based on list length review
set lineout ""
foreach part $adjusted_synline {
if {[llength $part] == 1} {
append lineout " " $part
} else {
append lineout " " [list $part]
}
}
#must be no leading space for tests in test::punk::args synopsis.test
append resultstr [string trim $lineout] \n
} }
} }
set resultstr [string trimright $resultstr \n] set resultstr [string trimright $resultstr \n]
@ -4620,6 +4723,7 @@ tcl::namespace::eval punk::ns {
@values @values
}] }]
set i 0 set i 0
#for 9.1+ can use -integer
foreach a $arglist { foreach a $arglist {
switch -- [llength $a] { switch -- [llength $a] {
1 { 1 {
@ -4663,7 +4767,7 @@ tcl::namespace::eval punk::ns {
lassign $impl generaltype mname location methodtype lassign $impl generaltype mname location methodtype
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
dict set choiceinfodict $cmd {{doctype objectmethod}} dict set choiceinfodict $cmd {{doctype objectmethod}}
@ -4679,12 +4783,10 @@ tcl::namespace::eval punk::ns {
dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]]
} }
} }
if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} {
if {[punk::args::id_exists $id]} { #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]"
#dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" dict lappend choiceinfodict $cmd {doctype punkargs}
dict lappend choiceinfodict $cmd {doctype punkargs} dict lappend choiceinfodict $cmd [list subhelp {*}$id]
dict lappend choiceinfodict $cmd [list subhelp {*}$id]
}
} }
break break
} }
@ -4842,7 +4944,6 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by arginfo) "(autogenerated by arginfo)
ensemble: ${$origin}" ensemble: ${$origin}"
@leaders -min 1
}] }]
if {[llength $parameters] == 0} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" append argdef \n "@leaders -min 1"
@ -4852,6 +4953,7 @@ tcl::namespace::eval punk::ns {
append argdef \n "$p -type string -help { (leading ensemble parameter)}" append argdef \n "$p -type string -help { (leading ensemble parameter)}"
} }
} }
append argdef \n "@values -unnamed true"
append argdef \n $vline append argdef \n $vline
punk::args::define $argdef punk::args::define $argdef
} }

2
src/bootsupport/modules/punk/path-0.1.0.tm

@ -182,7 +182,7 @@ namespace eval punk::path {
proc normjoin {args} { proc normjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}] set args [lmap a $args {string map "\\\\ /" $a}]
set path [plainjoin {*}$args] set path [plainjoin {*}$args]
switch -exact $path { switch -exact -- $path {
"" { "" {
return "" return ""
} }

125
src/bootsupport/modules/textblock-0.1.3.tm

@ -4531,10 +4531,10 @@ tcl::namespace::eval textblock {
-help "existing table object to use" -help "existing table object to use"
-action -default "append" -choices {append replace}\ -action -default "append" -choices {append replace}\
-help "row insertion method if existing -table is supplied -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column" if append is chosen the new values will always start at the first column"
-title -type string -help\ -title -type string -help\
"Title to display overlayed on top edge of table. "Title to display overlayed on top edge of table.
Will not be visible if -show_edge is false" Will not be visible if -show_edge is false"
-titlealign -type string -choices {left centre right} -titlealign -type string -choices {left centre right}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame" -help "frame type or dict for custom frame"
@ -4545,32 +4545,32 @@ tcl::namespace::eval textblock {
-help "Show vertical table separators" -help "Show vertical table separators"
-show_hseps -default "" -type boolean\ -show_hseps -default "" -type boolean\
-help "Show horizontal table separators -help "Show horizontal table separators
(default 0 if no existing -table supplied)" (default 0 if no existing -table supplied)"
-colheaders -default "" -type list\ -colheaders -default "" -type list\
-help {list of lists. list of column header values. Outer list must match number of columns. -help {list of lists. list of column header values. Outer list must match number of columns.
A table A table
e.g single header row: -colheaders {{column_a} {column_b} {column_c}} e.g single header row: -colheaders {{column_a} {column_b} {column_c}}
e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}} e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}}
Note that each element of the outer list is itself a list so: Note that each element of the outer list is itself a list so:
-colheaders {"column a" "column b" "column c"} -colheaders {"column a" "column b" "column c"}
Is likely not the right format if it was intended to have a single header row where the Is likely not the right format if it was intended to have a single header row where the
column titles contain spaces. column titles contain spaces.
The correct syntax for that would be: The correct syntax for that would be:
-colheaders {{"column a"} {"column b"} {"column c"}} -colheaders {{"column a"} {"column b"} {"column c"}}
For spanning header cells - use 'set t [list_as_table -return tableobject ...]' For spanning header cells - use 'set t [list_as_table -return tableobject ...]'
and then something like: and then something like:
$t configure_header 1 -colspans {3 0 0}; $t print $t configure_header 1 -colspans {3 0 0}; $t print
} }
-header -default "" -type list -multiple 1\ -header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row. -help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns" The number of values for each must be <= number of columns"
-show_header -type boolean\ -show_header -type boolean\
-help "Whether to show a header row. -help "Whether to show a header row.
Omit for unspecified/automatic, Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied." in which case it will display only if -headers list was supplied."
-columns -default "" -type integer\ -columns -default "" -type integer\
-help "Number of table columns -help "Number of table columns
Will default to 2 if not using an existing -table object" 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" datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value"
@ -4810,19 +4810,19 @@ tcl::namespace::eval textblock {
-choices {horizontal vertical}\ -choices {horizontal vertical}\
-help\ -help\
"Direction of character increments. "Direction of character increments.
When rainbow is in the colour list, When rainbow is in the colour list,
the colour stripes will be oriented the colour stripes will be oriented
in this direction. in this direction.
" "
@values -min 0 -max 1 @values -min 0 -max 1
colour -type list -default {} -optional 1 -help\ colour -type list -default {} -optional 1 -help\
"List of Ansi colour names "List of Ansi colour names
e.g. testblock -size 10 {white Red} e.g. testblock -size 10 {white Red}
produces a block of character 10x10 produces a block of character 10x10
with white text on red bacground with white text on red bacground
The additional pseudo-color 'rainbow' The additional pseudo-color 'rainbow'
is available. is available.
" "
} }
@ -5717,6 +5717,7 @@ tcl::namespace::eval textblock {
" "
-ansiresets -type any -default auto -ansiresets -type any -default auto
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
@values
blocks -type any -multiple 1 blocks -type any -multiple 1
} }
@ -6095,6 +6096,7 @@ tcl::namespace::eval textblock {
proc welcome_test {} { proc welcome_test {} {
package require punk::ansi package require punk::ansi
package require patternpunk
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]] set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]]
# Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com # Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com
set table [[textblock::spantest] print] set table [[textblock::spantest] print]
@ -6108,6 +6110,7 @@ tcl::namespace::eval textblock {
proc example {args} { proc example {args} {
set opts [tcl::dict::create -forcecolour 0] set opts [tcl::dict::create -forcecolour 0]
package require patternpunk
foreach {k v} $args { foreach {k v} $args {
switch -- $k { switch -- $k {
-forcecolour { -forcecolour {
@ -7981,54 +7984,55 @@ tcl::namespace::eval textblock {
frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\"" frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\""
-checkargs -default 1 -type boolean\ -checkargs -default 1 -type boolean\
-help "If true do extra argument checks and -help "If true do extra argument checks and
provide more comprehensive error info. provide more comprehensive error info.
As the argument parser loads around 16 default frame As the argument parser loads around 16 default frame
samples dynamically, this can add add up as each may samples dynamically, this can add add up as each may
take 10s of microseconds. For many-framed tables take 10s of microseconds. For many-framed tables
and other applications this can add up. and other applications this can add up.
Set false for performance improvement." Set false for performance improvement."
-etabs -default 0\ -etabs -default 0\
-help "expanding tabs - experimental/unimplemented." -help "expanding tabs - experimental/unimplemented."
#review - -choicelabels placeholder dollarsign of textblock::frame_samples must be left aligned with -choicelabels
-type -default light\ -type -default light\
-type dict\ -type dict\
-typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\ -typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\
-choices {${[textblock::frametypes]}}\ -choices {${[textblock::frametypes]}}\
-choicerestricted 0 -choicecolumns 8\ -choicerestricted 0 -choicecolumns 8\
-choicelabels { -choicelabels {
${[textblock::frame_samples]} ${[textblock::frame_samples]}
}\ }\
-help "Type of border for frame." -help "Type of border for frame."
-boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. -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. passing an empty string will result in no box, but title/subtitle will still appear if supplied.
${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}"
-boxmap -default {} -type dict -boxmap -default {} -type dict
-joins -default {} -type list -joins -default {} -type list
-title -default "" -type string -regexprefail {\n}\ -title -default "" -type string -regexprefail {\n}\
-help "Frame title placed on topbar - no newlines. -help "Frame title placed on topbar - no newlines.
May contain ANSI - no trailing reset required. May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
-titlealign -default "centre" -choices {left centre right} -titlealign -default "centre" -choices {left centre right}
-subtitle -default "" -type string -regexprefail {\n}\ -subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines -help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required." May contain Ansi - no trailing reset required."
-subtitlealign -default "centre" -choices {left centre right} -subtitlealign -default "centre" -choices {left centre right}
-width -default "" -type int\ -width -default "" -type int\
-help "Width of resulting frame including borders. -help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content." If omitted or empty-string, the width will be determined automatically based on content."
-height -default "" -type int\ -height -default "" -type int\
-help "Height of resulting frame including borders." -help "Height of resulting frame including borders."
-ansiborder -default "" -type ansistring\ -ansiborder -default "" -type ansistring\
-help "Ansi escape sequence to set border attributes. -help "Ansi escape sequence to set border attributes.
${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents
e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}"
-ansibase -default "" -type ansistring\ -ansibase -default "" -type ansistring\
-help "Default ANSI attributes within frame." -help "Default ANSI attributes within frame."
-blockalign -default centre -choices {left right centre}\ -blockalign -default centre -choices {left right centre}\
-help "Alignment of the content block within the frame." -help "Alignment of the content block within the frame."
-pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background
extends within the content block inside the frame. extends within the content block inside the frame.
Has no effect if no ANSI in content." Has no effect if no ANSI in content."
-textalign -default left -choices {left right centre}\ -textalign -default left -choices {left right centre}\
-help "Alignment of text within the content block. (centre unimplemented)" -help "Alignment of text within the content block. (centre unimplemented)"
-ellipsis -default 1 -type boolean\ -ellipsis -default 1 -type boolean\
@ -8037,16 +8041,16 @@ tcl::namespace::eval textblock {
-buildcache -default 1 -type boolean -buildcache -default 1 -type boolean
-crm_mode -default 0 -type boolean\ -crm_mode -default 0 -type boolean\
-help "Show ANSI control characters within frame contents. -help "Show ANSI control characters within frame contents.
(Control Representation Mode) (Control Representation Mode)
Frame width doesn't adapt and content may be truncated Frame width doesn't adapt and content may be truncated
so -width may need to be manually set to display more." 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\ contents -default "" -type string\
-help "Frame contents - may be a block of text containing newlines and ANSI. -help "Frame contents - may be a block of text containing newlines and ANSI.
Text may be 'ragged' - ie unequal line-lengths. Text may be 'ragged' - ie unequal line-lengths.
No trailing ANSI reset required. No trailing ANSI reset required.
${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}"
} }
} }
@ -8915,15 +8919,16 @@ tcl::namespace::eval textblock {
} }
} }
punk::args::define { punk::args::define {
@id -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 -max_cross_size -default 0 -type integer -help\
Only cross sizes that divide the size of the overall block will be used. "Largest size cross to use to make up the block
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. Only cross sizes that divide the size of the overall block will be used.
Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) 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.
If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. 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 "
size -default 1 -type integer @values -min 0 -max 1
size -default 1 -type integer
} }
proc gcross {args} { proc gcross {args} {
set argd [punk::args::parse $args withid ::textblock::gcross] set argd [punk::args::parse $args withid ::textblock::gcross]

50
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm

@ -577,18 +577,18 @@ namespace eval punk {
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
-returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels { -returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels {
"matched"\ "matched"\
" Return only lines that matched." " Return only lines that matched."
"breaksandmatches"\ "breaksandmatches"\
" Return configured --break= lines in between non-consecutive matches" " Return configured --break= lines in between non-consecutive matches"
"all"\ "all"\
" Return all lines. " Return all lines.
This has a similar effect to the 'grep' trick of matching on 'pattern|$' This has a similar effect to the 'grep' trick of matching on 'pattern|$'
(The $ matches all lines that have an end; ie all lines, but there is no (The $ matches all lines that have an end; ie all lines, but there is no
associated character to which to apply highlighting) associated character to which to apply highlighting)
except that when instead using -returnlines all with --line-number, the * except that when instead using -returnlines all with --line-number, the *
indicator after the linenumber will only be highlighted for lines with matches, indicator after the linenumber will only be highlighted for lines with matches,
and the following matchcount will indicate zero for non-matching lines." and the following matchcount will indicate zero for non-matching lines."
} }
-B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num
-C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\ -C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\
@ -609,9 +609,9 @@ namespace eval punk {
" "
-ansistrip -type none -help\ -ansistrip -type none -help\
"Strip all ansi codes from the input string before processing. "Strip all ansi codes from the input string before processing.
This is not necessary for regex matching purposes, as the matching is always This is not necessary for regex matching purposes, as the matching is always
performed on the ansistripped characters anyway, but by stripping ANSI, the performed on the ansistripped characters anyway, but by stripping ANSI, the
result only has the ANSI supplied by the -highlight option." result only has the ANSI supplied by the -highlight option."
#-n|--line-number as per grep utility, except that we include a * for matches #-n|--line-number as per grep utility, except that we include a * for matches
-n|--line-number -type none -help\ -n|--line-number -type none -help\
@ -7153,8 +7153,8 @@ namespace eval punk {
-exclude_punctlines -default 1 -type boolean -exclude_punctlines -default 1 -type boolean
-show_largest -default 0 -type integer -help\ -show_largest -default 0 -type integer -help\
"Report the top largest linecount files. "Report the top largest linecount files.
The value represents the number of files The value represents the number of files
to report on." to report on."
} " } "
#we could map away whitespace and use string is punct - but not as flexible? review #we could map away whitespace and use string is punct - but not as flexible? review
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
@ -7384,7 +7384,7 @@ namespace eval punk {
#dict of list-len 2 is equiv to dict of dict with one keyval pair #dict of list-len 2 is equiv to dict of dict with one keyval pair
#-------------------------------- #--------------------------------
#!!!todo fix - linedict is unfinished and non-functioning #!!!todo fix - linedict is unfinished and non-functioning
#linedict based on indents #linedict based on indents
@ -7615,23 +7615,23 @@ namespace eval punk {
-showcount -type boolean -default 1 -help\ -showcount -type boolean -default 1 -help\
"Display a leading indicator in brackets showing the number of arg values present." "Display a leading indicator in brackets showing the number of arg values present."
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels {
0 "Strip ANSI codes from display 0 " Strip ANSI codes from display
of values. The disply output will of values. The disply output will
still be colourised if -ansibase has still be colourised if -ansibase has
not been set to empty string or not been set to empty string or
[a+ normal]. The stderr or stdout [a+ normal]. The stderr or stdout
channels may also have an ansi colour. channels may also have an ansi colour.
(see 'colour off' or punk::config)" (see 'colour off' or punk::config)"
1 "Leave value as is" 1 " Leave value as is"
2 "Display the ANSI codes and 2 " Display the ANSI codes and
other control characters inline other control characters inline
with replacement indicators. with replacement indicators.
e.g esc, newline, space, tab" e.g esc, newline, space, tab"
VIEW "Alias for 2" VIEW " Alias for 2"
3 "Display as per 2 but with 3 " Display as per 2 but with
colourised ANSI replacement codes." colourised ANSI replacement codes."
VIEWCODES "Alias for 3" VIEWCODES " Alias for 3"
4 "Display ANSI and control 4 " Display ANSI and control
chars in default colour, but chars in default colour, but
apply the contained ansi to apply the contained ansi to
the text portions so they display the text portions so they display

45
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -3287,31 +3287,32 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#indent of 1 space is important for clarity in i -return string a+ output #indent of 1 space is important for clarity in i -return string a+ output
dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m" dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m"
} }
set SGR_help\ set SGR_help\
{SGR code from the list below, or an integer corresponding to the code e.g 31 = red. {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. A leading capital letter indicates a codename applies to the background colour.
Other accepted codes are: Other accepted codes are:
term-<int> Term-<int> foreground/background where int is 0-255 terminal color term-<int> Term-<int> foreground/background where int is 0-255 terminal color
term-<termcolour> Term-<termcolour> foreground/background term-<termcolour> Term-<termcolour> foreground/background
web-<webcolour> Web-<webcolour> web-<webcolour> Web-<webcolour>
x11-<xllcolour> X11-<x11colour> x11-<xllcolour> X11-<x11colour>
tk-<tkcolour> Tk-<tkcolour> tk-<tkcolour> Tk-<tkcolour>
rgb-<r>-<g>-<b> Rgb-<r>-<g>-<b> foreground/background where <r> <g> <b> are the rgb-<r>-<g>-<b> Rgb-<r>-<g>-<b> foreground/background where <r> <g> <b> are the
0-255 int values for red, green and blue. 0-255 int values for red, green and blue.
rgb#<hexcode> Rgb#<hexcode> where <hexcode> is a 6 char hex colour e.g rgb#C71585 rgb#<hexcode> Rgb#<hexcode> where <hexcode> is a 6 char hex colour e.g rgb#C71585
The acceptable values for colours can be queried using The acceptable values for colours can be queried using
punk::ansi::a? term punk::ansi::a? term
punk::ansi::a? web punk::ansi::a? web
punk::ansi::a? x11 punk::ansi::a? x11
punk::ansi::a? tk punk::ansi::a? tk
Example to set foreground red and background cyan followed by a reset: Example to set foreground red and background cyan followed by a reset:
set str \"[a+ red Cyan]sample text[a]\" set str \"[a+ red Cyan]sample text[a]\"
} }
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::punk::ansi::a+ @id -id ::punk::ansi::a+
@ -3325,6 +3326,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
-choicelabels {%choicelabels%}\ -choicelabels {%choicelabels%}\
-choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\
"%SGR_help%" "%SGR_help%"
#note SGR_help string has same level of indent as placeholder
}]] }]]
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -5835,8 +5837,11 @@ tcl::namespace::eval punk::ansi::ta {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::ansi::ta}] #[subsection {Namespace punk::ansi::ta}]
#[para] text ansi functions #[para] text ansi functions
#[para] based on but not identical to the Perl Text Ansi module: #[para] based on the API but not identical to the Perl Text Ansi module: Text::ANSI::Util
#[para] https://metacpan.org/pod/Text::ANSI::Util
#[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm
#[para] These functions are not based on the source code of the perl functions, but the documented input and output
#[para] so algorithms and performance may differ.
#[list_begin definitions] #[list_begin definitions]
tcl::namespace::path ::punk::ansi tcl::namespace::path ::punk::ansi
namespace export detect detect_in_list detect_sgr extract length split_codes split_at_codes split_codes_single namespace export detect detect_in_list detect_sgr extract length split_codes split_at_codes split_codes_single
@ -8137,7 +8142,7 @@ tcl::namespace::eval punk::ansi::ansistring {
#return empty string for each index that is out of range #return empty string for each index that is out of range
#review - this is possibly too slow to be very useful as is. #review - this is possibly too slow to be very useful as is.
# consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string
#see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. #see also punk::lib::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them.
proc INDEXABSOLUTE {string args} { proc INDEXABSOLUTE {string args} {
set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most) set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most)
set testindices [list] set testindices [list]
@ -8166,6 +8171,8 @@ tcl::namespace::eval punk::ansi::ansistring {
} else { } else {
set offset 0 set offset 0
} }
#2025 -BROKEN - doesn't handle indices with both + and -
#see updated punk::lib::lindex_resolve
#by now, if op = + then offset = 0 so we only need to handle the minus case #by now, if op = + then offset = 0 so we only need to handle the minus case
if {$payload_len == -1} { if {$payload_len == -1} {
set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal

10862
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm

File diff suppressed because it is too large Load Diff

3017
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm

File diff suppressed because it is too large Load Diff

4570
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm

File diff suppressed because it is too large Load Diff

4
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -150,8 +150,8 @@ namespace eval punk::mix::commandset::module {
"Create a new module file in the appropriate folder within src/modules. "Create a new module file in the appropriate folder within src/modules.
If the name given in the module argument is namespaced, If the name given in the module argument is namespaced,
the necessary subfolder(s) will be used or created." the necessary subfolder(s) will be used or created."
-project -optional 1 -project -optional 1
-version -default "0.1.0" -help\ -version -type packageversion -default "0.1.0" -help\
"version to use if not specified as part of the module argument. "version to use if not specified as part of the module argument.
If a version is specified in the module argument as well as in -version If a version is specified in the module argument as well as in -version
the higher version number will be used. the higher version number will be used.

272
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

@ -491,42 +491,50 @@ tcl::namespace::eval punk::ns {
lassign $cindices cstart cend lassign $cindices cstart cend
append p [string range $nspath $s $cstart-1] append p [string range $nspath $s $cstart-1]
set numcolons [expr {$cend - $cstart + 1}] set numcolons [expr {$cend - $cstart + 1}]
if {$numcolons == 1} { #assert numcolons != 0 due to regexp +
#internal colon switch -exact -- $numcolons {
append p : 2 - 4 {
set s [expr {$cend+1}] #4 is a somewhat common case - could handle with default branch but may as well short circuit here.
continue
} elseif {$numcolons == 2} {
lappend parts $p
set p ""
set s [expr {$cend+1}]
continue
} elseif {($numcolons -1) % 3 == 0} {
set numcolons [expr {$numcolons -2}]
}
#assert numcolons >=3 and not in 4,7,10,13,16,19,22... sequence
if {$numcolons % 3 == 0} {
#if numcolons % 3 == 0 we have a leading colon left for next ns
#this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y
#we resolve with allowing leading colons only for each ns.
set singlec_count [expr {($numcolons /3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p lappend parts $p
set p ""
set s [expr {$cend+1}]
#continue
} }
set p ":" 1 {
set s [expr {$cend+1}] #internal colon
continue append p :
} else { set s [expr {$cend+1}]
set singlec_count [expr {(($numcolons +1)/3) -1}] #continue
if {$singlec_count > 0} { }
lappend parts $p {*}[lrepeat $singlec_count :] default {
} else { if {($numcolons -1) %3 == 0} {
lappend parts $p set numcolons [expr {$numcolons -2}]
}
#assert numcolons >=4 and not in 7,10,13,16,19,22... sequence
if {$numcolons % 3 == 0} {
#if numcolons % 3 == 0 we have a leading colon left for next ns
#this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y
#we resolve with allowing leading colons only for each ns.
set singlec_count [expr {($numcolons /3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p
}
set p ":"
set s [expr {$cend+1}]
#continue
} else {
set singlec_count [expr {(($numcolons +1)/3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p
}
set p ""
set s [expr {$cend+1}]
}
} }
set p ""
set s [expr {$cend+1}]
} }
} }
if {$cend < ([string length $nspath]-1)} { if {$cend < ([string length $nspath]-1)} {
@ -695,6 +703,39 @@ tcl::namespace::eval punk::ns {
} }
proc nsglob_as_re {glob} { proc nsglob_as_re {glob} {
#any segment that is not just * must match exactly one segment in the path
set pats [list]
foreach seg [nsparts_cached $glob] {
switch -exact -- $seg {
"" {
lappend pats ""
}
* {
#review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed
#lappend pats {[^:]*}
#negative lookahead
#any number of chars not followed by ::, followed by any number of non :
lappend pats {(?:.(?!::))*[^:]*}
}
** {
lappend pats {.*}
}
default {
set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
#set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg]
set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg]
lappend pats "$pat"
} else {
lappend pats "$seg"
}
}
}
}
return "^[join $pats ::]\$"
}
#obsolete
proc nsglob_as_re1 {glob} {
#any segment that is not just * must match exactly one segment in the path #any segment that is not just * must match exactly one segment in the path
set pats [list] set pats [list]
foreach seg [nsparts_cached $glob] { foreach seg [nsparts_cached $glob] {
@ -2984,7 +3025,7 @@ tcl::namespace::eval punk::ns {
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
#private? todo? #private? todo?
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
#dict set choiceinfodict $cmd {{doctype ooo}} #dict set choiceinfodict $cmd {{doctype ooo}}
@ -3042,9 +3083,10 @@ tcl::namespace::eval punk::ns {
@cmd -name "${$objtype}: ${$origin}" -help\ @cmd -name "${$objtype}: ${$origin}" -help\
"Instance of class: ${$class} (info autogenerated by generate_autodef) "Instance of class: ${$class} (info autogenerated by generate_autodef)
(see 'i punk::ns::Cmark' for symbols)" (see 'i punk::ns::Cmark' for symbols)"
@leaders -min 1 @leaders -min 1 -max 1
}] }]
append argdef \n $vline append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
@ -3148,15 +3190,15 @@ tcl::namespace::eval punk::ns {
dict for {sub subwhat} $subcommand_dict { dict for {sub subwhat} $subcommand_dict {
if {[llength $subwhat] > 1} { if {[llength $subwhat] > 1} {
#TODO - resolve using cmdinfo? #TODO - resolve using cmdinfo?
puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" puts stderr "generate_autodef warning: subcommand $sub points to multiword target $subwhat - TODO"
} }
set targetfirstword [lindex $subwhat 0] set targetfirstword [lindex $subwhat 0]
set targetinfo [cmdwhich $targetfirstword] set targetinfo [cmdwhich $targetfirstword]
set targetorigin [dict get $targetinfo origin] set targetorigin [dict get $targetinfo origin]
set targetcmdtype [dict get $targetinfo origintype] set targetcmdtype [dict get $targetinfo origintype]
set nstarget [nsprefix $targetorigin] set nstarget [nsprefix $targetorigin]
# -resolved-
dict set choiceinfodict $sub [list [list resolved $subwhat]] dict set choiceinfodict $sub [list [list ensemblesubtarget {*}$subwhat]]
dict lappend choiceinfodict $sub [list doctype $targetcmdtype] dict lappend choiceinfodict $sub [list doctype $targetcmdtype]
if {[punk::args::id_exists [list $origin $sub]]} { if {[punk::args::id_exists [list $origin $sub]]} {
@ -3183,17 +3225,18 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by generate_autodef) "(autogenerated by generate_autodef)
ensemble: ${$origin}" ensemble: ${$origin}"
@leaders -min 1
}] }]
#we must put a max on @leaders so that any subsequent arguments are not parsed as leaders for an ensemble root docid
if {[llength $parameters] == 0} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" append argdef \n "@leaders -min 1 -max 1"
} else { } else {
append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" append argdef \n "@leaders -min [expr {[llength $parameters]+1}] -max [expr {[llength $parameters]+1}]"
foreach p $parameters { foreach p $parameters {
append argdef \n "$p -type string -help { (leading ensemble parameter)}" append argdef \n "$p -type string -ensembleparameter 1 -help { (leading ensemble parameter)}"
} }
} }
append argdef \n $vline append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
proc { proc {
@ -3325,6 +3368,13 @@ tcl::namespace::eval punk::ns {
set cinfo [cmdwhich $finalcommand] set cinfo [cmdwhich $finalcommand]
set origin [dict get $cinfo origin] set origin [dict get $cinfo origin]
set cmdtype [dict get $cinfo origintype] set cmdtype [dict get $cinfo origintype]
if {$cmdtype eq "notfound" && [llength $finalcommand] > 1} {
#e.g see curried command produced by 'punk::netbox::man <apicontextid> new'
set next [list {*}$finalcommand {*}$remainingargs]
if {$next ne $args} {
return [cmdinfo {*}$next]
}
}
return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack] return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack]
} }
proc cmd_traverse {ns formid args} { proc cmd_traverse {ns formid args} {
@ -3493,6 +3543,7 @@ tcl::namespace::eval punk::ns {
#we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs. #we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs.
#(would not support shor-form prefix of subcommand - even if the proc implementation did) #(would not support shor-form prefix of subcommand - even if the proc implementation did)
set docid_exists 0 set docid_exists 0
set eparams [list]
if {[punk::args::id_exists "$origin [lindex $args $i]"]} { if {[punk::args::id_exists "$origin [lindex $args $i]"]} {
set a [lindex $args $i] set a [lindex $args $i]
#review - tests? #review - tests?
@ -3504,7 +3555,7 @@ tcl::namespace::eval punk::ns {
set origin [list $origin $a] set origin [list $origin $a]
incr i incr i
set queryargs [lrange $args $i end] set queryargs [lrange $args $i end]
set resolvedargs [list $a] ;#even though the set resolvedargs [list $a] ;#
set queryargs_untested $queryargs set queryargs_untested $queryargs
} elseif {[punk::args::id_exists $docid]} { } elseif {[punk::args::id_exists $docid]} {
set docid_exists 1 set docid_exists 1
@ -3543,6 +3594,12 @@ tcl::namespace::eval punk::ns {
set leadernames [dict get $spec FORMS $fid LEADER_NAMES] set leadernames [dict get $spec FORMS $fid LEADER_NAMES]
set optnames [dict get $spec FORMS $fid OPT_NAMES] set optnames [dict get $spec FORMS $fid OPT_NAMES]
set valnames [dict get $spec FORMS $fid VAL_NAMES] set valnames [dict get $spec FORMS $fid VAL_NAMES]
#review - see 'string is word' vs 'string is wordchar' behaviour due to documented common opts/vals in the parent ensemble-like command '::tcl::string::is'
#we should be preferring the most specific documentation
#Alternatively - we could adjust the 'string is' documentation to have @values -unnamed true
#and put the common info in the help for <unnamed> - but that would give us an inferior synopsis for 'string is'
if {![llength $optnames] && ![llength $valnames]} { if {![llength $optnames] && ![llength $valnames]} {
#set queryargs [lrange $args $i end] #set queryargs [lrange $args $i end]
@ -3574,8 +3631,26 @@ tcl::namespace::eval punk::ns {
if {$is_ensembleparam} { if {$is_ensembleparam} {
lappend resolvedargs $q lappend resolvedargs $q
lpop queryargs_untested 0 lpop queryargs_untested 0
lappend eparams $q
puts stderr "---> cmd_traverse ensembleparam $q ($lname)"
puts stderr "arginfo: $arginfo"
puts stderr "---> eparams: $eparams"
puts stderr "---> existing args: $args"
#ledit queryargs_untested 0 0 #ledit queryargs_untested 0 0
#review - add tests #review - add tests
#todo - put param in untested (multiple ensembleparams??)
#ledit queryargs_untested 1 0 $q ;#(linsert)
#set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand
#if {$posn_subcommand > 0} {
# set params [lrange $queryargs 0 $posn_subcommand-1]
# set remaining_queryargs [lrange $queryargs $posn_subcommand end]
#} else {
# set params [list]
# set remaining_queryargs $queryargs
#}
incr i
continue continue
} }
if {![llength $allchoices]} { if {![llength $allchoices]} {
@ -3585,7 +3660,7 @@ tcl::namespace::eval punk::ns {
#ledit queryargs_untested 0 0 #ledit queryargs_untested 0 0
#jjj #jjj
#continue #continue
return [list 3 $origin $resolvedargs $queryargs_untested $docid] return [list 3 $origin $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
break break
} }
set resolved_q [tcl::prefix::match -error "" $allchoices $q] set resolved_q [tcl::prefix::match -error "" $allchoices $q]
@ -3610,9 +3685,9 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
foreach inf $cinfo { foreach inf $cinfo {
switch -- [lindex $inf 0] { switch -- [lindex $inf 0] {
"resolved" { "subhelp" {
#punk::args::ensemble_subcommands_definition
set mapped_subcmd [lrange $inf 1 end] set mapped_subcmd [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3630,11 +3705,14 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" set docid ""
} }
#puts stderr "cmd_traverse 'resolved' $mapped_subcmd" #allow subhelp override - todo: review/document rationale/usecases
break
} }
"subhelp" { "ensemblesubtarget" {
# -resolved-
#punk::args::ensemble_subcommands_definition
#This could be a list representing some other ensemble or command with pre-included arguments
set mapped_subcmd [lrange $inf 1 end] set mapped_subcmd [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3652,8 +3730,16 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" set docid ""
} }
#allow subhelp override - todo: review/document rationale/usecases #puts stderr "cmd_traverse 'resolved' $mapped_subcmd"
break }
"doctype" {
set d [lindex $inf 1]
switch -- $d {
"classmethod" {
}
"coremethod" {
}
}
} }
} }
} }
@ -3668,23 +3754,9 @@ tcl::namespace::eval punk::ns {
set mapped_subcmd "$raw_origin $resolved_q" set mapped_subcmd "$raw_origin $resolved_q"
set docid $mapped_subcmd set docid $mapped_subcmd
} else { } else {
#REVIEW - there is no reason to assume a subcommand (even in an ensemble) #NOTE there is no reason to assume a subcommand (even in an ensemble)
#will be located at "${raw_origin}::$resolved_q" #will be located at "${raw_origin}::$resolved_q"
#ensemble -map could point resolved_q somewhere else entirely #ensemble -map could point resolved_q somewhere else entirely
#punk::args::update_definitions [list $raw_origin]
#if {[punk::args::id_exists "${raw_origin}::$resolved_q"]} {
# set mapped_subcmd "${raw_origin}::$resolved_q"
# set docid $mapped_subcmd
#} else {
# if {![punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# namespace eval $ns [list punk::ns::generate_autodef "${raw_origin}::$resolved_q"]
# }
# if {[punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# set mapped_subcmd ${raw_origin}::$resolved_q
# set docid (autodef)${raw_origin}::$resolved_q
# }
#}
} }
} }
#puts "----------$mapped_subcmd" #puts "----------$mapped_subcmd"
@ -3695,13 +3767,18 @@ tcl::namespace::eval punk::ns {
#punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] #punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {[llength $queryargs_untested] == 0} { if {[llength $queryargs_untested] == 0} {
return [list 6 $mapped_subcmd $resolvedargs $queryargs_untested $docid] return [list 6 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
} }
set origin [yield [list 0 $mapped_subcmd $resolvedargs $queryargs_untested $docid]] set origin [yield [list 0 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]]
#set resolvedargs [list] #set resolvedargs [list]
incr i [expr {-1 * [llength $resolvedargs]+1}] #incr i [expr {-1 * [llength $resolvedargs]+1}] ;#wrong e.g test trace add execution blah enterstep cmd
#puts stderr "... yield-result $origin i:$i" #JJJ
#puts stderr "... yield-result $origin i:$i args: $args"
ledit args $i+1 $i {*}$eparams
set eparams [list]
set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]] set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]]
set origin [dict get $whichinfo origin] set origin [dict get $whichinfo origin]
@ -3719,15 +3796,15 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
} }
break break ;#out of foreach q $queryargs ...
} else { } else {
#test with: i namespace which -v x #test with: i namespace which -v x
return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid] return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid]
} }
} } ;#end loop foreach q $queryargs lname $leadernames_matched
} else { } else {
#?? #??
puts stderr "cmdinfo.cmd_traverse returning 8 $origin $resolvedargs [lrange $args $i end] $docid" #puts stderr "cmdinfo.cmd_traverse returning 8 origin: $origin resolved: $resolvedargs remaining: [lrange $args $i end] docid: $docid"
return [list 8 $origin $resolvedargs [lrange $args $i end] $docid] return [list 8 $origin $resolvedargs [lrange $args $i end] $docid]
} }
} else { } else {
@ -3758,7 +3835,8 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::forms] set argd [::punk::args::parse $args withid ::punk::ns::forms]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context
set id [dict get $resolveinfo origin] #set id [dict get $resolveinfo origin]
set id [dict get $resolveinfo docid]
::punk::args::forms $id ::punk::args::forms $id
} }
@ -3778,8 +3856,10 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::eg] set argd [::punk::args::parse $args withid ::punk::ns::eg]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context
set resolved_id [dict get $resolveinfo origin] #set resolved_id [dict get $resolveinfo origin]
set result [::punk::args::eg $resolved_id] #set result [::punk::args::eg $resolved_id]
set docid [dict get $resolveinfo docid]
set result [::punk::args::eg $docid]
} }
@ -3849,7 +3929,30 @@ tcl::namespace::eval punk::ns {
#puts stderr [textblock::frame $syn] #puts stderr [textblock::frame $syn]
#set replaceuntil [expr {[llength $resolved_id]-1}] #set replaceuntil [expr {[llength $resolved_id]-1}]
set replaceuntil [expr {[llength $resolved_id]-1+$excess}] set replaceuntil [expr {[llength $resolved_id]-1+$excess}]
append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n #append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n ;#don't use join - will destroy braced sets
#e.g see s dict filter
#treating a somewhat arbitrary string $synline as a list here is a bit risky
#todo - consider always using 'punk::args::synopsis -return dict' and operating on that list to rebuild string - REVIEW
set adjusted_synline [lreplace $synline 0 $replaceuntil {*}$resolved_args] ;#don't use join - will destroy braced sets
#however - we don't want the extra bracing around ansi elements caused by list rep!
#::dict filter {dictionaryValue} script {keyVariable valueVariable} {script}
#vs
#::dict filter dictionaryValue script {keyVariable valueVariable} script
#(due to ansi in dictionaryValue and trailing script)
#manually join based on list length review
set lineout ""
foreach part $adjusted_synline {
if {[llength $part] == 1} {
append lineout " " $part
} else {
append lineout " " [list $part]
}
}
#must be no leading space for tests in test::punk::args synopsis.test
append resultstr [string trim $lineout] \n
} }
} }
set resultstr [string trimright $resultstr \n] set resultstr [string trimright $resultstr \n]
@ -4620,6 +4723,7 @@ tcl::namespace::eval punk::ns {
@values @values
}] }]
set i 0 set i 0
#for 9.1+ can use -integer
foreach a $arglist { foreach a $arglist {
switch -- [llength $a] { switch -- [llength $a] {
1 { 1 {
@ -4663,7 +4767,7 @@ tcl::namespace::eval punk::ns {
lassign $impl generaltype mname location methodtype lassign $impl generaltype mname location methodtype
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
dict set choiceinfodict $cmd {{doctype objectmethod}} dict set choiceinfodict $cmd {{doctype objectmethod}}
@ -4679,12 +4783,10 @@ tcl::namespace::eval punk::ns {
dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]]
} }
} }
if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} {
if {[punk::args::id_exists $id]} { #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]"
#dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" dict lappend choiceinfodict $cmd {doctype punkargs}
dict lappend choiceinfodict $cmd {doctype punkargs} dict lappend choiceinfodict $cmd [list subhelp {*}$id]
dict lappend choiceinfodict $cmd [list subhelp {*}$id]
}
} }
break break
} }
@ -4842,7 +4944,6 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by arginfo) "(autogenerated by arginfo)
ensemble: ${$origin}" ensemble: ${$origin}"
@leaders -min 1
}] }]
if {[llength $parameters] == 0} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" append argdef \n "@leaders -min 1"
@ -4852,6 +4953,7 @@ tcl::namespace::eval punk::ns {
append argdef \n "$p -type string -help { (leading ensemble parameter)}" append argdef \n "$p -type string -help { (leading ensemble parameter)}"
} }
} }
append argdef \n "@values -unnamed true"
append argdef \n $vline append argdef \n $vline
punk::args::define $argdef punk::args::define $argdef
} }

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/path-0.1.0.tm

@ -182,7 +182,7 @@ namespace eval punk::path {
proc normjoin {args} { proc normjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}] set args [lmap a $args {string map "\\\\ /" $a}]
set path [plainjoin {*}$args] set path [plainjoin {*}$args]
switch -exact $path { switch -exact -- $path {
"" { "" {
return "" return ""
} }

125
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm

@ -4531,10 +4531,10 @@ tcl::namespace::eval textblock {
-help "existing table object to use" -help "existing table object to use"
-action -default "append" -choices {append replace}\ -action -default "append" -choices {append replace}\
-help "row insertion method if existing -table is supplied -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column" if append is chosen the new values will always start at the first column"
-title -type string -help\ -title -type string -help\
"Title to display overlayed on top edge of table. "Title to display overlayed on top edge of table.
Will not be visible if -show_edge is false" Will not be visible if -show_edge is false"
-titlealign -type string -choices {left centre right} -titlealign -type string -choices {left centre right}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame" -help "frame type or dict for custom frame"
@ -4545,32 +4545,32 @@ tcl::namespace::eval textblock {
-help "Show vertical table separators" -help "Show vertical table separators"
-show_hseps -default "" -type boolean\ -show_hseps -default "" -type boolean\
-help "Show horizontal table separators -help "Show horizontal table separators
(default 0 if no existing -table supplied)" (default 0 if no existing -table supplied)"
-colheaders -default "" -type list\ -colheaders -default "" -type list\
-help {list of lists. list of column header values. Outer list must match number of columns. -help {list of lists. list of column header values. Outer list must match number of columns.
A table A table
e.g single header row: -colheaders {{column_a} {column_b} {column_c}} e.g single header row: -colheaders {{column_a} {column_b} {column_c}}
e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}} e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}}
Note that each element of the outer list is itself a list so: Note that each element of the outer list is itself a list so:
-colheaders {"column a" "column b" "column c"} -colheaders {"column a" "column b" "column c"}
Is likely not the right format if it was intended to have a single header row where the Is likely not the right format if it was intended to have a single header row where the
column titles contain spaces. column titles contain spaces.
The correct syntax for that would be: The correct syntax for that would be:
-colheaders {{"column a"} {"column b"} {"column c"}} -colheaders {{"column a"} {"column b"} {"column c"}}
For spanning header cells - use 'set t [list_as_table -return tableobject ...]' For spanning header cells - use 'set t [list_as_table -return tableobject ...]'
and then something like: and then something like:
$t configure_header 1 -colspans {3 0 0}; $t print $t configure_header 1 -colspans {3 0 0}; $t print
} }
-header -default "" -type list -multiple 1\ -header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row. -help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns" The number of values for each must be <= number of columns"
-show_header -type boolean\ -show_header -type boolean\
-help "Whether to show a header row. -help "Whether to show a header row.
Omit for unspecified/automatic, Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied." in which case it will display only if -headers list was supplied."
-columns -default "" -type integer\ -columns -default "" -type integer\
-help "Number of table columns -help "Number of table columns
Will default to 2 if not using an existing -table object" 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" datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value"
@ -4810,19 +4810,19 @@ tcl::namespace::eval textblock {
-choices {horizontal vertical}\ -choices {horizontal vertical}\
-help\ -help\
"Direction of character increments. "Direction of character increments.
When rainbow is in the colour list, When rainbow is in the colour list,
the colour stripes will be oriented the colour stripes will be oriented
in this direction. in this direction.
" "
@values -min 0 -max 1 @values -min 0 -max 1
colour -type list -default {} -optional 1 -help\ colour -type list -default {} -optional 1 -help\
"List of Ansi colour names "List of Ansi colour names
e.g. testblock -size 10 {white Red} e.g. testblock -size 10 {white Red}
produces a block of character 10x10 produces a block of character 10x10
with white text on red bacground with white text on red bacground
The additional pseudo-color 'rainbow' The additional pseudo-color 'rainbow'
is available. is available.
" "
} }
@ -5717,6 +5717,7 @@ tcl::namespace::eval textblock {
" "
-ansiresets -type any -default auto -ansiresets -type any -default auto
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
@values
blocks -type any -multiple 1 blocks -type any -multiple 1
} }
@ -6095,6 +6096,7 @@ tcl::namespace::eval textblock {
proc welcome_test {} { proc welcome_test {} {
package require punk::ansi package require punk::ansi
package require patternpunk
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]] set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]]
# Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com # Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com
set table [[textblock::spantest] print] set table [[textblock::spantest] print]
@ -6108,6 +6110,7 @@ tcl::namespace::eval textblock {
proc example {args} { proc example {args} {
set opts [tcl::dict::create -forcecolour 0] set opts [tcl::dict::create -forcecolour 0]
package require patternpunk
foreach {k v} $args { foreach {k v} $args {
switch -- $k { switch -- $k {
-forcecolour { -forcecolour {
@ -7981,54 +7984,55 @@ tcl::namespace::eval textblock {
frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\"" frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\""
-checkargs -default 1 -type boolean\ -checkargs -default 1 -type boolean\
-help "If true do extra argument checks and -help "If true do extra argument checks and
provide more comprehensive error info. provide more comprehensive error info.
As the argument parser loads around 16 default frame As the argument parser loads around 16 default frame
samples dynamically, this can add add up as each may samples dynamically, this can add add up as each may
take 10s of microseconds. For many-framed tables take 10s of microseconds. For many-framed tables
and other applications this can add up. and other applications this can add up.
Set false for performance improvement." Set false for performance improvement."
-etabs -default 0\ -etabs -default 0\
-help "expanding tabs - experimental/unimplemented." -help "expanding tabs - experimental/unimplemented."
#review - -choicelabels placeholder dollarsign of textblock::frame_samples must be left aligned with -choicelabels
-type -default light\ -type -default light\
-type dict\ -type dict\
-typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\ -typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\
-choices {${[textblock::frametypes]}}\ -choices {${[textblock::frametypes]}}\
-choicerestricted 0 -choicecolumns 8\ -choicerestricted 0 -choicecolumns 8\
-choicelabels { -choicelabels {
${[textblock::frame_samples]} ${[textblock::frame_samples]}
}\ }\
-help "Type of border for frame." -help "Type of border for frame."
-boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. -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. passing an empty string will result in no box, but title/subtitle will still appear if supplied.
${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}"
-boxmap -default {} -type dict -boxmap -default {} -type dict
-joins -default {} -type list -joins -default {} -type list
-title -default "" -type string -regexprefail {\n}\ -title -default "" -type string -regexprefail {\n}\
-help "Frame title placed on topbar - no newlines. -help "Frame title placed on topbar - no newlines.
May contain ANSI - no trailing reset required. May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
-titlealign -default "centre" -choices {left centre right} -titlealign -default "centre" -choices {left centre right}
-subtitle -default "" -type string -regexprefail {\n}\ -subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines -help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required." May contain Ansi - no trailing reset required."
-subtitlealign -default "centre" -choices {left centre right} -subtitlealign -default "centre" -choices {left centre right}
-width -default "" -type int\ -width -default "" -type int\
-help "Width of resulting frame including borders. -help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content." If omitted or empty-string, the width will be determined automatically based on content."
-height -default "" -type int\ -height -default "" -type int\
-help "Height of resulting frame including borders." -help "Height of resulting frame including borders."
-ansiborder -default "" -type ansistring\ -ansiborder -default "" -type ansistring\
-help "Ansi escape sequence to set border attributes. -help "Ansi escape sequence to set border attributes.
${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents
e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}"
-ansibase -default "" -type ansistring\ -ansibase -default "" -type ansistring\
-help "Default ANSI attributes within frame." -help "Default ANSI attributes within frame."
-blockalign -default centre -choices {left right centre}\ -blockalign -default centre -choices {left right centre}\
-help "Alignment of the content block within the frame." -help "Alignment of the content block within the frame."
-pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background
extends within the content block inside the frame. extends within the content block inside the frame.
Has no effect if no ANSI in content." Has no effect if no ANSI in content."
-textalign -default left -choices {left right centre}\ -textalign -default left -choices {left right centre}\
-help "Alignment of text within the content block. (centre unimplemented)" -help "Alignment of text within the content block. (centre unimplemented)"
-ellipsis -default 1 -type boolean\ -ellipsis -default 1 -type boolean\
@ -8037,16 +8041,16 @@ tcl::namespace::eval textblock {
-buildcache -default 1 -type boolean -buildcache -default 1 -type boolean
-crm_mode -default 0 -type boolean\ -crm_mode -default 0 -type boolean\
-help "Show ANSI control characters within frame contents. -help "Show ANSI control characters within frame contents.
(Control Representation Mode) (Control Representation Mode)
Frame width doesn't adapt and content may be truncated Frame width doesn't adapt and content may be truncated
so -width may need to be manually set to display more." 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\ contents -default "" -type string\
-help "Frame contents - may be a block of text containing newlines and ANSI. -help "Frame contents - may be a block of text containing newlines and ANSI.
Text may be 'ragged' - ie unequal line-lengths. Text may be 'ragged' - ie unequal line-lengths.
No trailing ANSI reset required. No trailing ANSI reset required.
${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}"
} }
} }
@ -8915,15 +8919,16 @@ tcl::namespace::eval textblock {
} }
} }
punk::args::define { punk::args::define {
@id -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 -max_cross_size -default 0 -type integer -help\
Only cross sizes that divide the size of the overall block will be used. "Largest size cross to use to make up the block
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. Only cross sizes that divide the size of the overall block will be used.
Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) 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.
If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. 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 "
size -default 1 -type integer @values -min 0 -max 1
size -default 1 -type integer
} }
proc gcross {args} { proc gcross {args} {
set argd [punk::args::parse $args withid ::textblock::gcross] set argd [punk::args::parse $args withid ::textblock::gcross]

50
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm

@ -577,18 +577,18 @@ namespace eval punk {
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
-returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels { -returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels {
"matched"\ "matched"\
" Return only lines that matched." " Return only lines that matched."
"breaksandmatches"\ "breaksandmatches"\
" Return configured --break= lines in between non-consecutive matches" " Return configured --break= lines in between non-consecutive matches"
"all"\ "all"\
" Return all lines. " Return all lines.
This has a similar effect to the 'grep' trick of matching on 'pattern|$' This has a similar effect to the 'grep' trick of matching on 'pattern|$'
(The $ matches all lines that have an end; ie all lines, but there is no (The $ matches all lines that have an end; ie all lines, but there is no
associated character to which to apply highlighting) associated character to which to apply highlighting)
except that when instead using -returnlines all with --line-number, the * except that when instead using -returnlines all with --line-number, the *
indicator after the linenumber will only be highlighted for lines with matches, indicator after the linenumber will only be highlighted for lines with matches,
and the following matchcount will indicate zero for non-matching lines." and the following matchcount will indicate zero for non-matching lines."
} }
-B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num
-C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\ -C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\
@ -609,9 +609,9 @@ namespace eval punk {
" "
-ansistrip -type none -help\ -ansistrip -type none -help\
"Strip all ansi codes from the input string before processing. "Strip all ansi codes from the input string before processing.
This is not necessary for regex matching purposes, as the matching is always This is not necessary for regex matching purposes, as the matching is always
performed on the ansistripped characters anyway, but by stripping ANSI, the performed on the ansistripped characters anyway, but by stripping ANSI, the
result only has the ANSI supplied by the -highlight option." result only has the ANSI supplied by the -highlight option."
#-n|--line-number as per grep utility, except that we include a * for matches #-n|--line-number as per grep utility, except that we include a * for matches
-n|--line-number -type none -help\ -n|--line-number -type none -help\
@ -7153,8 +7153,8 @@ namespace eval punk {
-exclude_punctlines -default 1 -type boolean -exclude_punctlines -default 1 -type boolean
-show_largest -default 0 -type integer -help\ -show_largest -default 0 -type integer -help\
"Report the top largest linecount files. "Report the top largest linecount files.
The value represents the number of files The value represents the number of files
to report on." to report on."
} " } "
#we could map away whitespace and use string is punct - but not as flexible? review #we could map away whitespace and use string is punct - but not as flexible? review
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
@ -7384,7 +7384,7 @@ namespace eval punk {
#dict of list-len 2 is equiv to dict of dict with one keyval pair #dict of list-len 2 is equiv to dict of dict with one keyval pair
#-------------------------------- #--------------------------------
#!!!todo fix - linedict is unfinished and non-functioning #!!!todo fix - linedict is unfinished and non-functioning
#linedict based on indents #linedict based on indents
@ -7615,23 +7615,23 @@ namespace eval punk {
-showcount -type boolean -default 1 -help\ -showcount -type boolean -default 1 -help\
"Display a leading indicator in brackets showing the number of arg values present." "Display a leading indicator in brackets showing the number of arg values present."
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels {
0 "Strip ANSI codes from display 0 " Strip ANSI codes from display
of values. The disply output will of values. The disply output will
still be colourised if -ansibase has still be colourised if -ansibase has
not been set to empty string or not been set to empty string or
[a+ normal]. The stderr or stdout [a+ normal]. The stderr or stdout
channels may also have an ansi colour. channels may also have an ansi colour.
(see 'colour off' or punk::config)" (see 'colour off' or punk::config)"
1 "Leave value as is" 1 " Leave value as is"
2 "Display the ANSI codes and 2 " Display the ANSI codes and
other control characters inline other control characters inline
with replacement indicators. with replacement indicators.
e.g esc, newline, space, tab" e.g esc, newline, space, tab"
VIEW "Alias for 2" VIEW " Alias for 2"
3 "Display as per 2 but with 3 " Display as per 2 but with
colourised ANSI replacement codes." colourised ANSI replacement codes."
VIEWCODES "Alias for 3" VIEWCODES " Alias for 3"
4 "Display ANSI and control 4 " Display ANSI and control
chars in default colour, but chars in default colour, but
apply the contained ansi to apply the contained ansi to
the text portions so they display the text portions so they display

45
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -3287,31 +3287,32 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#indent of 1 space is important for clarity in i -return string a+ output #indent of 1 space is important for clarity in i -return string a+ output
dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m" dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m"
} }
set SGR_help\ set SGR_help\
{SGR code from the list below, or an integer corresponding to the code e.g 31 = red. {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. A leading capital letter indicates a codename applies to the background colour.
Other accepted codes are: Other accepted codes are:
term-<int> Term-<int> foreground/background where int is 0-255 terminal color term-<int> Term-<int> foreground/background where int is 0-255 terminal color
term-<termcolour> Term-<termcolour> foreground/background term-<termcolour> Term-<termcolour> foreground/background
web-<webcolour> Web-<webcolour> web-<webcolour> Web-<webcolour>
x11-<xllcolour> X11-<x11colour> x11-<xllcolour> X11-<x11colour>
tk-<tkcolour> Tk-<tkcolour> tk-<tkcolour> Tk-<tkcolour>
rgb-<r>-<g>-<b> Rgb-<r>-<g>-<b> foreground/background where <r> <g> <b> are the rgb-<r>-<g>-<b> Rgb-<r>-<g>-<b> foreground/background where <r> <g> <b> are the
0-255 int values for red, green and blue. 0-255 int values for red, green and blue.
rgb#<hexcode> Rgb#<hexcode> where <hexcode> is a 6 char hex colour e.g rgb#C71585 rgb#<hexcode> Rgb#<hexcode> where <hexcode> is a 6 char hex colour e.g rgb#C71585
The acceptable values for colours can be queried using The acceptable values for colours can be queried using
punk::ansi::a? term punk::ansi::a? term
punk::ansi::a? web punk::ansi::a? web
punk::ansi::a? x11 punk::ansi::a? x11
punk::ansi::a? tk punk::ansi::a? tk
Example to set foreground red and background cyan followed by a reset: Example to set foreground red and background cyan followed by a reset:
set str \"[a+ red Cyan]sample text[a]\" set str \"[a+ red Cyan]sample text[a]\"
} }
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::punk::ansi::a+ @id -id ::punk::ansi::a+
@ -3325,6 +3326,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
-choicelabels {%choicelabels%}\ -choicelabels {%choicelabels%}\
-choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\
"%SGR_help%" "%SGR_help%"
#note SGR_help string has same level of indent as placeholder
}]] }]]
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -5835,8 +5837,11 @@ tcl::namespace::eval punk::ansi::ta {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::ansi::ta}] #[subsection {Namespace punk::ansi::ta}]
#[para] text ansi functions #[para] text ansi functions
#[para] based on but not identical to the Perl Text Ansi module: #[para] based on the API but not identical to the Perl Text Ansi module: Text::ANSI::Util
#[para] https://metacpan.org/pod/Text::ANSI::Util
#[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm
#[para] These functions are not based on the source code of the perl functions, but the documented input and output
#[para] so algorithms and performance may differ.
#[list_begin definitions] #[list_begin definitions]
tcl::namespace::path ::punk::ansi tcl::namespace::path ::punk::ansi
namespace export detect detect_in_list detect_sgr extract length split_codes split_at_codes split_codes_single namespace export detect detect_in_list detect_sgr extract length split_codes split_at_codes split_codes_single
@ -8137,7 +8142,7 @@ tcl::namespace::eval punk::ansi::ansistring {
#return empty string for each index that is out of range #return empty string for each index that is out of range
#review - this is possibly too slow to be very useful as is. #review - this is possibly too slow to be very useful as is.
# consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string
#see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. #see also punk::lib::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them.
proc INDEXABSOLUTE {string args} { proc INDEXABSOLUTE {string args} {
set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most) set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most)
set testindices [list] set testindices [list]
@ -8166,6 +8171,8 @@ tcl::namespace::eval punk::ansi::ansistring {
} else { } else {
set offset 0 set offset 0
} }
#2025 -BROKEN - doesn't handle indices with both + and -
#see updated punk::lib::lindex_resolve
#by now, if op = + then offset = 0 so we only need to handle the minus case #by now, if op = + then offset = 0 so we only need to handle the minus case
if {$payload_len == -1} { if {$payload_len == -1} {
set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal

10862
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm

File diff suppressed because it is too large Load Diff

3017
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm

File diff suppressed because it is too large Load Diff

4570
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm

File diff suppressed because it is too large Load Diff

4
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm

@ -150,8 +150,8 @@ namespace eval punk::mix::commandset::module {
"Create a new module file in the appropriate folder within src/modules. "Create a new module file in the appropriate folder within src/modules.
If the name given in the module argument is namespaced, If the name given in the module argument is namespaced,
the necessary subfolder(s) will be used or created." the necessary subfolder(s) will be used or created."
-project -optional 1 -project -optional 1
-version -default "0.1.0" -help\ -version -type packageversion -default "0.1.0" -help\
"version to use if not specified as part of the module argument. "version to use if not specified as part of the module argument.
If a version is specified in the module argument as well as in -version If a version is specified in the module argument as well as in -version
the higher version number will be used. the higher version number will be used.

272
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

@ -491,42 +491,50 @@ tcl::namespace::eval punk::ns {
lassign $cindices cstart cend lassign $cindices cstart cend
append p [string range $nspath $s $cstart-1] append p [string range $nspath $s $cstart-1]
set numcolons [expr {$cend - $cstart + 1}] set numcolons [expr {$cend - $cstart + 1}]
if {$numcolons == 1} { #assert numcolons != 0 due to regexp +
#internal colon switch -exact -- $numcolons {
append p : 2 - 4 {
set s [expr {$cend+1}] #4 is a somewhat common case - could handle with default branch but may as well short circuit here.
continue
} elseif {$numcolons == 2} {
lappend parts $p
set p ""
set s [expr {$cend+1}]
continue
} elseif {($numcolons -1) % 3 == 0} {
set numcolons [expr {$numcolons -2}]
}
#assert numcolons >=3 and not in 4,7,10,13,16,19,22... sequence
if {$numcolons % 3 == 0} {
#if numcolons % 3 == 0 we have a leading colon left for next ns
#this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y
#we resolve with allowing leading colons only for each ns.
set singlec_count [expr {($numcolons /3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p lappend parts $p
set p ""
set s [expr {$cend+1}]
#continue
} }
set p ":" 1 {
set s [expr {$cend+1}] #internal colon
continue append p :
} else { set s [expr {$cend+1}]
set singlec_count [expr {(($numcolons +1)/3) -1}] #continue
if {$singlec_count > 0} { }
lappend parts $p {*}[lrepeat $singlec_count :] default {
} else { if {($numcolons -1) %3 == 0} {
lappend parts $p set numcolons [expr {$numcolons -2}]
}
#assert numcolons >=4 and not in 7,10,13,16,19,22... sequence
if {$numcolons % 3 == 0} {
#if numcolons % 3 == 0 we have a leading colon left for next ns
#this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y
#we resolve with allowing leading colons only for each ns.
set singlec_count [expr {($numcolons /3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p
}
set p ":"
set s [expr {$cend+1}]
#continue
} else {
set singlec_count [expr {(($numcolons +1)/3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p
}
set p ""
set s [expr {$cend+1}]
}
} }
set p ""
set s [expr {$cend+1}]
} }
} }
if {$cend < ([string length $nspath]-1)} { if {$cend < ([string length $nspath]-1)} {
@ -695,6 +703,39 @@ tcl::namespace::eval punk::ns {
} }
proc nsglob_as_re {glob} { proc nsglob_as_re {glob} {
#any segment that is not just * must match exactly one segment in the path
set pats [list]
foreach seg [nsparts_cached $glob] {
switch -exact -- $seg {
"" {
lappend pats ""
}
* {
#review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed
#lappend pats {[^:]*}
#negative lookahead
#any number of chars not followed by ::, followed by any number of non :
lappend pats {(?:.(?!::))*[^:]*}
}
** {
lappend pats {.*}
}
default {
set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
#set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg]
set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg]
lappend pats "$pat"
} else {
lappend pats "$seg"
}
}
}
}
return "^[join $pats ::]\$"
}
#obsolete
proc nsglob_as_re1 {glob} {
#any segment that is not just * must match exactly one segment in the path #any segment that is not just * must match exactly one segment in the path
set pats [list] set pats [list]
foreach seg [nsparts_cached $glob] { foreach seg [nsparts_cached $glob] {
@ -2984,7 +3025,7 @@ tcl::namespace::eval punk::ns {
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
#private? todo? #private? todo?
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
#dict set choiceinfodict $cmd {{doctype ooo}} #dict set choiceinfodict $cmd {{doctype ooo}}
@ -3042,9 +3083,10 @@ tcl::namespace::eval punk::ns {
@cmd -name "${$objtype}: ${$origin}" -help\ @cmd -name "${$objtype}: ${$origin}" -help\
"Instance of class: ${$class} (info autogenerated by generate_autodef) "Instance of class: ${$class} (info autogenerated by generate_autodef)
(see 'i punk::ns::Cmark' for symbols)" (see 'i punk::ns::Cmark' for symbols)"
@leaders -min 1 @leaders -min 1 -max 1
}] }]
append argdef \n $vline append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
@ -3148,15 +3190,15 @@ tcl::namespace::eval punk::ns {
dict for {sub subwhat} $subcommand_dict { dict for {sub subwhat} $subcommand_dict {
if {[llength $subwhat] > 1} { if {[llength $subwhat] > 1} {
#TODO - resolve using cmdinfo? #TODO - resolve using cmdinfo?
puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" puts stderr "generate_autodef warning: subcommand $sub points to multiword target $subwhat - TODO"
} }
set targetfirstword [lindex $subwhat 0] set targetfirstword [lindex $subwhat 0]
set targetinfo [cmdwhich $targetfirstword] set targetinfo [cmdwhich $targetfirstword]
set targetorigin [dict get $targetinfo origin] set targetorigin [dict get $targetinfo origin]
set targetcmdtype [dict get $targetinfo origintype] set targetcmdtype [dict get $targetinfo origintype]
set nstarget [nsprefix $targetorigin] set nstarget [nsprefix $targetorigin]
# -resolved-
dict set choiceinfodict $sub [list [list resolved $subwhat]] dict set choiceinfodict $sub [list [list ensemblesubtarget {*}$subwhat]]
dict lappend choiceinfodict $sub [list doctype $targetcmdtype] dict lappend choiceinfodict $sub [list doctype $targetcmdtype]
if {[punk::args::id_exists [list $origin $sub]]} { if {[punk::args::id_exists [list $origin $sub]]} {
@ -3183,17 +3225,18 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by generate_autodef) "(autogenerated by generate_autodef)
ensemble: ${$origin}" ensemble: ${$origin}"
@leaders -min 1
}] }]
#we must put a max on @leaders so that any subsequent arguments are not parsed as leaders for an ensemble root docid
if {[llength $parameters] == 0} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" append argdef \n "@leaders -min 1 -max 1"
} else { } else {
append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" append argdef \n "@leaders -min [expr {[llength $parameters]+1}] -max [expr {[llength $parameters]+1}]"
foreach p $parameters { foreach p $parameters {
append argdef \n "$p -type string -help { (leading ensemble parameter)}" append argdef \n "$p -type string -ensembleparameter 1 -help { (leading ensemble parameter)}"
} }
} }
append argdef \n $vline append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
proc { proc {
@ -3325,6 +3368,13 @@ tcl::namespace::eval punk::ns {
set cinfo [cmdwhich $finalcommand] set cinfo [cmdwhich $finalcommand]
set origin [dict get $cinfo origin] set origin [dict get $cinfo origin]
set cmdtype [dict get $cinfo origintype] set cmdtype [dict get $cinfo origintype]
if {$cmdtype eq "notfound" && [llength $finalcommand] > 1} {
#e.g see curried command produced by 'punk::netbox::man <apicontextid> new'
set next [list {*}$finalcommand {*}$remainingargs]
if {$next ne $args} {
return [cmdinfo {*}$next]
}
}
return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack] return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack]
} }
proc cmd_traverse {ns formid args} { proc cmd_traverse {ns formid args} {
@ -3493,6 +3543,7 @@ tcl::namespace::eval punk::ns {
#we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs. #we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs.
#(would not support shor-form prefix of subcommand - even if the proc implementation did) #(would not support shor-form prefix of subcommand - even if the proc implementation did)
set docid_exists 0 set docid_exists 0
set eparams [list]
if {[punk::args::id_exists "$origin [lindex $args $i]"]} { if {[punk::args::id_exists "$origin [lindex $args $i]"]} {
set a [lindex $args $i] set a [lindex $args $i]
#review - tests? #review - tests?
@ -3504,7 +3555,7 @@ tcl::namespace::eval punk::ns {
set origin [list $origin $a] set origin [list $origin $a]
incr i incr i
set queryargs [lrange $args $i end] set queryargs [lrange $args $i end]
set resolvedargs [list $a] ;#even though the set resolvedargs [list $a] ;#
set queryargs_untested $queryargs set queryargs_untested $queryargs
} elseif {[punk::args::id_exists $docid]} { } elseif {[punk::args::id_exists $docid]} {
set docid_exists 1 set docid_exists 1
@ -3543,6 +3594,12 @@ tcl::namespace::eval punk::ns {
set leadernames [dict get $spec FORMS $fid LEADER_NAMES] set leadernames [dict get $spec FORMS $fid LEADER_NAMES]
set optnames [dict get $spec FORMS $fid OPT_NAMES] set optnames [dict get $spec FORMS $fid OPT_NAMES]
set valnames [dict get $spec FORMS $fid VAL_NAMES] set valnames [dict get $spec FORMS $fid VAL_NAMES]
#review - see 'string is word' vs 'string is wordchar' behaviour due to documented common opts/vals in the parent ensemble-like command '::tcl::string::is'
#we should be preferring the most specific documentation
#Alternatively - we could adjust the 'string is' documentation to have @values -unnamed true
#and put the common info in the help for <unnamed> - but that would give us an inferior synopsis for 'string is'
if {![llength $optnames] && ![llength $valnames]} { if {![llength $optnames] && ![llength $valnames]} {
#set queryargs [lrange $args $i end] #set queryargs [lrange $args $i end]
@ -3574,8 +3631,26 @@ tcl::namespace::eval punk::ns {
if {$is_ensembleparam} { if {$is_ensembleparam} {
lappend resolvedargs $q lappend resolvedargs $q
lpop queryargs_untested 0 lpop queryargs_untested 0
lappend eparams $q
puts stderr "---> cmd_traverse ensembleparam $q ($lname)"
puts stderr "arginfo: $arginfo"
puts stderr "---> eparams: $eparams"
puts stderr "---> existing args: $args"
#ledit queryargs_untested 0 0 #ledit queryargs_untested 0 0
#review - add tests #review - add tests
#todo - put param in untested (multiple ensembleparams??)
#ledit queryargs_untested 1 0 $q ;#(linsert)
#set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand
#if {$posn_subcommand > 0} {
# set params [lrange $queryargs 0 $posn_subcommand-1]
# set remaining_queryargs [lrange $queryargs $posn_subcommand end]
#} else {
# set params [list]
# set remaining_queryargs $queryargs
#}
incr i
continue continue
} }
if {![llength $allchoices]} { if {![llength $allchoices]} {
@ -3585,7 +3660,7 @@ tcl::namespace::eval punk::ns {
#ledit queryargs_untested 0 0 #ledit queryargs_untested 0 0
#jjj #jjj
#continue #continue
return [list 3 $origin $resolvedargs $queryargs_untested $docid] return [list 3 $origin $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
break break
} }
set resolved_q [tcl::prefix::match -error "" $allchoices $q] set resolved_q [tcl::prefix::match -error "" $allchoices $q]
@ -3610,9 +3685,9 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
foreach inf $cinfo { foreach inf $cinfo {
switch -- [lindex $inf 0] { switch -- [lindex $inf 0] {
"resolved" { "subhelp" {
#punk::args::ensemble_subcommands_definition
set mapped_subcmd [lrange $inf 1 end] set mapped_subcmd [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3630,11 +3705,14 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" set docid ""
} }
#puts stderr "cmd_traverse 'resolved' $mapped_subcmd" #allow subhelp override - todo: review/document rationale/usecases
break
} }
"subhelp" { "ensemblesubtarget" {
# -resolved-
#punk::args::ensemble_subcommands_definition
#This could be a list representing some other ensemble or command with pre-included arguments
set mapped_subcmd [lrange $inf 1 end] set mapped_subcmd [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3652,8 +3730,16 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" set docid ""
} }
#allow subhelp override - todo: review/document rationale/usecases #puts stderr "cmd_traverse 'resolved' $mapped_subcmd"
break }
"doctype" {
set d [lindex $inf 1]
switch -- $d {
"classmethod" {
}
"coremethod" {
}
}
} }
} }
} }
@ -3668,23 +3754,9 @@ tcl::namespace::eval punk::ns {
set mapped_subcmd "$raw_origin $resolved_q" set mapped_subcmd "$raw_origin $resolved_q"
set docid $mapped_subcmd set docid $mapped_subcmd
} else { } else {
#REVIEW - there is no reason to assume a subcommand (even in an ensemble) #NOTE there is no reason to assume a subcommand (even in an ensemble)
#will be located at "${raw_origin}::$resolved_q" #will be located at "${raw_origin}::$resolved_q"
#ensemble -map could point resolved_q somewhere else entirely #ensemble -map could point resolved_q somewhere else entirely
#punk::args::update_definitions [list $raw_origin]
#if {[punk::args::id_exists "${raw_origin}::$resolved_q"]} {
# set mapped_subcmd "${raw_origin}::$resolved_q"
# set docid $mapped_subcmd
#} else {
# if {![punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# namespace eval $ns [list punk::ns::generate_autodef "${raw_origin}::$resolved_q"]
# }
# if {[punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# set mapped_subcmd ${raw_origin}::$resolved_q
# set docid (autodef)${raw_origin}::$resolved_q
# }
#}
} }
} }
#puts "----------$mapped_subcmd" #puts "----------$mapped_subcmd"
@ -3695,13 +3767,18 @@ tcl::namespace::eval punk::ns {
#punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] #punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {[llength $queryargs_untested] == 0} { if {[llength $queryargs_untested] == 0} {
return [list 6 $mapped_subcmd $resolvedargs $queryargs_untested $docid] return [list 6 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
} }
set origin [yield [list 0 $mapped_subcmd $resolvedargs $queryargs_untested $docid]] set origin [yield [list 0 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]]
#set resolvedargs [list] #set resolvedargs [list]
incr i [expr {-1 * [llength $resolvedargs]+1}] #incr i [expr {-1 * [llength $resolvedargs]+1}] ;#wrong e.g test trace add execution blah enterstep cmd
#puts stderr "... yield-result $origin i:$i" #JJJ
#puts stderr "... yield-result $origin i:$i args: $args"
ledit args $i+1 $i {*}$eparams
set eparams [list]
set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]] set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]]
set origin [dict get $whichinfo origin] set origin [dict get $whichinfo origin]
@ -3719,15 +3796,15 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
} }
break break ;#out of foreach q $queryargs ...
} else { } else {
#test with: i namespace which -v x #test with: i namespace which -v x
return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid] return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid]
} }
} } ;#end loop foreach q $queryargs lname $leadernames_matched
} else { } else {
#?? #??
puts stderr "cmdinfo.cmd_traverse returning 8 $origin $resolvedargs [lrange $args $i end] $docid" #puts stderr "cmdinfo.cmd_traverse returning 8 origin: $origin resolved: $resolvedargs remaining: [lrange $args $i end] docid: $docid"
return [list 8 $origin $resolvedargs [lrange $args $i end] $docid] return [list 8 $origin $resolvedargs [lrange $args $i end] $docid]
} }
} else { } else {
@ -3758,7 +3835,8 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::forms] set argd [::punk::args::parse $args withid ::punk::ns::forms]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context
set id [dict get $resolveinfo origin] #set id [dict get $resolveinfo origin]
set id [dict get $resolveinfo docid]
::punk::args::forms $id ::punk::args::forms $id
} }
@ -3778,8 +3856,10 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::eg] set argd [::punk::args::parse $args withid ::punk::ns::eg]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context
set resolved_id [dict get $resolveinfo origin] #set resolved_id [dict get $resolveinfo origin]
set result [::punk::args::eg $resolved_id] #set result [::punk::args::eg $resolved_id]
set docid [dict get $resolveinfo docid]
set result [::punk::args::eg $docid]
} }
@ -3849,7 +3929,30 @@ tcl::namespace::eval punk::ns {
#puts stderr [textblock::frame $syn] #puts stderr [textblock::frame $syn]
#set replaceuntil [expr {[llength $resolved_id]-1}] #set replaceuntil [expr {[llength $resolved_id]-1}]
set replaceuntil [expr {[llength $resolved_id]-1+$excess}] set replaceuntil [expr {[llength $resolved_id]-1+$excess}]
append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n #append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n ;#don't use join - will destroy braced sets
#e.g see s dict filter
#treating a somewhat arbitrary string $synline as a list here is a bit risky
#todo - consider always using 'punk::args::synopsis -return dict' and operating on that list to rebuild string - REVIEW
set adjusted_synline [lreplace $synline 0 $replaceuntil {*}$resolved_args] ;#don't use join - will destroy braced sets
#however - we don't want the extra bracing around ansi elements caused by list rep!
#::dict filter {dictionaryValue} script {keyVariable valueVariable} {script}
#vs
#::dict filter dictionaryValue script {keyVariable valueVariable} script
#(due to ansi in dictionaryValue and trailing script)
#manually join based on list length review
set lineout ""
foreach part $adjusted_synline {
if {[llength $part] == 1} {
append lineout " " $part
} else {
append lineout " " [list $part]
}
}
#must be no leading space for tests in test::punk::args synopsis.test
append resultstr [string trim $lineout] \n
} }
} }
set resultstr [string trimright $resultstr \n] set resultstr [string trimright $resultstr \n]
@ -4620,6 +4723,7 @@ tcl::namespace::eval punk::ns {
@values @values
}] }]
set i 0 set i 0
#for 9.1+ can use -integer
foreach a $arglist { foreach a $arglist {
switch -- [llength $a] { switch -- [llength $a] {
1 { 1 {
@ -4663,7 +4767,7 @@ tcl::namespace::eval punk::ns {
lassign $impl generaltype mname location methodtype lassign $impl generaltype mname location methodtype
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
dict set choiceinfodict $cmd {{doctype objectmethod}} dict set choiceinfodict $cmd {{doctype objectmethod}}
@ -4679,12 +4783,10 @@ tcl::namespace::eval punk::ns {
dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]]
} }
} }
if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} {
if {[punk::args::id_exists $id]} { #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]"
#dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" dict lappend choiceinfodict $cmd {doctype punkargs}
dict lappend choiceinfodict $cmd {doctype punkargs} dict lappend choiceinfodict $cmd [list subhelp {*}$id]
dict lappend choiceinfodict $cmd [list subhelp {*}$id]
}
} }
break break
} }
@ -4842,7 +4944,6 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by arginfo) "(autogenerated by arginfo)
ensemble: ${$origin}" ensemble: ${$origin}"
@leaders -min 1
}] }]
if {[llength $parameters] == 0} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" append argdef \n "@leaders -min 1"
@ -4852,6 +4953,7 @@ tcl::namespace::eval punk::ns {
append argdef \n "$p -type string -help { (leading ensemble parameter)}" append argdef \n "$p -type string -help { (leading ensemble parameter)}"
} }
} }
append argdef \n "@values -unnamed true"
append argdef \n $vline append argdef \n $vline
punk::args::define $argdef punk::args::define $argdef
} }

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/path-0.1.0.tm

@ -182,7 +182,7 @@ namespace eval punk::path {
proc normjoin {args} { proc normjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}] set args [lmap a $args {string map "\\\\ /" $a}]
set path [plainjoin {*}$args] set path [plainjoin {*}$args]
switch -exact $path { switch -exact -- $path {
"" { "" {
return "" return ""
} }

125
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm

@ -4531,10 +4531,10 @@ tcl::namespace::eval textblock {
-help "existing table object to use" -help "existing table object to use"
-action -default "append" -choices {append replace}\ -action -default "append" -choices {append replace}\
-help "row insertion method if existing -table is supplied -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column" if append is chosen the new values will always start at the first column"
-title -type string -help\ -title -type string -help\
"Title to display overlayed on top edge of table. "Title to display overlayed on top edge of table.
Will not be visible if -show_edge is false" Will not be visible if -show_edge is false"
-titlealign -type string -choices {left centre right} -titlealign -type string -choices {left centre right}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame" -help "frame type or dict for custom frame"
@ -4545,32 +4545,32 @@ tcl::namespace::eval textblock {
-help "Show vertical table separators" -help "Show vertical table separators"
-show_hseps -default "" -type boolean\ -show_hseps -default "" -type boolean\
-help "Show horizontal table separators -help "Show horizontal table separators
(default 0 if no existing -table supplied)" (default 0 if no existing -table supplied)"
-colheaders -default "" -type list\ -colheaders -default "" -type list\
-help {list of lists. list of column header values. Outer list must match number of columns. -help {list of lists. list of column header values. Outer list must match number of columns.
A table A table
e.g single header row: -colheaders {{column_a} {column_b} {column_c}} e.g single header row: -colheaders {{column_a} {column_b} {column_c}}
e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}} e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}}
Note that each element of the outer list is itself a list so: Note that each element of the outer list is itself a list so:
-colheaders {"column a" "column b" "column c"} -colheaders {"column a" "column b" "column c"}
Is likely not the right format if it was intended to have a single header row where the Is likely not the right format if it was intended to have a single header row where the
column titles contain spaces. column titles contain spaces.
The correct syntax for that would be: The correct syntax for that would be:
-colheaders {{"column a"} {"column b"} {"column c"}} -colheaders {{"column a"} {"column b"} {"column c"}}
For spanning header cells - use 'set t [list_as_table -return tableobject ...]' For spanning header cells - use 'set t [list_as_table -return tableobject ...]'
and then something like: and then something like:
$t configure_header 1 -colspans {3 0 0}; $t print $t configure_header 1 -colspans {3 0 0}; $t print
} }
-header -default "" -type list -multiple 1\ -header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row. -help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns" The number of values for each must be <= number of columns"
-show_header -type boolean\ -show_header -type boolean\
-help "Whether to show a header row. -help "Whether to show a header row.
Omit for unspecified/automatic, Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied." in which case it will display only if -headers list was supplied."
-columns -default "" -type integer\ -columns -default "" -type integer\
-help "Number of table columns -help "Number of table columns
Will default to 2 if not using an existing -table object" 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" datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value"
@ -4810,19 +4810,19 @@ tcl::namespace::eval textblock {
-choices {horizontal vertical}\ -choices {horizontal vertical}\
-help\ -help\
"Direction of character increments. "Direction of character increments.
When rainbow is in the colour list, When rainbow is in the colour list,
the colour stripes will be oriented the colour stripes will be oriented
in this direction. in this direction.
" "
@values -min 0 -max 1 @values -min 0 -max 1
colour -type list -default {} -optional 1 -help\ colour -type list -default {} -optional 1 -help\
"List of Ansi colour names "List of Ansi colour names
e.g. testblock -size 10 {white Red} e.g. testblock -size 10 {white Red}
produces a block of character 10x10 produces a block of character 10x10
with white text on red bacground with white text on red bacground
The additional pseudo-color 'rainbow' The additional pseudo-color 'rainbow'
is available. is available.
" "
} }
@ -5717,6 +5717,7 @@ tcl::namespace::eval textblock {
" "
-ansiresets -type any -default auto -ansiresets -type any -default auto
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
@values
blocks -type any -multiple 1 blocks -type any -multiple 1
} }
@ -6095,6 +6096,7 @@ tcl::namespace::eval textblock {
proc welcome_test {} { proc welcome_test {} {
package require punk::ansi package require punk::ansi
package require patternpunk
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]] set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]]
# Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com # Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com
set table [[textblock::spantest] print] set table [[textblock::spantest] print]
@ -6108,6 +6110,7 @@ tcl::namespace::eval textblock {
proc example {args} { proc example {args} {
set opts [tcl::dict::create -forcecolour 0] set opts [tcl::dict::create -forcecolour 0]
package require patternpunk
foreach {k v} $args { foreach {k v} $args {
switch -- $k { switch -- $k {
-forcecolour { -forcecolour {
@ -7981,54 +7984,55 @@ tcl::namespace::eval textblock {
frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\"" frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\""
-checkargs -default 1 -type boolean\ -checkargs -default 1 -type boolean\
-help "If true do extra argument checks and -help "If true do extra argument checks and
provide more comprehensive error info. provide more comprehensive error info.
As the argument parser loads around 16 default frame As the argument parser loads around 16 default frame
samples dynamically, this can add add up as each may samples dynamically, this can add add up as each may
take 10s of microseconds. For many-framed tables take 10s of microseconds. For many-framed tables
and other applications this can add up. and other applications this can add up.
Set false for performance improvement." Set false for performance improvement."
-etabs -default 0\ -etabs -default 0\
-help "expanding tabs - experimental/unimplemented." -help "expanding tabs - experimental/unimplemented."
#review - -choicelabels placeholder dollarsign of textblock::frame_samples must be left aligned with -choicelabels
-type -default light\ -type -default light\
-type dict\ -type dict\
-typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\ -typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\
-choices {${[textblock::frametypes]}}\ -choices {${[textblock::frametypes]}}\
-choicerestricted 0 -choicecolumns 8\ -choicerestricted 0 -choicecolumns 8\
-choicelabels { -choicelabels {
${[textblock::frame_samples]} ${[textblock::frame_samples]}
}\ }\
-help "Type of border for frame." -help "Type of border for frame."
-boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. -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. passing an empty string will result in no box, but title/subtitle will still appear if supplied.
${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}"
-boxmap -default {} -type dict -boxmap -default {} -type dict
-joins -default {} -type list -joins -default {} -type list
-title -default "" -type string -regexprefail {\n}\ -title -default "" -type string -regexprefail {\n}\
-help "Frame title placed on topbar - no newlines. -help "Frame title placed on topbar - no newlines.
May contain ANSI - no trailing reset required. May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
-titlealign -default "centre" -choices {left centre right} -titlealign -default "centre" -choices {left centre right}
-subtitle -default "" -type string -regexprefail {\n}\ -subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines -help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required." May contain Ansi - no trailing reset required."
-subtitlealign -default "centre" -choices {left centre right} -subtitlealign -default "centre" -choices {left centre right}
-width -default "" -type int\ -width -default "" -type int\
-help "Width of resulting frame including borders. -help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content." If omitted or empty-string, the width will be determined automatically based on content."
-height -default "" -type int\ -height -default "" -type int\
-help "Height of resulting frame including borders." -help "Height of resulting frame including borders."
-ansiborder -default "" -type ansistring\ -ansiborder -default "" -type ansistring\
-help "Ansi escape sequence to set border attributes. -help "Ansi escape sequence to set border attributes.
${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents
e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}"
-ansibase -default "" -type ansistring\ -ansibase -default "" -type ansistring\
-help "Default ANSI attributes within frame." -help "Default ANSI attributes within frame."
-blockalign -default centre -choices {left right centre}\ -blockalign -default centre -choices {left right centre}\
-help "Alignment of the content block within the frame." -help "Alignment of the content block within the frame."
-pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background
extends within the content block inside the frame. extends within the content block inside the frame.
Has no effect if no ANSI in content." Has no effect if no ANSI in content."
-textalign -default left -choices {left right centre}\ -textalign -default left -choices {left right centre}\
-help "Alignment of text within the content block. (centre unimplemented)" -help "Alignment of text within the content block. (centre unimplemented)"
-ellipsis -default 1 -type boolean\ -ellipsis -default 1 -type boolean\
@ -8037,16 +8041,16 @@ tcl::namespace::eval textblock {
-buildcache -default 1 -type boolean -buildcache -default 1 -type boolean
-crm_mode -default 0 -type boolean\ -crm_mode -default 0 -type boolean\
-help "Show ANSI control characters within frame contents. -help "Show ANSI control characters within frame contents.
(Control Representation Mode) (Control Representation Mode)
Frame width doesn't adapt and content may be truncated Frame width doesn't adapt and content may be truncated
so -width may need to be manually set to display more." 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\ contents -default "" -type string\
-help "Frame contents - may be a block of text containing newlines and ANSI. -help "Frame contents - may be a block of text containing newlines and ANSI.
Text may be 'ragged' - ie unequal line-lengths. Text may be 'ragged' - ie unequal line-lengths.
No trailing ANSI reset required. No trailing ANSI reset required.
${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}"
} }
} }
@ -8915,15 +8919,16 @@ tcl::namespace::eval textblock {
} }
} }
punk::args::define { punk::args::define {
@id -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 -max_cross_size -default 0 -type integer -help\
Only cross sizes that divide the size of the overall block will be used. "Largest size cross to use to make up the block
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. Only cross sizes that divide the size of the overall block will be used.
Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) 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.
If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. 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 "
size -default 1 -type integer @values -min 0 -max 1
size -default 1 -type integer
} }
proc gcross {args} { proc gcross {args} {
set argd [punk::args::parse $args withid ::textblock::gcross] set argd [punk::args::parse $args withid ::textblock::gcross]

4
src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm

@ -297,7 +297,7 @@ namespace eval argparsingtest {
} }
punk::args::define { punk::args::define {
@id -id ::test1_punkargs_by_id @id -id ::argparsingtest::test1_punkargs_by_id
@cmd -name argtest4 -help "test of punk::args::parse comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
@ -314,7 +314,7 @@ namespace eval argparsingtest {
@values @values
} }
proc test1_punkargs_by_id {args} { proc test1_punkargs_by_id {args} {
set argd [punk::args::get_by_id ::test1_punkargs_by_id $args] set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs_by_id $args]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
} }

50
src/vfs/_vfscommon.vfs/modules/punk-0.1.tm

@ -577,18 +577,18 @@ namespace eval punk {
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
-returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels { -returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels {
"matched"\ "matched"\
" Return only lines that matched." " Return only lines that matched."
"breaksandmatches"\ "breaksandmatches"\
" Return configured --break= lines in between non-consecutive matches" " Return configured --break= lines in between non-consecutive matches"
"all"\ "all"\
" Return all lines. " Return all lines.
This has a similar effect to the 'grep' trick of matching on 'pattern|$' This has a similar effect to the 'grep' trick of matching on 'pattern|$'
(The $ matches all lines that have an end; ie all lines, but there is no (The $ matches all lines that have an end; ie all lines, but there is no
associated character to which to apply highlighting) associated character to which to apply highlighting)
except that when instead using -returnlines all with --line-number, the * except that when instead using -returnlines all with --line-number, the *
indicator after the linenumber will only be highlighted for lines with matches, indicator after the linenumber will only be highlighted for lines with matches,
and the following matchcount will indicate zero for non-matching lines." and the following matchcount will indicate zero for non-matching lines."
} }
-B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num
-C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\ -C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\
@ -609,9 +609,9 @@ namespace eval punk {
" "
-ansistrip -type none -help\ -ansistrip -type none -help\
"Strip all ansi codes from the input string before processing. "Strip all ansi codes from the input string before processing.
This is not necessary for regex matching purposes, as the matching is always This is not necessary for regex matching purposes, as the matching is always
performed on the ansistripped characters anyway, but by stripping ANSI, the performed on the ansistripped characters anyway, but by stripping ANSI, the
result only has the ANSI supplied by the -highlight option." result only has the ANSI supplied by the -highlight option."
#-n|--line-number as per grep utility, except that we include a * for matches #-n|--line-number as per grep utility, except that we include a * for matches
-n|--line-number -type none -help\ -n|--line-number -type none -help\
@ -7153,8 +7153,8 @@ namespace eval punk {
-exclude_punctlines -default 1 -type boolean -exclude_punctlines -default 1 -type boolean
-show_largest -default 0 -type integer -help\ -show_largest -default 0 -type integer -help\
"Report the top largest linecount files. "Report the top largest linecount files.
The value represents the number of files The value represents the number of files
to report on." to report on."
} " } "
#we could map away whitespace and use string is punct - but not as flexible? review #we could map away whitespace and use string is punct - but not as flexible? review
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
@ -7384,7 +7384,7 @@ namespace eval punk {
#dict of list-len 2 is equiv to dict of dict with one keyval pair #dict of list-len 2 is equiv to dict of dict with one keyval pair
#-------------------------------- #--------------------------------
#!!!todo fix - linedict is unfinished and non-functioning #!!!todo fix - linedict is unfinished and non-functioning
#linedict based on indents #linedict based on indents
@ -7615,23 +7615,23 @@ namespace eval punk {
-showcount -type boolean -default 1 -help\ -showcount -type boolean -default 1 -help\
"Display a leading indicator in brackets showing the number of arg values present." "Display a leading indicator in brackets showing the number of arg values present."
-ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels {
0 "Strip ANSI codes from display 0 " Strip ANSI codes from display
of values. The disply output will of values. The disply output will
still be colourised if -ansibase has still be colourised if -ansibase has
not been set to empty string or not been set to empty string or
[a+ normal]. The stderr or stdout [a+ normal]. The stderr or stdout
channels may also have an ansi colour. channels may also have an ansi colour.
(see 'colour off' or punk::config)" (see 'colour off' or punk::config)"
1 "Leave value as is" 1 " Leave value as is"
2 "Display the ANSI codes and 2 " Display the ANSI codes and
other control characters inline other control characters inline
with replacement indicators. with replacement indicators.
e.g esc, newline, space, tab" e.g esc, newline, space, tab"
VIEW "Alias for 2" VIEW " Alias for 2"
3 "Display as per 2 but with 3 " Display as per 2 but with
colourised ANSI replacement codes." colourised ANSI replacement codes."
VIEWCODES "Alias for 3" VIEWCODES " Alias for 3"
4 "Display ANSI and control 4 " Display ANSI and control
chars in default colour, but chars in default colour, but
apply the contained ansi to apply the contained ansi to
the text portions so they display the text portions so they display

45
src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm

@ -3287,31 +3287,32 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#indent of 1 space is important for clarity in i -return string a+ output #indent of 1 space is important for clarity in i -return string a+ output
dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m" dict set SGR_samples $k " [punk::ansi::a+ $k]sample\x1b\[m"
} }
set SGR_help\ set SGR_help\
{SGR code from the list below, or an integer corresponding to the code e.g 31 = red. {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. A leading capital letter indicates a codename applies to the background colour.
Other accepted codes are: Other accepted codes are:
term-<int> Term-<int> foreground/background where int is 0-255 terminal color term-<int> Term-<int> foreground/background where int is 0-255 terminal color
term-<termcolour> Term-<termcolour> foreground/background term-<termcolour> Term-<termcolour> foreground/background
web-<webcolour> Web-<webcolour> web-<webcolour> Web-<webcolour>
x11-<xllcolour> X11-<x11colour> x11-<xllcolour> X11-<x11colour>
tk-<tkcolour> Tk-<tkcolour> tk-<tkcolour> Tk-<tkcolour>
rgb-<r>-<g>-<b> Rgb-<r>-<g>-<b> foreground/background where <r> <g> <b> are the rgb-<r>-<g>-<b> Rgb-<r>-<g>-<b> foreground/background where <r> <g> <b> are the
0-255 int values for red, green and blue. 0-255 int values for red, green and blue.
rgb#<hexcode> Rgb#<hexcode> where <hexcode> is a 6 char hex colour e.g rgb#C71585 rgb#<hexcode> Rgb#<hexcode> where <hexcode> is a 6 char hex colour e.g rgb#C71585
The acceptable values for colours can be queried using The acceptable values for colours can be queried using
punk::ansi::a? term punk::ansi::a? term
punk::ansi::a? web punk::ansi::a? web
punk::ansi::a? x11 punk::ansi::a? x11
punk::ansi::a? tk punk::ansi::a? tk
Example to set foreground red and background cyan followed by a reset: Example to set foreground red and background cyan followed by a reset:
set str \"[a+ red Cyan]sample text[a]\" set str \"[a+ red Cyan]sample text[a]\"
} }
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id ::punk::ansi::a+ @id -id ::punk::ansi::a+
@ -3325,6 +3326,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
-choicelabels {%choicelabels%}\ -choicelabels {%choicelabels%}\
-choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\ -choicecolumns 5 -choiceprefix 0 -choicerestricted 0 -help\
"%SGR_help%" "%SGR_help%"
#note SGR_help string has same level of indent as placeholder
}]] }]]
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -5835,8 +5837,11 @@ tcl::namespace::eval punk::ansi::ta {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::ansi::ta}] #[subsection {Namespace punk::ansi::ta}]
#[para] text ansi functions #[para] text ansi functions
#[para] based on but not identical to the Perl Text Ansi module: #[para] based on the API but not identical to the Perl Text Ansi module: Text::ANSI::Util
#[para] https://metacpan.org/pod/Text::ANSI::Util
#[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm
#[para] These functions are not based on the source code of the perl functions, but the documented input and output
#[para] so algorithms and performance may differ.
#[list_begin definitions] #[list_begin definitions]
tcl::namespace::path ::punk::ansi tcl::namespace::path ::punk::ansi
namespace export detect detect_in_list detect_sgr extract length split_codes split_at_codes split_codes_single namespace export detect detect_in_list detect_sgr extract length split_codes split_at_codes split_codes_single
@ -8137,7 +8142,7 @@ tcl::namespace::eval punk::ansi::ansistring {
#return empty string for each index that is out of range #return empty string for each index that is out of range
#review - this is possibly too slow to be very useful as is. #review - this is possibly too slow to be very useful as is.
# consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string
#see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. #see also punk::lib::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them.
proc INDEXABSOLUTE {string args} { proc INDEXABSOLUTE {string args} {
set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most) set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most)
set testindices [list] set testindices [list]
@ -8166,6 +8171,8 @@ tcl::namespace::eval punk::ansi::ansistring {
} else { } else {
set offset 0 set offset 0
} }
#2025 -BROKEN - doesn't handle indices with both + and -
#see updated punk::lib::lindex_resolve
#by now, if op = + then offset = 0 so we only need to handle the minus case #by now, if op = + then offset = 0 so we only need to handle the minus case
if {$payload_len == -1} { if {$payload_len == -1} {
set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal

10862
src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm

File diff suppressed because it is too large Load Diff

211
src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm

@ -947,8 +947,9 @@ tcl::namespace::eval punk::args {
if {[string first \$\{ $optionspecs] > 0} { if {[string first \$\{ $optionspecs] > 0} {
if {$defspace ne ""} { if {$defspace ne ""} {
#normal/desired case #normal/desired case
#set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] #JJJ
set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -paramindents none -allowcommands $optionspecs]] set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
#set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -paramindents none -allowcommands $optionspecs]]
} else { } else {
#todo - deprecate/stop from happening? #todo - deprecate/stop from happening?
puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)"
@ -979,7 +980,9 @@ tcl::namespace::eval punk::args {
# -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}"
#} #}
if {$defspace ne ""} { if {$defspace ne ""} {
set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]]
#JJJ - review
set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -paramindents none $optionspecs]]
} }
#REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?)
if {[string first \$\{ $optionspecs] > 0} { if {[string first \$\{ $optionspecs] > 0} {
@ -1876,13 +1879,16 @@ tcl::namespace::eval punk::args {
#set all_choices [_resolve_get_record_choices] #set all_choices [_resolve_get_record_choices]
foreach fid $record_form_ids { foreach fid $record_form_ids {
if {[dict get $F $fid argspace] eq "leaders"} { switch -exact -- [dict get $F $fid argspace] {
dict set F $fid argspace "options" leaders {
} elseif {[dict get $F $fid argspace] eq "values"} { dict set F $fid argspace "options"
error "punk::args::resolve - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id" }
values {
error "punk::args::resolve - invalid placement of line '$rec' - must come before @values (command form:'$fid') @id:$DEF_definition_id"
}
} }
set record_type option set record_type option
dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname] dict set F $fid OPT_NAMES [list {*}[dict get $F $fid OPT_NAMES] $argname]
} }
@ -2017,6 +2023,8 @@ tcl::namespace::eval punk::args {
} }
ansi - ansistring {set normtype ansistring} ansi - ansistring {set normtype ansistring}
string - globstring {set normtype $lc_firstword} string - globstring {set normtype $lc_firstword}
packageversion {set normtype packageversion}
packagerequirement {set normtype packagerequirement}
literal { literal {
#value was split out by _split_type_expression #value was split out by _split_type_expression
set normtype literal([lindex $alt 1]) set normtype literal([lindex $alt 1])
@ -2390,8 +2398,13 @@ tcl::namespace::eval punk::args {
as these arguments are already fully spec'd. The defaults from the as these arguments are already fully spec'd. The defaults from the
source can be removed by adding @leaders, @opts @values to the source can be removed by adding @leaders, @opts @values to the
-antiglobs list, but again - this won't affect the existing arguments. -antiglobs list, but again - this won't affect the existing arguments.
Each argument can have members of its spec overridden using the Each argument can have members of its spec overridden using the
-override dictionary. -override dictionary The members of each override sub dictionary are
usually options beginning with a dash. The key 'name' can be used to
override the name of the leader/option/value itself.
e.g
punk::args::resolved_def -types values -override {version {name version1 -optional 0}} (shared)::package version
" "
@leaders -min 0 -max 0 @leaders -min 0 -max 0
@opts @opts
@ -2453,16 +2466,21 @@ tcl::namespace::eval punk::args {
#a definition id must not begin with "-" ??? review #a definition id must not begin with "-" ??? review
for {set i 0} {$i < [llength $args]} {incr i} { for {set i 0} {$i < [llength $args]} {incr i} {
set a [lindex $args $i] set a [lindex $args $i]
if {$a in {-type -types}} { switch -exact -- $a {
incr i -type - -types {
dict set opts -types [lindex $args $i] incr i
} elseif {[string match -* $a]} { dict set opts -types [lindex $args $i]
incr i }
dict set opts $a [lindex $args $i] default {
} else { if {[string match -* $a]} {
set id [lindex $args $i] incr i
set patterns [lrange $args $i+1 end] dict set opts $a [lindex $args $i]
break } else {
set id [lindex $args $i]
set patterns [lrange $args $i+1 end]
break
}
}
} }
if {$i == [llength $args]-1} { if {$i == [llength $args]-1} {
punk::args::parse $args withid ::punk::args::resolved_def punk::args::parse $args withid ::punk::args::resolved_def
@ -2608,8 +2626,9 @@ tcl::namespace::eval punk::args {
if {[dict get $argspec -ARGTYPE] eq $tp} { if {[dict get $argspec -ARGTYPE] eq $tp} {
set argspec [dict remove $argspec -ARGTYPE] set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} { if {[dict exists $opt_override $m]} {
append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" set overdict [dict get $opt_override $m]
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] append result \n "\"$m\" [dict merge $argspec $overdict]"
dict set resultdict $m [dict merge $argspec $overdict]
} else { } else {
append result \n "\"$m\" $argspec" append result \n "\"$m\" $argspec"
dict set resultdict $m $argspec dict set resultdict $m $argspec
@ -2670,8 +2689,19 @@ tcl::namespace::eval punk::args {
if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} { if {[dict get $argspec -ARGTYPE] eq [dict get $argtypes $type]} {
set argspec [dict remove $argspec -ARGTYPE] set argspec [dict remove $argspec -ARGTYPE]
if {[dict exists $opt_override $m]} { if {[dict exists $opt_override $m]} {
append result \n "\"$m\" [dict merge $argspec [dict get $opt_override $m]]" set overdict [dict get $opt_override $m]
dict set resultdict $m [dict merge $argspec [dict get $opt_override $m]] if {[dict exists $opt_override $m name]} {
#special override for name of argument itself
#e.g
#punk::args::resolved_def -types values -override {version {name version1 -optional 1}} (shared)::package version
set newname [dict get $opt_override $m name]
dict unset overdict name
append result \n "\"$newname\" [dict merge $argspec $overdict]"
dict set resultdict $newname [dict merge $argspec $overdict]
} else {
append result \n "\"$m\" [dict merge $argspec $overdict]"
dict set resultdict $m [dict merge $argspec $overdict]
}
} else { } else {
append result \n "\"$m\" $argspec" append result \n "\"$m\" $argspec"
dict set resultdict $m $argspec dict set resultdict $m $argspec
@ -3328,6 +3358,7 @@ tcl::namespace::eval punk::args {
#limit colours to standard 16 so that themes can apply to help output #limit colours to standard 16 so that themes can apply to help output
variable arg_error_isrunning variable arg_error_isrunning
if {$arg_error_isrunning} { if {$arg_error_isrunning} {
set arg_error_isrunning 0
error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" error "arg_error already running - error in arg_error?\n triggering errmsg: $msg"
} }
@ -3501,6 +3532,9 @@ tcl::namespace::eval punk::args {
set docname [Dict_getdef $spec_dict doc_info -name "Manual:"] set docname [Dict_getdef $spec_dict doc_info -name "Manual:"]
set docurl [Dict_getdef $spec_dict doc_info -url ""] set docurl [Dict_getdef $spec_dict doc_info -url ""]
#set example [Dict_getdef $spec_dict examples_info -help ""]
set has_example [dict exists $spec_dict examples_info -help]
#review - when can there be more than one selected form? #review - when can there be more than one selected form?
set argdisplay_header "" set argdisplay_header ""
set argdisplay_body "" set argdisplay_body ""
@ -3546,6 +3580,12 @@ tcl::namespace::eval punk::args {
} else { } else {
set docurl_display "" set docurl_display ""
} }
if {$has_example} {
lappend blank_header_col ""
set example_display "[a+ white]eg [dict get $spec_dict id]$RST"
} else {
set example_display ""
}
#synopsis #synopsis
set synopsis "# [Dict_getdef $spec_dict cmd_info -summary {}]\n" set synopsis "# [Dict_getdef $spec_dict cmd_info -summary {}]\n"
set form_info [dict get $spec_dict form_info] set form_info [dict get $spec_dict form_info]
@ -3624,6 +3664,14 @@ tcl::namespace::eval punk::args {
} }
incr h incr h
} }
if {$has_example} {
if {$use_table} {
$t configure_header $h -colspans $arg_colspans -values [list Example: $example_display]
} else {
lappend errlines "Example: $docurl_display"
}
incr h
}
if {$synopsis ne ""} { if {$synopsis ne ""} {
if {$use_table} { if {$use_table} {
$t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]] $t configure_header $h -colspans $arg_colspans -values [list Synopsis: [punk::ansi::ansiwrap brightwhite $synopsis]]
@ -4896,7 +4944,7 @@ tcl::namespace::eval punk::args {
set clause_member_optional 0 set clause_member_optional 0
} }
set tp [string trim $tp ?] set tp [string trim $tp ?]
switch -glob $tp { switch -glob -- $tp {
literal* { literal* {
set litinfo [string range $tp 7 end] set litinfo [string range $tp 7 end]
set match [string range $litinfo 1 end-1] set match [string range $litinfo 1 end-1]
@ -5188,7 +5236,7 @@ tcl::namespace::eval punk::args {
#more complex type_expressions would require a bracketing syntax - (and probably pre-parsing) #more complex type_expressions would require a bracketing syntax - (and probably pre-parsing)
#or perhaps more performant, RPN to avoid bracket parsing #or perhaps more performant, RPN to avoid bracket parsing
#if literal(..), literalprefix(..), stringstartswith(..) etc can have pipe symbols and brackets etc - we can't just use split #if literal(..), literalprefix(..), stringstartswith(..) etc can have pipe symbols and brackets etc - we can't just use split
#if we require -type to always be treated as a list - and if an element is length 1 - require it to #if we require -type to always be treated as a list - and if an element is length 1 - require it to
#have properly balanced brackets that don't contain | ( ) etc we can simplify - REVIEW #have properly balanced brackets that don't contain | ( ) etc we can simplify - REVIEW
#consider: #consider:
@ -5807,6 +5855,49 @@ tcl::namespace::eval punk::args {
break break
} }
} }
packageversion {
if {[catch {::package vsatisfies $e_check $e_check}]} {
set msg "$argclass $argname for %caller% requires type packageversion. A package version number as understood by 'package vsatifies'. Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
} else {
lset clause_results $c_idx $a_idx 1
break
}
}
packagerequirement {
set parts [split $e_check -]
if {[llength $parts] > 2} {
set msg "$argclass $argname for %caller% requires type packagerequirement. (form min min- or min-max) Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
continue
}
set vchecklist [list]
if {[llength $parts] == 1} {
lappend vchecklist [lindex $parts 0]
} else {
lassign $parts vmin vmax
if {$vmax eq ""} {
#empty vmax allowed - ignore
lappend vchecklist $vmin
} else {
lappend vchecklist $vmin $vmax
}
}
#we have either just the min, or min and max
set v_ok 1 ;#default assumption
foreach vcheck $vchecklist {
if {[catch {::package vsatisfies $vcheck $vcheck}]} {
set msg "$argclass $argname for %caller% requires type packagerequirement. (from min min- or min-max) . Received: '$e_check'"
lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg]
set v_ok 0
break ;#inner loop
}
}
if {$v_ok} {
lset clause_results $c_idx $a_idx 1
break
}
}
string - ansistring - globstring { string - ansistring - globstring {
#we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string
#we possibly don't want to always have to regex on things that don't pass the other more basic checks #we possibly don't want to always have to regex on things that don't pass the other more basic checks
@ -6158,7 +6249,7 @@ tcl::namespace::eval punk::args {
#no pass for this clause - fetch first? error and raise #no pass for this clause - fetch first? error and raise
#todo - return error containing clause_indices so we can report more than one failing element at once? #todo - return error containing clause_indices so we can report more than one failing element at once?
foreach e $clauseresult { foreach e $clauseresult {
switch -exact [lindex $e 0] { switch -exact -- [lindex $e 0] {
errorcode { errorcode {
#errorcode <list> msg <string #errorcode <list> msg <string
set errorcode [lindex $e 1] set errorcode [lindex $e 1]
@ -7076,7 +7167,7 @@ tcl::namespace::eval punk::args {
set nameidx 0 set nameidx 0
if {$can_have_leaders} { if {$can_have_leaders} {
if {$LEADER_TAKEWHENARGSMODULO} { if {$LEADER_TAKEWHENARGSMODULO} {
#assign set of leaders purely based on number of total args #assign set of leaders purely based on number of total args
set take [expr {[llength $remaining_rawargs] % $LEADER_TAKEWHENARGSMODULO}] set take [expr {[llength $remaining_rawargs] % $LEADER_TAKEWHENARGSMODULO}]
set pre_values [lrange $remaining_rawargs 0 $take-1] set pre_values [lrange $remaining_rawargs 0 $take-1]
set remaining_rawargs [lrange $remaining_rawargs $take end] set remaining_rawargs [lrange $remaining_rawargs $take end]
@ -9167,6 +9258,7 @@ tcl::namespace::eval punk::args {
append syn " $display" append syn " $display"
dict set ARGD type [dict get $arginfo -type] dict set ARGD type [dict get $arginfo -type]
dict set ARGD optional [dict get $arginfo -optional] dict set ARGD optional [dict get $arginfo -optional]
dict set ARGD multiple [dict get $arginfo -multiple]
dict set ARGD display $display dict set ARGD display $display
#dict lappend SYND $f $ARGD #dict lappend SYND $f $ARGD
@ -9300,6 +9392,7 @@ tcl::namespace::eval punk::args {
append syn " $display" append syn " $display"
dict set ARGD type [dict get $arginfo -type] dict set ARGD type [dict get $arginfo -type]
dict set ARGD optional [dict get $arginfo -optional] dict set ARGD optional [dict get $arginfo -optional]
dict set ARGD multiple [dict get $arginfo -multiple]
dict set ARGD display $display dict set ARGD display $display
#dict lappend SYND $f $ARGD #dict lappend SYND $f $ARGD
lappend FORMARGS $ARGD lappend FORMARGS $ARGD
@ -9417,10 +9510,23 @@ tcl::namespace::eval punk::args {
append syn " $display" append syn " $display"
dict set ARGD type [dict get $arginfo -type] dict set ARGD type [dict get $arginfo -type]
dict set ARGD optional [dict get $arginfo -optional] dict set ARGD optional [dict get $arginfo -optional]
dict set ARGD multiple [dict get $arginfo -multiple]
dict set ARGD display $display dict set ARGD display $display
#dict lappend SYND $f $ARGD #dict lappend SYND $f $ARGD
lappend FORMARGS $ARGD lappend FORMARGS $ARGD
} }
#accepts unnamed extra arguments e.g toplevel docid for ensembles and ensemble-like commands
if {[dict get $forminfo VAL_UNNAMED]} {
set display "?<unnamed>...?"
append syn " $display"
set ARGD [dict create argname "" class value]
dict set ARGD type any
dict set ARGD optional 1
dict set ARGD multiple 1
dict set ARGD display $display
lappend FORMARGS $ARGD
}
append syn \n append syn \n
dict set SYND FORMS $f $FORMARGS dict set SYND FORMS $f $FORMARGS
} }
@ -9640,7 +9746,8 @@ tcl::namespace::eval punk::args {
dict for {g members} $opt_groupdict { dict for {g members} $opt_groupdict {
lappend allgrouped {*}$members lappend allgrouped {*}$members
} }
set choiceinfodict [dict create] set choiceinfodict [dict create]
set choicelabelsdict [dict create]
foreach {sc cmd} $subdict { foreach {sc cmd} $subdict {
if {$sc ni $allgrouped} { if {$sc ni $allgrouped} {
if {$sc ni $others} { if {$sc ni $others} {
@ -9669,20 +9776,44 @@ tcl::namespace::eval punk::args {
} }
} }
#could be more than one punk::args id - choose a precedence by how we order the id_exists checks. #could be more than one punk::args id - choose a precedence by how we order the id_exists checks.
if {[punk::args::id_exists [list $ensemble $sc]]} { set id_checks [list\
dict lappend choiceinfodict $sc {doctype punkargs} "$ensemble $sc"\
dict lappend choiceinfodict $sc [list subhelp {*}$ensemble $sc] $cmd\
} elseif {[punk::args::id_exists $cmd]} { [dict get $cinfo origin]\
dict lappend choiceinfodict $sc {doctype punkargs} ]
dict lappend choiceinfodict $sc [list subhelp {*}$cmd] foreach checkid $id_checks {
} elseif {[punk::args::id_exists [dict get $cinfo origin]]} { if {[punk::args::id_exists $checkid]} {
dict lappend choiceinfodict $sc {doctype punkargs} dict lappend choiceinfodict $sc {doctype punkargs}
dict lappend choiceinfodict $sc [list subhelp {*}[dict get $cinfo origin]] dict lappend choiceinfodict $sc [list subhelp {*}$checkid]
} else { #dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::ns::synopsis $checkid][punk::ansi::a]
#puts stderr "ensemble_subcommands_definition--- NO doc for [list $ensemble $sc] or $cmd or [dict get $cinfo origin]" dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::args::synopsis $checkid][punk::ansi::a]
break
}
} }
#if {[punk::args::id_exists [list $ensemble $sc]]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
# dict lappend choiceinfodict $sc [list subhelp {*}$ensemble $sc]
#} elseif {[punk::args::id_exists $cmd]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
# dict lappend choiceinfodict $sc [list subhelp {*}$cmd]
#} elseif {[punk::args::id_exists [dict get $cinfo origin]]} {
# dict lappend choiceinfodict $sc {doctype punkargs}
# dict lappend choiceinfodict $sc [list subhelp {*}[dict get $cinfo origin]]
#}
#foreach id [punk::args::get_ids "::package *"] {
# if {[llength $id] == 2} {
# lassign $id _ sub
# dict set PACKAGE_CHOICEINFO $sub {{doctype native} {doctype punkargs}}
# #override manual synopsis entry
# dict set PACKAGE_CHOICELABELS $sub [punk::ns::synopsis "::package $sub"]
# }
#}
#if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} { #if {[punk::args::id_exists [dict get $cinfo origin]] || [punk::args::id_exists [list $ensemble $sc]]} {
# dict lappend choiceinfodict $sc {doctype punkargs} # dict lappend choiceinfodict $sc {doctype punkargs}
#} #}
@ -9694,7 +9825,7 @@ tcl::namespace::eval punk::args {
dict for {g members} $opt_groupdict { dict for {g members} $opt_groupdict {
append argdef " \"$g\" \{$members\}" \n append argdef " \"$g\" \{$members\}" \n
} }
append argdef " \} -choicecolumns $opt_columns -choiceinfo {$choiceinfodict}" \n append argdef " \} -choicecolumns $opt_columns -choicelabels {$choicelabelsdict} -choiceinfo {$choiceinfodict}" \n
#todo -choicelabels #todo -choicelabels
#detect subcommand further info available e.g if oo or ensemble or punk::args id exists.. #detect subcommand further info available e.g if oo or ensemble or punk::args id exists..

3017
src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm

File diff suppressed because it is too large Load Diff

70
src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tkcore-0.1.1.tm

@ -453,7 +453,75 @@ tcl::namespace::eval punk::args::moduledoc::tkcore {
} "@doc -name Manpage: -url [manpage bell]" } "@doc -name Manpage: -url [manpage button]"\
{@examples -help {
This is the classic Tk “Hello, World!” demonstration:
${[punk::args::moduledoc::tclcore::argdoc::example {
button .b -text "Hello, World!" -command exit
pack .b
}]}
This example demonstrates how to handle button accelerators:
${[punk::args::moduledoc::tclcore::argdoc::example {
button .b1 -text Hello -underline 0
button .b2 -text World -underline 0
bind . <Key-h> {.b1 flash; .b1 invoke}
bind . <Key-w> {.b2 flash; .b2 invoke}
pack .b1 .b2
}]}
}
}
punk::args::define {
@id -id "(widgetcommand)Class_Button cget"
@cmd -name "(widgetcommand)Class_Button cget" -help\
"Returns the current value of the configuration option given by option.
Option may have any of the values accepted by the button command."
@leaders -min 1 -max 1
option -type string
}
set CLASS_BUTTON_CHOICES [list cget configure flash invoke]
#manual synopses for subcommands not yet defined
set CLASS_BUTTON_CHOICELABELS [subst -novariables {
}]
set CLASS_BUTTON_CHOICEINFO [dict create]
foreach sub $CLASS_BUTTON_CHOICES {
#default for all
dict set CLASS_BUTTON_CHOICEINFO $sub {{doctype native}}
}
foreach id [punk::args::get_ids "(widgetcommand)Class_Button *"] {
if {[llength $id] == 2} {
lassign $id _ sub
dict set CLASS_BUTTON_CHOICEINFO $sub {{doctype native} {doctype punkargs}}
#override manual synopsis entry
#puts stderr "override manual synopsis entry with [punk::ns::synopsis "::package $sub"]"
dict set CLASS_BUTTON_CHOICELABELS $sub [punk::ansi::a+ normal][punk::ns::synopsis "(widgetcommand)Class_Button $sub"]
}
}
punk::args::define {
@id -id (widgetcommand)Class_Button
@cmd -name "Tk widget: (widgetcommand)Class_Button"\
-summary\
"widgetcommand for Tk class Button"\
-help\
"widgetcommand for Tk class Button"
@leaders -min 1 -max 1
option -type string\
-choicecolumns 2\
-choicegroups {
"actions" {flash invoke}
}\
-choicelabels {${$CLASS_BUTTON_CHOICELABELS}}\
-choiceinfo {${$CLASS_BUTTON_CHOICEINFO}}
} "@doc -name Manpage: -url [manpage button]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---

88
src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm

@ -478,7 +478,7 @@ tcl::namespace::eval punk::imap4::proto {
@values -min 0 -max 1 @values -min 0 -max 1
capability -type string -default "" -help\ capability -type string -default "" -help\
"The name of a capability to look for "The name of a capability to look for
in the cached response." in the cached response."
}] }]
proc has_capability {chan {capability ""}} { proc has_capability {chan {capability ""}} {
variable info variable info
@ -557,25 +557,25 @@ tcl::namespace::eval punk::imap4::proto {
@opts @opts
-validstates -default * -help\ -validstates -default * -help\
"A list of valid states from which this "A list of valid states from which this
command can be called" command can be called"
@values -min 1 -max -1 @values -min 1 -max -1
command -type string command -type string
arg -multiple 1 -optional 1 -help\ arg -multiple 1 -optional 1 -help\
{Each argument for the command must be {Each argument for the command must be
supplied in a way that preserved the form supplied in a way that preserved the form
expected by an IMAP server. expected by an IMAP server.
For example, if an argument has spaces it For example, if an argument has spaces it
may need to be in double quotes and so need may need to be in double quotes and so need
to be explicitly specified with quotes and a to be explicitly specified with quotes and a
protecting set of braces. protecting set of braces.
e.g e.g
simplecmd EXAMINE {"mailbox name with spaces"} simplecmd EXAMINE {"mailbox name with spaces"}
If Tcl variable substitution is required, escapes If Tcl variable substitution is required, escapes
within a quoted string could be used, or string map. within a quoted string could be used, or string map.
e.g e.g
simplecmd $ch SETMETADATA $b "($ann \"$val\")" simplecmd $ch SETMETADATA $b "($ann \"$val\")"
} }
}] }]
proc simplecmd {args} { proc simplecmd {args} {
set argd [punk::args::parse $args withid ::punk::imap4::proto::simplecmd] set argd [punk::args::parse $args withid ::punk::imap4::proto::simplecmd]
lassign [dict values $argd] leaders opts values received lassign [dict values $argd] leaders opts values received
@ -2059,18 +2059,18 @@ tcl::namespace::eval punk::imap4 {
user user
rights -help\ rights -help\
"A rights string consisting of zero or more rights "A rights string consisting of zero or more rights
characters (lowercase) optionally beginning with a characters (lowercase) optionally beginning with a
\"+\" or \"-\" \"+\" or \"-\"
e.g SETACL projectfolder other.user +cda e.g SETACL projectfolder other.user +cda
If the string starts with a plus, the following If the string starts with a plus, the following
rights are added to any existing rights for the rights are added to any existing rights for the
specified user. specified user.
If the string starts with a minus, the following If the string starts with a minus, the following
rights are removed from any existing rights for rights are removed from any existing rights for
the specified user. the specified user.
If the string does not start with a plus or minus, If the string does not start with a plus or minus,
the rights replace any existing rights for the the rights replace any existing rights for the
specified user. specified user.
" "
}] }]
proc SETACL {args} { proc SETACL {args} {
@ -2142,12 +2142,12 @@ tcl::namespace::eval punk::imap4 {
@values -min 0 -max 1 @values -min 0 -max 1
mailbox -default INBOX -help\ mailbox -default INBOX -help\
{To supply a mailbox name with spaces {To supply a mailbox name with spaces
The value will need to be enclosed with The value will need to be enclosed with
double quotes - and these quotes need to double quotes - and these quotes need to
be sent to the server. Enclose in curly be sent to the server. Enclose in curly
braces to ensure this. braces to ensure this.
e.g e.g
SELECT $ch {"Deleted Items"} SELECT $ch {"Deleted Items"}
} }
}] }]
proc SELECT {args} { proc SELECT {args} {
@ -2172,12 +2172,12 @@ tcl::namespace::eval punk::imap4 {
#todo - share argdefs more! #todo - share argdefs more!
mailbox -default INBOX -help\ mailbox -default INBOX -help\
{To supply a mailbox name with spaces {To supply a mailbox name with spaces
The value will need to be enclosed with The value will need to be enclosed with
double quotes - and these quotes need to double quotes - and these quotes need to
be sent to the server. Enclose in curly be sent to the server. Enclose in curly
braces to ensure this. braces to ensure this.
e.g e.g
SELECT $ch {"Deleted Items"} SELECT $ch {"Deleted Items"}
} }
}] }]
proc EXAMINE {args} { proc EXAMINE {args} {
@ -2339,12 +2339,12 @@ tcl::namespace::eval punk::imap4 {
queryitems -default {} -help\ queryitems -default {} -help\
"Some common FETCH queries are shown here, but "Some common FETCH queries are shown here, but
this list isn't exhaustive."\ this list isn't exhaustive."\
-multiple 1 -optional 0 -choiceprefix 0 -choicerestricted 0 -choicecolumns 2 -choices { -multiple 1 -optional 0 -choiceprefix 0 -choicerestricted 0 -choicecolumns 2 -choices {
ALL FAST FULL BODY BODYSTRUCTURE ENVELOPE FLAGS INTERNALDATE ALL FAST FULL BODY BODYSTRUCTURE ENVELOPE FLAGS INTERNALDATE
SIZE RFC822.SIZE SIZE RFC822.SIZE
UID UID
TEXT HEADER BODY[] BINARY[] BINARY.SIZE[] TEXT HEADER BODY[] BINARY[] BINARY.SIZE[]
} -choicelabels { } -choicelabels {
ALL\ ALL\
" Macro equivalent to: " Macro equivalent to:
(FLAGS INTERNALDATE RFC822.SIZE ENVELOPE) (FLAGS INTERNALDATE RFC822.SIZE ENVELOPE)
@ -2928,7 +2928,7 @@ tcl::namespace::eval punk::imap4 {
@values -min 2 -max 2 @values -min 2 -max 2
mailbox -help\ mailbox -help\
{Mailbox name or empty string {""} for server annotations} {Mailbox name or empty string {""} for server annotations}
annotation -choicerestricted 0 -help\ annotation -choicerestricted 0 -choiceprefix 0 -help\
"May include glob character *"\ "May include glob character *"\
-choices { -choices {
/private/specialuse /private/squat /private/sieve /private/sharedseen /private/comment /private/specialuse /private/squat /private/sieve /private/sharedseen /private/comment
@ -2986,7 +2986,7 @@ tcl::namespace::eval punk::imap4 {
/private/expire /private/news2mail /private/pop3showafter /private/expire /private/news2mail /private/pop3showafter
} -help\ } -help\
"Annotation is a string beginning with /private/ or /shared/ "Annotation is a string beginning with /private/ or /shared/
Check specific server for supported mailbox annotations. Check specific server for supported mailbox annotations.
" "
value -help\ value -help\
"Pass the empty string or NIL to unset/delete the annotation" "Pass the empty string or NIL to unset/delete the annotation"
@ -3405,7 +3405,7 @@ tcl::namespace::eval punk::imap4 {
*:3 *:3
1,3,5,7:9 1,3,5,7:9
" "
storetype -default +FLAGS -choicecolumns 1 -choices {+FLAGS +FLAGS.SILENT -FLAGS -FLAGS.SILENT FLAGS FLAGS.SILENT}\ storetype -default +FLAGS -choicecolumns 1 -choiceprefix 0 -choices {+FLAGS +FLAGS.SILENT -FLAGS -FLAGS.SILENT FLAGS FLAGS.SILENT}\
-choicelabels { -choicelabels {
+FLAGS\ +FLAGS\
"Add the supplied flagnames to the flags for the message. "Add the supplied flagnames to the flags for the message.

2
src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.2.tm

@ -1526,7 +1526,7 @@ namespace eval punk::lib {
set pnext [string range $pnext 1 end] set pnext [string range $pnext 1 end]
} }
# single type in segment e.g /@@something/ # single type in segment e.g /@@something/
switch -exact $pnext { switch -exact -- $pnext {
"" { "" {
set substructure string set substructure string
} }

4570
src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.3.tm

File diff suppressed because it is too large Load Diff

4
src/vfs/_vfscommon.vfs/modules/punk/mix/commandset/module-0.1.0.tm

@ -150,8 +150,8 @@ namespace eval punk::mix::commandset::module {
"Create a new module file in the appropriate folder within src/modules. "Create a new module file in the appropriate folder within src/modules.
If the name given in the module argument is namespaced, If the name given in the module argument is namespaced,
the necessary subfolder(s) will be used or created." the necessary subfolder(s) will be used or created."
-project -optional 1 -project -optional 1
-version -default "0.1.0" -help\ -version -type packageversion -default "0.1.0" -help\
"version to use if not specified as part of the module argument. "version to use if not specified as part of the module argument.
If a version is specified in the module argument as well as in -version If a version is specified in the module argument as well as in -version
the higher version number will be used. the higher version number will be used.

BIN
src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.2.tm

Binary file not shown.

155
src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm

@ -980,10 +980,10 @@ tcl::namespace::eval punk::netbox {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_STATUS]\ [set ::punk::netbox::argdoc::_RETURN_STATUS]\
@ -1091,27 +1091,28 @@ tcl::namespace::eval punk::netbox::dcim {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help\
{${$::punk::netbox::argdoc::_number_filter_help}}
-name -name
-NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_name_filter_help}} -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}}
-asset_tag -type string -asset_tag -type string
-ASSET_TAG_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_string_filter_help}} -ASSET_TAG_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}}
-face -type string -face -type string
-face__n -type string -face__n -type string
-position -type integer -position -type integer
-POSITION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -POSITION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-airflow -type string -airflow -type string
-airflow__n -type string -airflow__n -type string
-vc_position -type integer -vc_position -type integer
-VC_POSITION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -VC_POSITION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-vc_priority -type integer -vc_priority -type integer
-VC_PRIORITY_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -VC_PRIORITY_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
}\ }\
[set ::punk::netbox::argdoc::_create_update_options]\ [set ::punk::netbox::argdoc::_create_update_options]\
{ {
@ -1155,9 +1156,9 @@ tcl::namespace::eval punk::netbox::dcim {
-status -type string -status -type string
-status__n -type string -status__n -type string
-mac_address -type string -mac_address -type string
-MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_string_filter_help}} -MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}}
-serial -type string -serial -type string
-SERIAL_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_string_filter_help}} -SERIAL_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}}
-virtual_chassis_id -type integer -virtual_chassis_id -type integer
-virtual_chassis_id__n -type integer -virtual_chassis_id__n -type integer
}\ }\
@ -1188,14 +1189,14 @@ tcl::namespace::eval punk::netbox::ipam {
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-name -name
-NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_name_filter_help}} -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}}
-rd -type string -help\ -rd -type string -help\
"Route distinguisher in any format" "Route distinguisher in any format"
-enforce_unique -enforce_unique
-description -type string -help "Exact Match (case sensitive)" -description -type string -help "Exact Match (case sensitive)"
-DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_description_filter_help}} -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}}
}\ }\
[set ::punk::netbox::argdoc::_create_update_options]\ [set ::punk::netbox::argdoc::_create_update_options]\
{ {
@ -1230,10 +1231,10 @@ tcl::namespace::eval punk::netbox::ipam {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1261,11 +1262,11 @@ tcl::namespace::eval punk::netbox::ipam {
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-is_pool -is_pool
-mark_utilized -mark_utilized
-description -type string -help "Exact Match (case sensitive)" -description -type string -help "Exact Match (case sensitive)"
-DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_description_filter_help}} -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}}
}\ }\
[set ::punk::netbox::argdoc::_create_update_options]\ [set ::punk::netbox::argdoc::_create_update_options]\
{ {
@ -1285,16 +1286,16 @@ tcl::namespace::eval punk::netbox::ipam {
-within_include -within_include
-contains -contains
-depth -depth
-DEPTH_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -DEPTH_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-children -children
-CHILDREN_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -CHILDREN_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-mask_length -mask_length
-mask_length__gte -mask_length__gte
-mask_length__lte -mask_length__lte
-vlan_id -type integer -vlan_id -type integer
-vlan_id__n -type integer -vlan_id__n -type integer
-vlan_vid -type integer -vlan_vid -type integer
-VLAN_VID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -VLAN_VID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-vrf_id -vrf_id
-vrf -vrf
-status -status
@ -1319,10 +1320,10 @@ tcl::namespace::eval punk::netbox::ipam {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1343,10 +1344,10 @@ tcl::namespace::eval punk::netbox::ipam {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1368,10 +1369,10 @@ tcl::namespace::eval punk::netbox::ipam {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_page_options]\ [set ::punk::netbox::argdoc::_page_options]\
@ -1508,11 +1509,11 @@ tcl::namespace::eval punk::netbox::ipam {
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-dns_name -dns_name
-DNS_NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_string_filter_help}} -DNS_NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}}
-description -type string -help "Exact Match (case sensitive)" -description -type string -help "Exact Match (case sensitive)"
-DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_description_filter_help}} -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}}
}\ }\
[set ::punk::netbox::argdoc::_create_update_options]\ [set ::punk::netbox::argdoc::_create_update_options]\
{ {
@ -1686,19 +1687,19 @@ tcl::namespace::eval punk::netbox::tenancy {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-name -name
-NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_name_filter_help}} -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}}
-slug -type string -slug -type string
-SLUG_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_string_filter_help}} -SLUG_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}}
-description -type string -description -type string
-DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_string_filter_help}} -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}}
}\ }\
[set ::punk::netbox::argdoc::_create_update_options]\ [set ::punk::netbox::argdoc::_create_update_options]\
{ {
@ -1735,24 +1736,24 @@ tcl::namespace::eval punk::netbox::virtualization {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
-id -type integer -id -type integer
-ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-name -name
-NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_name_filter_help}} -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}}
-cluster -type string -cluster -type string
-cluster_n -type string -cluster_n -type string
-vcpus -type integer -vcpus -type integer
-VCPUS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -VCPUS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-memory -type integer -help\ -memory -type integer -help\
"Whole number" "Whole number"
-MEMORY_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -MEMORY_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
-disk -type integer -disk -type integer
-DISK_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_number_filter_help}} -DISK_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}}
}\ }\
[set ::punk::netbox::argdoc::_create_update_options]\ [set ::punk::netbox::argdoc::_create_update_options]\
{ {
@ -1782,7 +1783,7 @@ tcl::namespace::eval punk::netbox::virtualization {
-platform -platform
-platform__n -platform__n
-mac_address -mac_address
-MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -help {${$::punk::netbox::argdoc::_string_filter_help}} -MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}}
-has_primary_ip -has_primary_ip
}\ }\
[set ::punk::netbox::argdoc::_group_options]\ [set ::punk::netbox::argdoc::_group_options]\
@ -1807,10 +1808,10 @@ tcl::namespace::eval punk::netbox::virtualization {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1835,10 +1836,10 @@ tcl::namespace::eval punk::netbox::virtualization {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
-FORCE -default 0 -type boolean -help\ -FORCE -default 0 -type boolean -help\
"Set to true to BULK delete all items at this endpoint" "Set to true to BULK delete all items at this endpoint"
@ -1859,10 +1860,10 @@ tcl::namespace::eval punk::netbox::virtualization {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\
@ -1883,10 +1884,10 @@ tcl::namespace::eval punk::netbox::virtualization {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
}\ }\
[set ::punk::netbox::argdoc::_RETURN_DICT]\ [set ::punk::netbox::argdoc::_RETURN_DICT]\

8
src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm

@ -132,10 +132,10 @@ tcl::namespace::eval punk::netbox::man {
@leaders -min 1 -max 1 @leaders -min 1 -max 1
apicontextid -help\ apicontextid -help\
"The name of the stored api context to use. "The name of the stored api context to use.
A contextid can be created in-memory using A contextid can be created in-memory using
api_context_create, or loaded from a .toml api_context_create, or loaded from a .toml
file using api_context_load."\ file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}} -choices {${[punk::netbox::api_context_names]}}
@opts @opts
}\ }\
] ]

272
src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm

@ -491,42 +491,50 @@ tcl::namespace::eval punk::ns {
lassign $cindices cstart cend lassign $cindices cstart cend
append p [string range $nspath $s $cstart-1] append p [string range $nspath $s $cstart-1]
set numcolons [expr {$cend - $cstart + 1}] set numcolons [expr {$cend - $cstart + 1}]
if {$numcolons == 1} { #assert numcolons != 0 due to regexp +
#internal colon switch -exact -- $numcolons {
append p : 2 - 4 {
set s [expr {$cend+1}] #4 is a somewhat common case - could handle with default branch but may as well short circuit here.
continue
} elseif {$numcolons == 2} {
lappend parts $p
set p ""
set s [expr {$cend+1}]
continue
} elseif {($numcolons -1) % 3 == 0} {
set numcolons [expr {$numcolons -2}]
}
#assert numcolons >=3 and not in 4,7,10,13,16,19,22... sequence
if {$numcolons % 3 == 0} {
#if numcolons % 3 == 0 we have a leading colon left for next ns
#this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y
#we resolve with allowing leading colons only for each ns.
set singlec_count [expr {($numcolons /3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p lappend parts $p
set p ""
set s [expr {$cend+1}]
#continue
} }
set p ":" 1 {
set s [expr {$cend+1}] #internal colon
continue append p :
} else { set s [expr {$cend+1}]
set singlec_count [expr {(($numcolons +1)/3) -1}] #continue
if {$singlec_count > 0} { }
lappend parts $p {*}[lrepeat $singlec_count :] default {
} else { if {($numcolons -1) %3 == 0} {
lappend parts $p set numcolons [expr {$numcolons -2}]
}
#assert numcolons >=4 and not in 7,10,13,16,19,22... sequence
if {$numcolons % 3 == 0} {
#if numcolons % 3 == 0 we have a leading colon left for next ns
#this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y
#we resolve with allowing leading colons only for each ns.
set singlec_count [expr {($numcolons /3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p
}
set p ":"
set s [expr {$cend+1}]
#continue
} else {
set singlec_count [expr {(($numcolons +1)/3) -1}]
if {$singlec_count > 0} {
lappend parts $p {*}[lrepeat $singlec_count :]
} else {
lappend parts $p
}
set p ""
set s [expr {$cend+1}]
}
} }
set p ""
set s [expr {$cend+1}]
} }
} }
if {$cend < ([string length $nspath]-1)} { if {$cend < ([string length $nspath]-1)} {
@ -695,6 +703,39 @@ tcl::namespace::eval punk::ns {
} }
proc nsglob_as_re {glob} { proc nsglob_as_re {glob} {
#any segment that is not just * must match exactly one segment in the path
set pats [list]
foreach seg [nsparts_cached $glob] {
switch -exact -- $seg {
"" {
lappend pats ""
}
* {
#review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed
#lappend pats {[^:]*}
#negative lookahead
#any number of chars not followed by ::, followed by any number of non :
lappend pats {(?:.(?!::))*[^:]*}
}
** {
lappend pats {.*}
}
default {
set seg [string map {. [.]} $seg]
if {[regexp {[*?]} $seg]} {
#set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg]
set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg]
lappend pats "$pat"
} else {
lappend pats "$seg"
}
}
}
}
return "^[join $pats ::]\$"
}
#obsolete
proc nsglob_as_re1 {glob} {
#any segment that is not just * must match exactly one segment in the path #any segment that is not just * must match exactly one segment in the path
set pats [list] set pats [list]
foreach seg [nsparts_cached $glob] { foreach seg [nsparts_cached $glob] {
@ -2984,7 +3025,7 @@ tcl::namespace::eval punk::ns {
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
#private? todo? #private? todo?
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
#dict set choiceinfodict $cmd {{doctype ooo}} #dict set choiceinfodict $cmd {{doctype ooo}}
@ -3042,9 +3083,10 @@ tcl::namespace::eval punk::ns {
@cmd -name "${$objtype}: ${$origin}" -help\ @cmd -name "${$objtype}: ${$origin}" -help\
"Instance of class: ${$class} (info autogenerated by generate_autodef) "Instance of class: ${$class} (info autogenerated by generate_autodef)
(see 'i punk::ns::Cmark' for symbols)" (see 'i punk::ns::Cmark' for symbols)"
@leaders -min 1 @leaders -min 1 -max 1
}] }]
append argdef \n $vline append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
@ -3148,15 +3190,15 @@ tcl::namespace::eval punk::ns {
dict for {sub subwhat} $subcommand_dict { dict for {sub subwhat} $subcommand_dict {
if {[llength $subwhat] > 1} { if {[llength $subwhat] > 1} {
#TODO - resolve using cmdinfo? #TODO - resolve using cmdinfo?
puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" puts stderr "generate_autodef warning: subcommand $sub points to multiword target $subwhat - TODO"
} }
set targetfirstword [lindex $subwhat 0] set targetfirstword [lindex $subwhat 0]
set targetinfo [cmdwhich $targetfirstword] set targetinfo [cmdwhich $targetfirstword]
set targetorigin [dict get $targetinfo origin] set targetorigin [dict get $targetinfo origin]
set targetcmdtype [dict get $targetinfo origintype] set targetcmdtype [dict get $targetinfo origintype]
set nstarget [nsprefix $targetorigin] set nstarget [nsprefix $targetorigin]
# -resolved-
dict set choiceinfodict $sub [list [list resolved $subwhat]] dict set choiceinfodict $sub [list [list ensemblesubtarget {*}$subwhat]]
dict lappend choiceinfodict $sub [list doctype $targetcmdtype] dict lappend choiceinfodict $sub [list doctype $targetcmdtype]
if {[punk::args::id_exists [list $origin $sub]]} { if {[punk::args::id_exists [list $origin $sub]]} {
@ -3183,17 +3225,18 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by generate_autodef) "(autogenerated by generate_autodef)
ensemble: ${$origin}" ensemble: ${$origin}"
@leaders -min 1
}] }]
#we must put a max on @leaders so that any subsequent arguments are not parsed as leaders for an ensemble root docid
if {[llength $parameters] == 0} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" append argdef \n "@leaders -min 1 -max 1"
} else { } else {
append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" append argdef \n "@leaders -min [expr {[llength $parameters]+1}] -max [expr {[llength $parameters]+1}]"
foreach p $parameters { foreach p $parameters {
append argdef \n "$p -type string -help { (leading ensemble parameter)}" append argdef \n "$p -type string -ensembleparameter 1 -help { (leading ensemble parameter)}"
} }
} }
append argdef \n $vline append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
proc { proc {
@ -3325,6 +3368,13 @@ tcl::namespace::eval punk::ns {
set cinfo [cmdwhich $finalcommand] set cinfo [cmdwhich $finalcommand]
set origin [dict get $cinfo origin] set origin [dict get $cinfo origin]
set cmdtype [dict get $cinfo origintype] set cmdtype [dict get $cinfo origintype]
if {$cmdtype eq "notfound" && [llength $finalcommand] > 1} {
#e.g see curried command produced by 'punk::netbox::man <apicontextid> new'
set next [list {*}$finalcommand {*}$remainingargs]
if {$next ne $args} {
return [cmdinfo {*}$next]
}
}
return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack] return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack]
} }
proc cmd_traverse {ns formid args} { proc cmd_traverse {ns formid args} {
@ -3493,6 +3543,7 @@ tcl::namespace::eval punk::ns {
#we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs. #we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs.
#(would not support shor-form prefix of subcommand - even if the proc implementation did) #(would not support shor-form prefix of subcommand - even if the proc implementation did)
set docid_exists 0 set docid_exists 0
set eparams [list]
if {[punk::args::id_exists "$origin [lindex $args $i]"]} { if {[punk::args::id_exists "$origin [lindex $args $i]"]} {
set a [lindex $args $i] set a [lindex $args $i]
#review - tests? #review - tests?
@ -3504,7 +3555,7 @@ tcl::namespace::eval punk::ns {
set origin [list $origin $a] set origin [list $origin $a]
incr i incr i
set queryargs [lrange $args $i end] set queryargs [lrange $args $i end]
set resolvedargs [list $a] ;#even though the set resolvedargs [list $a] ;#
set queryargs_untested $queryargs set queryargs_untested $queryargs
} elseif {[punk::args::id_exists $docid]} { } elseif {[punk::args::id_exists $docid]} {
set docid_exists 1 set docid_exists 1
@ -3543,6 +3594,12 @@ tcl::namespace::eval punk::ns {
set leadernames [dict get $spec FORMS $fid LEADER_NAMES] set leadernames [dict get $spec FORMS $fid LEADER_NAMES]
set optnames [dict get $spec FORMS $fid OPT_NAMES] set optnames [dict get $spec FORMS $fid OPT_NAMES]
set valnames [dict get $spec FORMS $fid VAL_NAMES] set valnames [dict get $spec FORMS $fid VAL_NAMES]
#review - see 'string is word' vs 'string is wordchar' behaviour due to documented common opts/vals in the parent ensemble-like command '::tcl::string::is'
#we should be preferring the most specific documentation
#Alternatively - we could adjust the 'string is' documentation to have @values -unnamed true
#and put the common info in the help for <unnamed> - but that would give us an inferior synopsis for 'string is'
if {![llength $optnames] && ![llength $valnames]} { if {![llength $optnames] && ![llength $valnames]} {
#set queryargs [lrange $args $i end] #set queryargs [lrange $args $i end]
@ -3574,8 +3631,26 @@ tcl::namespace::eval punk::ns {
if {$is_ensembleparam} { if {$is_ensembleparam} {
lappend resolvedargs $q lappend resolvedargs $q
lpop queryargs_untested 0 lpop queryargs_untested 0
lappend eparams $q
puts stderr "---> cmd_traverse ensembleparam $q ($lname)"
puts stderr "arginfo: $arginfo"
puts stderr "---> eparams: $eparams"
puts stderr "---> existing args: $args"
#ledit queryargs_untested 0 0 #ledit queryargs_untested 0 0
#review - add tests #review - add tests
#todo - put param in untested (multiple ensembleparams??)
#ledit queryargs_untested 1 0 $q ;#(linsert)
#set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand
#if {$posn_subcommand > 0} {
# set params [lrange $queryargs 0 $posn_subcommand-1]
# set remaining_queryargs [lrange $queryargs $posn_subcommand end]
#} else {
# set params [list]
# set remaining_queryargs $queryargs
#}
incr i
continue continue
} }
if {![llength $allchoices]} { if {![llength $allchoices]} {
@ -3585,7 +3660,7 @@ tcl::namespace::eval punk::ns {
#ledit queryargs_untested 0 0 #ledit queryargs_untested 0 0
#jjj #jjj
#continue #continue
return [list 3 $origin $resolvedargs $queryargs_untested $docid] return [list 3 $origin $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
break break
} }
set resolved_q [tcl::prefix::match -error "" $allchoices $q] set resolved_q [tcl::prefix::match -error "" $allchoices $q]
@ -3610,9 +3685,9 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
foreach inf $cinfo { foreach inf $cinfo {
switch -- [lindex $inf 0] { switch -- [lindex $inf 0] {
"resolved" { "subhelp" {
#punk::args::ensemble_subcommands_definition
set mapped_subcmd [lrange $inf 1 end] set mapped_subcmd [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3630,11 +3705,14 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" set docid ""
} }
#puts stderr "cmd_traverse 'resolved' $mapped_subcmd" #allow subhelp override - todo: review/document rationale/usecases
break
} }
"subhelp" { "ensemblesubtarget" {
# -resolved-
#punk::args::ensemble_subcommands_definition
#This could be a list representing some other ensemble or command with pre-included arguments
set mapped_subcmd [lrange $inf 1 end] set mapped_subcmd [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3652,8 +3730,16 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" set docid ""
} }
#allow subhelp override - todo: review/document rationale/usecases #puts stderr "cmd_traverse 'resolved' $mapped_subcmd"
break }
"doctype" {
set d [lindex $inf 1]
switch -- $d {
"classmethod" {
}
"coremethod" {
}
}
} }
} }
} }
@ -3668,23 +3754,9 @@ tcl::namespace::eval punk::ns {
set mapped_subcmd "$raw_origin $resolved_q" set mapped_subcmd "$raw_origin $resolved_q"
set docid $mapped_subcmd set docid $mapped_subcmd
} else { } else {
#REVIEW - there is no reason to assume a subcommand (even in an ensemble) #NOTE there is no reason to assume a subcommand (even in an ensemble)
#will be located at "${raw_origin}::$resolved_q" #will be located at "${raw_origin}::$resolved_q"
#ensemble -map could point resolved_q somewhere else entirely #ensemble -map could point resolved_q somewhere else entirely
#punk::args::update_definitions [list $raw_origin]
#if {[punk::args::id_exists "${raw_origin}::$resolved_q"]} {
# set mapped_subcmd "${raw_origin}::$resolved_q"
# set docid $mapped_subcmd
#} else {
# if {![punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# namespace eval $ns [list punk::ns::generate_autodef "${raw_origin}::$resolved_q"]
# }
# if {[punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# set mapped_subcmd ${raw_origin}::$resolved_q
# set docid (autodef)${raw_origin}::$resolved_q
# }
#}
} }
} }
#puts "----------$mapped_subcmd" #puts "----------$mapped_subcmd"
@ -3695,13 +3767,18 @@ tcl::namespace::eval punk::ns {
#punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] #punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {[llength $queryargs_untested] == 0} { if {[llength $queryargs_untested] == 0} {
return [list 6 $mapped_subcmd $resolvedargs $queryargs_untested $docid] return [list 6 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]
} }
set origin [yield [list 0 $mapped_subcmd $resolvedargs $queryargs_untested $docid]] set origin [yield [list 0 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]]
#set resolvedargs [list] #set resolvedargs [list]
incr i [expr {-1 * [llength $resolvedargs]+1}] #incr i [expr {-1 * [llength $resolvedargs]+1}] ;#wrong e.g test trace add execution blah enterstep cmd
#puts stderr "... yield-result $origin i:$i" #JJJ
#puts stderr "... yield-result $origin i:$i args: $args"
ledit args $i+1 $i {*}$eparams
set eparams [list]
set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]] set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]]
set origin [dict get $whichinfo origin] set origin [dict get $whichinfo origin]
@ -3719,15 +3796,15 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
} }
break break ;#out of foreach q $queryargs ...
} else { } else {
#test with: i namespace which -v x #test with: i namespace which -v x
return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid] return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid]
} }
} } ;#end loop foreach q $queryargs lname $leadernames_matched
} else { } else {
#?? #??
puts stderr "cmdinfo.cmd_traverse returning 8 $origin $resolvedargs [lrange $args $i end] $docid" #puts stderr "cmdinfo.cmd_traverse returning 8 origin: $origin resolved: $resolvedargs remaining: [lrange $args $i end] docid: $docid"
return [list 8 $origin $resolvedargs [lrange $args $i end] $docid] return [list 8 $origin $resolvedargs [lrange $args $i end] $docid]
} }
} else { } else {
@ -3758,7 +3835,8 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::forms] set argd [::punk::args::parse $args withid ::punk::ns::forms]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context
set id [dict get $resolveinfo origin] #set id [dict get $resolveinfo origin]
set id [dict get $resolveinfo docid]
::punk::args::forms $id ::punk::args::forms $id
} }
@ -3778,8 +3856,10 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::eg] set argd [::punk::args::parse $args withid ::punk::ns::eg]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context
set resolved_id [dict get $resolveinfo origin] #set resolved_id [dict get $resolveinfo origin]
set result [::punk::args::eg $resolved_id] #set result [::punk::args::eg $resolved_id]
set docid [dict get $resolveinfo docid]
set result [::punk::args::eg $docid]
} }
@ -3849,7 +3929,30 @@ tcl::namespace::eval punk::ns {
#puts stderr [textblock::frame $syn] #puts stderr [textblock::frame $syn]
#set replaceuntil [expr {[llength $resolved_id]-1}] #set replaceuntil [expr {[llength $resolved_id]-1}]
set replaceuntil [expr {[llength $resolved_id]-1+$excess}] set replaceuntil [expr {[llength $resolved_id]-1+$excess}]
append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n #append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n ;#don't use join - will destroy braced sets
#e.g see s dict filter
#treating a somewhat arbitrary string $synline as a list here is a bit risky
#todo - consider always using 'punk::args::synopsis -return dict' and operating on that list to rebuild string - REVIEW
set adjusted_synline [lreplace $synline 0 $replaceuntil {*}$resolved_args] ;#don't use join - will destroy braced sets
#however - we don't want the extra bracing around ansi elements caused by list rep!
#::dict filter {dictionaryValue} script {keyVariable valueVariable} {script}
#vs
#::dict filter dictionaryValue script {keyVariable valueVariable} script
#(due to ansi in dictionaryValue and trailing script)
#manually join based on list length review
set lineout ""
foreach part $adjusted_synline {
if {[llength $part] == 1} {
append lineout " " $part
} else {
append lineout " " [list $part]
}
}
#must be no leading space for tests in test::punk::args synopsis.test
append resultstr [string trim $lineout] \n
} }
} }
set resultstr [string trimright $resultstr \n] set resultstr [string trimright $resultstr \n]
@ -4620,6 +4723,7 @@ tcl::namespace::eval punk::ns {
@values @values
}] }]
set i 0 set i 0
#for 9.1+ can use -integer
foreach a $arglist { foreach a $arglist {
switch -- [llength $a] { switch -- [llength $a] {
1 { 1 {
@ -4663,7 +4767,7 @@ tcl::namespace::eval punk::ns {
lassign $impl generaltype mname location methodtype lassign $impl generaltype mname location methodtype
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
dict set choiceinfodict $cmd {{doctype objectmethod}} dict set choiceinfodict $cmd {{doctype objectmethod}}
@ -4679,12 +4783,10 @@ tcl::namespace::eval punk::ns {
dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]]
} }
} }
if {[info commands ::punk::args::id_exists] ne ""} { if {[punk::args::id_exists $id]} {
if {[punk::args::id_exists $id]} { #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]"
#dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" dict lappend choiceinfodict $cmd {doctype punkargs}
dict lappend choiceinfodict $cmd {doctype punkargs} dict lappend choiceinfodict $cmd [list subhelp {*}$id]
dict lappend choiceinfodict $cmd [list subhelp {*}$id]
}
} }
break break
} }
@ -4842,7 +4944,6 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by arginfo) "(autogenerated by arginfo)
ensemble: ${$origin}" ensemble: ${$origin}"
@leaders -min 1
}] }]
if {[llength $parameters] == 0} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" append argdef \n "@leaders -min 1"
@ -4852,6 +4953,7 @@ tcl::namespace::eval punk::ns {
append argdef \n "$p -type string -help { (leading ensemble parameter)}" append argdef \n "$p -type string -help { (leading ensemble parameter)}"
} }
} }
append argdef \n "@values -unnamed true"
append argdef \n $vline append argdef \n $vline
punk::args::define $argdef punk::args::define $argdef
} }

2
src/vfs/_vfscommon.vfs/modules/punk/path-0.1.0.tm

@ -182,7 +182,7 @@ namespace eval punk::path {
proc normjoin {args} { proc normjoin {args} {
set args [lmap a $args {string map "\\\\ /" $a}] set args [lmap a $args {string map "\\\\ /" $a}]
set path [plainjoin {*}$args] set path [plainjoin {*}$args]
switch -exact $path { switch -exact -- $path {
"" { "" {
return "" return ""
} }

BIN
src/vfs/_vfscommon.vfs/modules/tarjar-2.4.3.tm

Binary file not shown.

BIN
src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm

Binary file not shown.

BIN
src/vfs/_vfscommon.vfs/modules/test/punk/lib-0.1.3.tm

Binary file not shown.

125
src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm

@ -4531,10 +4531,10 @@ tcl::namespace::eval textblock {
-help "existing table object to use" -help "existing table object to use"
-action -default "append" -choices {append replace}\ -action -default "append" -choices {append replace}\
-help "row insertion method if existing -table is supplied -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column" if append is chosen the new values will always start at the first column"
-title -type string -help\ -title -type string -help\
"Title to display overlayed on top edge of table. "Title to display overlayed on top edge of table.
Will not be visible if -show_edge is false" Will not be visible if -show_edge is false"
-titlealign -type string -choices {left centre right} -titlealign -type string -choices {left centre right}
-frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\
-help "frame type or dict for custom frame" -help "frame type or dict for custom frame"
@ -4545,32 +4545,32 @@ tcl::namespace::eval textblock {
-help "Show vertical table separators" -help "Show vertical table separators"
-show_hseps -default "" -type boolean\ -show_hseps -default "" -type boolean\
-help "Show horizontal table separators -help "Show horizontal table separators
(default 0 if no existing -table supplied)" (default 0 if no existing -table supplied)"
-colheaders -default "" -type list\ -colheaders -default "" -type list\
-help {list of lists. list of column header values. Outer list must match number of columns. -help {list of lists. list of column header values. Outer list must match number of columns.
A table A table
e.g single header row: -colheaders {{column_a} {column_b} {column_c}} e.g single header row: -colheaders {{column_a} {column_b} {column_c}}
e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}} e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}}
Note that each element of the outer list is itself a list so: Note that each element of the outer list is itself a list so:
-colheaders {"column a" "column b" "column c"} -colheaders {"column a" "column b" "column c"}
Is likely not the right format if it was intended to have a single header row where the Is likely not the right format if it was intended to have a single header row where the
column titles contain spaces. column titles contain spaces.
The correct syntax for that would be: The correct syntax for that would be:
-colheaders {{"column a"} {"column b"} {"column c"}} -colheaders {{"column a"} {"column b"} {"column c"}}
For spanning header cells - use 'set t [list_as_table -return tableobject ...]' For spanning header cells - use 'set t [list_as_table -return tableobject ...]'
and then something like: and then something like:
$t configure_header 1 -colspans {3 0 0}; $t print $t configure_header 1 -colspans {3 0 0}; $t print
} }
-header -default "" -type list -multiple 1\ -header -default "" -type list -multiple 1\
-help "Each supplied -header argument is a header row. -help "Each supplied -header argument is a header row.
The number of values for each must be <= number of columns" The number of values for each must be <= number of columns"
-show_header -type boolean\ -show_header -type boolean\
-help "Whether to show a header row. -help "Whether to show a header row.
Omit for unspecified/automatic, Omit for unspecified/automatic,
in which case it will display only if -headers list was supplied." in which case it will display only if -headers list was supplied."
-columns -default "" -type integer\ -columns -default "" -type integer\
-help "Number of table columns -help "Number of table columns
Will default to 2 if not using an existing -table object" 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" datalist -default {} -type list -help "flat list of table cell values which will be wrapped based on -columns value"
@ -4810,19 +4810,19 @@ tcl::namespace::eval textblock {
-choices {horizontal vertical}\ -choices {horizontal vertical}\
-help\ -help\
"Direction of character increments. "Direction of character increments.
When rainbow is in the colour list, When rainbow is in the colour list,
the colour stripes will be oriented the colour stripes will be oriented
in this direction. in this direction.
" "
@values -min 0 -max 1 @values -min 0 -max 1
colour -type list -default {} -optional 1 -help\ colour -type list -default {} -optional 1 -help\
"List of Ansi colour names "List of Ansi colour names
e.g. testblock -size 10 {white Red} e.g. testblock -size 10 {white Red}
produces a block of character 10x10 produces a block of character 10x10
with white text on red bacground with white text on red bacground
The additional pseudo-color 'rainbow' The additional pseudo-color 'rainbow'
is available. is available.
" "
} }
@ -5717,6 +5717,7 @@ tcl::namespace::eval textblock {
" "
-ansiresets -type any -default auto -ansiresets -type any -default auto
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
@values
blocks -type any -multiple 1 blocks -type any -multiple 1
} }
@ -6095,6 +6096,7 @@ tcl::namespace::eval textblock {
proc welcome_test {} { proc welcome_test {} {
package require punk::ansi package require punk::ansi
package require patternpunk
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]] set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]]
# Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com # Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com
set table [[textblock::spantest] print] set table [[textblock::spantest] print]
@ -6108,6 +6110,7 @@ tcl::namespace::eval textblock {
proc example {args} { proc example {args} {
set opts [tcl::dict::create -forcecolour 0] set opts [tcl::dict::create -forcecolour 0]
package require patternpunk
foreach {k v} $args { foreach {k v} $args {
switch -- $k { switch -- $k {
-forcecolour { -forcecolour {
@ -7981,54 +7984,55 @@ tcl::namespace::eval textblock {
frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\"" frame -type block -ansiborder [a+ blue Red] -ansibase [a+ black Red] \"A\\nB\""
-checkargs -default 1 -type boolean\ -checkargs -default 1 -type boolean\
-help "If true do extra argument checks and -help "If true do extra argument checks and
provide more comprehensive error info. provide more comprehensive error info.
As the argument parser loads around 16 default frame As the argument parser loads around 16 default frame
samples dynamically, this can add add up as each may samples dynamically, this can add add up as each may
take 10s of microseconds. For many-framed tables take 10s of microseconds. For many-framed tables
and other applications this can add up. and other applications this can add up.
Set false for performance improvement." Set false for performance improvement."
-etabs -default 0\ -etabs -default 0\
-help "expanding tabs - experimental/unimplemented." -help "expanding tabs - experimental/unimplemented."
#review - -choicelabels placeholder dollarsign of textblock::frame_samples must be left aligned with -choicelabels
-type -default light\ -type -default light\
-type dict\ -type dict\
-typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\ -typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\
-choices {${[textblock::frametypes]}}\ -choices {${[textblock::frametypes]}}\
-choicerestricted 0 -choicecolumns 8\ -choicerestricted 0 -choicecolumns 8\
-choicelabels { -choicelabels {
${[textblock::frame_samples]} ${[textblock::frame_samples]}
}\ }\
-help "Type of border for frame." -help "Type of border for frame."
-boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. -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. passing an empty string will result in no box, but title/subtitle will still appear if supplied.
${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}"
-boxmap -default {} -type dict -boxmap -default {} -type dict
-joins -default {} -type list -joins -default {} -type list
-title -default "" -type string -regexprefail {\n}\ -title -default "" -type string -regexprefail {\n}\
-help "Frame title placed on topbar - no newlines. -help "Frame title placed on topbar - no newlines.
May contain ANSI - no trailing reset required. May contain ANSI - no trailing reset required.
${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing
e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}"
-titlealign -default "centre" -choices {left centre right} -titlealign -default "centre" -choices {left centre right}
-subtitle -default "" -type string -regexprefail {\n}\ -subtitle -default "" -type string -regexprefail {\n}\
-help "Frame subtitle placed on bottombar - no newlines -help "Frame subtitle placed on bottombar - no newlines
May contain Ansi - no trailing reset required." May contain Ansi - no trailing reset required."
-subtitlealign -default "centre" -choices {left centre right} -subtitlealign -default "centre" -choices {left centre right}
-width -default "" -type int\ -width -default "" -type int\
-help "Width of resulting frame including borders. -help "Width of resulting frame including borders.
If omitted or empty-string, the width will be determined automatically based on content." If omitted or empty-string, the width will be determined automatically based on content."
-height -default "" -type int\ -height -default "" -type int\
-help "Height of resulting frame including borders." -help "Height of resulting frame including borders."
-ansiborder -default "" -type ansistring\ -ansiborder -default "" -type ansistring\
-help "Ansi escape sequence to set border attributes. -help "Ansi escape sequence to set border attributes.
${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents ${[textblock::EG]}e.g 1: frame -ansiborder [a+ web-red] contents
e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}" e.g 2: frame -ansiborder \"\\x1b\\\[31m\" contents${[textblock::RST]}"
-ansibase -default "" -type ansistring\ -ansibase -default "" -type ansistring\
-help "Default ANSI attributes within frame." -help "Default ANSI attributes within frame."
-blockalign -default centre -choices {left right centre}\ -blockalign -default centre -choices {left right centre}\
-help "Alignment of the content block within the frame." -help "Alignment of the content block within the frame."
-pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background -pad -default 1 -type boolean -help "Whether to pad within the ANSI so content background
extends within the content block inside the frame. extends within the content block inside the frame.
Has no effect if no ANSI in content." Has no effect if no ANSI in content."
-textalign -default left -choices {left right centre}\ -textalign -default left -choices {left right centre}\
-help "Alignment of text within the content block. (centre unimplemented)" -help "Alignment of text within the content block. (centre unimplemented)"
-ellipsis -default 1 -type boolean\ -ellipsis -default 1 -type boolean\
@ -8037,16 +8041,16 @@ tcl::namespace::eval textblock {
-buildcache -default 1 -type boolean -buildcache -default 1 -type boolean
-crm_mode -default 0 -type boolean\ -crm_mode -default 0 -type boolean\
-help "Show ANSI control characters within frame contents. -help "Show ANSI control characters within frame contents.
(Control Representation Mode) (Control Representation Mode)
Frame width doesn't adapt and content may be truncated Frame width doesn't adapt and content may be truncated
so -width may need to be manually set to display more." 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\ contents -default "" -type string\
-help "Frame contents - may be a block of text containing newlines and ANSI. -help "Frame contents - may be a block of text containing newlines and ANSI.
Text may be 'ragged' - ie unequal line-lengths. Text may be 'ragged' - ie unequal line-lengths.
No trailing ANSI reset required. No trailing ANSI reset required.
${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}" ${[textblock::EG]}e.g: frame \"[a+ blue White] \\nMy blue foreground text on\\nwhite background\\n\"${[textblock::RST]}"
} }
} }
@ -8915,15 +8919,16 @@ tcl::namespace::eval textblock {
} }
} }
punk::args::define { punk::args::define {
@id -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 -max_cross_size -default 0 -type integer -help\
Only cross sizes that divide the size of the overall block will be used. "Largest size cross to use to make up the block
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. Only cross sizes that divide the size of the overall block will be used.
Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) 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.
If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. 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 "
size -default 1 -type integer @values -min 0 -max 1
size -default 1 -type integer
} }
proc gcross {args} { proc gcross {args} {
set argd [punk::args::parse $args withid ::textblock::gcross] set argd [punk::args::parse $args withid ::textblock::gcross]

Loading…
Cancel
Save