Browse Source

punk::args fixes and more tclcore documentation

master
Julian Noble 1 week ago
parent
commit
ae2acc3d5f
  1. 56
      src/bootsupport/modules/argparsingtest-0.1.0.tm
  2. 6
      src/bootsupport/modules/commandstack-0.3.tm
  3. 25
      src/bootsupport/modules/modpod-0.1.3.tm
  4. 1
      src/bootsupport/modules/punk/aliascore-0.1.0.tm
  5. 14
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  6. 6400
      src/bootsupport/modules/punk/args-0.1.6.tm
  7. 6458
      src/bootsupport/modules/punk/args-0.1.7.tm
  8. 72
      src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  9. 37
      src/bootsupport/modules/punk/config-0.1.tm
  10. 8
      src/bootsupport/modules/punk/du-0.1.0.tm
  11. 4
      src/bootsupport/modules/punk/fileline-0.1.0.tm
  12. 1472
      src/bootsupport/modules/punk/lib-0.1.0.tm
  13. 29
      src/bootsupport/modules/punk/lib-0.1.2.tm
  14. 1061
      src/bootsupport/modules/punk/libunknown-0.1.tm
  15. 8
      src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
  16. 16
      src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm
  17. 39
      src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm
  18. 23
      src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  19. 1408
      src/bootsupport/modules/punk/ns-0.1.0.tm
  20. 2
      src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  21. 14
      src/bootsupport/modules/punk/repo-0.1.1.tm
  22. 179
      src/bootsupport/modules/punk/zip-0.1.1.tm
  23. 108
      src/bootsupport/modules/textblock-0.1.3.tm
  24. 56
      src/modules/argparsingtest-999999.0a1.0.tm
  25. 2
      src/modules/patternpunk-1.1.tm
  26. 46
      src/modules/punk-0.1.tm
  27. 1
      src/modules/punk/aliascore-999999.0a1.0.tm
  28. 14
      src/modules/punk/ansi-999999.0a1.0.tm
  29. 1939
      src/modules/punk/args-999999.0a1.0.tm
  30. 2
      src/modules/punk/args-buildversion.txt
  31. 1495
      src/modules/punk/args/tclcore-999999.0a1.0.tm
  32. 72
      src/modules/punk/cap/handlers/templates-999999.0a1.0.tm
  33. 37
      src/modules/punk/config-0.1.tm
  34. 8
      src/modules/punk/du-999999.0a1.0.tm
  35. 4
      src/modules/punk/fileline-999999.0a1.0.tm
  36. 23
      src/modules/punk/lib-999999.0a1.0.tm
  37. 2
      src/modules/punk/lib-buildversion.txt
  38. 8
      src/modules/punk/mix/commandset/doc-999999.0a1.0.tm
  39. 16
      src/modules/punk/mix/commandset/layout-999999.0a1.0.tm
  40. 39
      src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm
  41. 23
      src/modules/punk/nav/fs-999999.0a1.0.tm
  42. 60
      src/modules/punk/netbox-999999.0a1.0.tm
  43. 787
      src/modules/punk/netbox/man-999999.0a1.0.tm
  44. 1408
      src/modules/punk/ns-999999.0a1.0.tm
  45. 14
      src/modules/punk/repo-999999.0a1.0.tm
  46. 179
      src/modules/punk/zip-999999.0a1.0.tm
  47. 128
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test
  48. 125
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/define.test
  49. 60
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test
  50. 0
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/args.test#..+args+args.test.fauxlink
  51. 226
      src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm
  52. 3
      src/modules/test/punk/args-buildversion.txt
  53. 108
      src/modules/textblock-999999.0a1.0.tm
  54. 4
      src/project_layouts/custom/_project/punk.basic/src/make.tcl
  55. 56
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm
  56. 6
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm
  57. 25
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm
  58. 1
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  59. 14
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  60. 6400
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.6.tm
  61. 6458
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.7.tm
  62. 72
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  63. 37
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm
  64. 8
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm
  65. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm
  66. 4237
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm
  67. 1061
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
  68. 8
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
  69. 16
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm
  70. 39
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm
  71. 23
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  72. 1408
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  73. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  74. 14
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm
  75. 179
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
  76. 108
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  77. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl
  78. 56
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm
  79. 6
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm
  80. 25
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.3.tm
  81. 1
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm
  82. 14
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  83. 6400
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.6.tm
  84. 6458
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.7.tm
  85. 72
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  86. 37
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm
  87. 8
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm
  88. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm
  89. 4237
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm
  90. 1061
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm
  91. 8
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
  92. 16
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm
  93. 39
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm
  94. 23
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  95. 1408
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  96. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm
  97. 14
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm
  98. 179
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
  99. 108
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  100. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl
  101. Some files were not shown because too many files have changed in this diff Show More

56
src/bootsupport/modules/argparsingtest-0.1.0.tm

@ -10,7 +10,7 @@
# @@ Meta Begin # @@ Meta Begin
# Application argparsingtest 0.1.0 # Application argparsingtest 0.1.0
# Meta platform tcl # Meta platform tcl
# Meta license MIT # Meta license MIT
# @@ Meta End # @@ Meta End
@ -21,7 +21,7 @@
#[manpage_begin punkshell_module_argparsingtest 0 0.1.0] #[manpage_begin punkshell_module_argparsingtest 0 0.1.0]
#[copyright "2024"] #[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}] #[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require argparsingtest] #[require argparsingtest]
#[keywords module] #[keywords module]
#[description] #[description]
@ -106,7 +106,7 @@ namespace eval argparsingtest {
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest}] #[subsection {Namespace argparsingtest}]
#[para] Core API functions for argparsingtest #[para] Core API functions for argparsingtest
#[list_begin definitions] #[list_begin definitions]
proc test1_ni {args} { proc test1_ni {args} {
@ -277,8 +277,8 @@ namespace eval argparsingtest {
#punk::args is slower than argp - but comparable, and argp doesn't support solo flags #punk::args is slower than argp - but comparable, and argp doesn't support solo flags
proc test1_punkargs {args} { proc test1_punkargs {args} {
set argd [punk::args::parse $args withdef { set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs @id -id ::argparsingtest::test1_punkargs
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -298,7 +298,7 @@ namespace eval argparsingtest {
punk::args::define { punk::args::define {
@id -id ::test1_punkargs_by_id @id -id ::test1_punkargs_by_id
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -320,7 +320,7 @@ namespace eval argparsingtest {
punk::args::define { punk::args::define {
@id -id ::argparsingtest::test1_punkargs2 @id -id ::argparsingtest::test1_punkargs2
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -334,7 +334,7 @@ namespace eval argparsingtest {
-2 -default 2 -type integer -2 -default 2 -type integer
-3 -default 3 -type integer -3 -default 3 -type integer
@values @values
} }
proc test1_punkargs2 {args} { proc test1_punkargs2 {args} {
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
@ -342,9 +342,9 @@ namespace eval argparsingtest {
proc test1_punkargs_validate_ansistripped {args} { proc test1_punkargs_validate_ansistripped {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs_validate_ansistripped @id -id ::argparsingtest::test1_punkargs_validate_ansistripped
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -choices {string object} -help "return type" -return -default string -type string -choices {string object} -help "return type"
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -358,7 +358,7 @@ namespace eval argparsingtest {
-2 -default 2 -type integer -validate_ansistripped true -2 -default 2 -type integer -validate_ansistripped true
-3 -default 3 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true
@values @values
} $args] }]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
} }
@ -387,11 +387,11 @@ namespace eval argparsingtest {
package require cmdline package require cmdline
#cmdline::getoptions is much faster than typedGetoptions #cmdline::getoptions is much faster than typedGetoptions
proc test1_cmdline_untyped {args} { proc test1_cmdline_untyped {args} {
set cmdlineopts_untyped { set cmdlineopts_untyped {
{return.arg "string" "return val"} {return.arg "string" "return val"}
{frametype.arg \uFFEF "frame type"} {frametype.arg \uFFEF "frame type"}
{show_edge.arg \uFFEF "show table borders"} {show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"} {show_seps.arg \uFFEF "show table seps"}
{join "join the things"} {join "join the things"}
{x.arg "" "arg x"} {x.arg "" "arg x"}
{y.arg b "arg y"} {y.arg b "arg y"}
@ -405,11 +405,11 @@ namespace eval argparsingtest {
return [::cmdline::getoptions args $cmdlineopts_untyped $usage] return [::cmdline::getoptions args $cmdlineopts_untyped $usage]
} }
proc test1_cmdline_typed {args} { proc test1_cmdline_typed {args} {
set cmdlineopts_typed { set cmdlineopts_typed {
{return.arg "string" "return val"} {return.arg "string" "return val"}
{frametype.arg \uFFEF "frame type"} {frametype.arg \uFFEF "frame type"}
{show_edge.arg \uFFEF "show table borders"} {show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"} {show_seps.arg \uFFEF "show table seps"}
{join "join the things"} {join "join the things"}
{x.arg "" "arg x"} {x.arg "" "arg x"}
{y.arg b "arg y"} {y.arg b "arg y"}
@ -465,7 +465,7 @@ namespace eval argparsingtest {
#multiline values use first line of each record to determine amount of indent to trim #multiline values use first line of each record to determine amount of indent to trim
proc test_multiline {args} { proc test_multiline {args} {
set t3 [textblock::frame t3] set t3 [textblock::frame t3]
set argd [punk::args::get_dict [subst { set argd [punk::args::parse $args withdef [subst {
-template1 -default { -template1 -default {
****** ******
* t1 * * t1 *
@ -476,7 +476,7 @@ namespace eval argparsingtest {
* t2 * * t2 *
******} ******}
-template3 -default {$t3} -template3 -default {$t3}
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately
-template3b -default { -template3b -default {
$t3 $t3
----------------- -----------------
@ -491,20 +491,20 @@ namespace eval argparsingtest {
" "
-flag -default 0 -type boolean -flag -default 0 -type boolean
}] $args] }]]
return $argd return $argd
} }
#proc sample1 {p1 n args} { #proc sample1 {p1 n args} {
# #*** !doctools # #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1 # #[para]Description of sample1
# #[para] Arguments: # #[para] Arguments:
# # [list_begin arguments] # # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1. # # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n. # # [arg_def integer n] A description of integer argument n.
# # [list_end] # # [list_end]
# return "ok" # return "ok"
#} #}
@ -524,14 +524,14 @@ namespace eval argparsingtest::lib {
namespace path [namespace parent] namespace path [namespace parent]
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest::lib}] #[subsection {Namespace argparsingtest::lib}]
#[para] Secondary functions that are part of the API #[para] Secondary functions that are part of the API
#[list_begin definitions] #[list_begin definitions]
#proc utility1 {p1 args} { #proc utility1 {p1 args} {
# #*** !doctools # #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1 # #[para]Description of utility1
# return 1 # return 1
#} #}
@ -549,17 +549,17 @@ namespace eval argparsingtest::lib {
namespace eval argparsingtest::system { namespace eval argparsingtest::system {
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest::system}] #[subsection {Namespace argparsingtest::system}]
#[para] Internal functions that are not part of the API #[para] Internal functions that are not part of the API
} }
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready
package provide argparsingtest [namespace eval argparsingtest { package provide argparsingtest [namespace eval argparsingtest {
variable pkg argparsingtest variable pkg argparsingtest
variable version variable version
set version 0.1.0 set version 0.1.0
}] }]
return return

6
src/bootsupport/modules/commandstack-0.3.tm

@ -99,8 +99,11 @@ namespace eval commandstack {
} }
} }
proc get_stack {command} { proc get_stack {{command ""}} {
variable all_stacks variable all_stacks
if {$command eq ""} {
return $all_stacks
}
set command [uplevel 1 [list namespace which $command]] set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} { if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command] return [dict get $all_stacks $command]
@ -116,6 +119,7 @@ namespace eval commandstack {
variable all_stacks variable all_stacks
if {[dict exists $all_stacks $command]} { if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command] set stack [dict get $all_stacks $command]
#stack is a list of dicts, 1st entry is token {<cmd> <renamer> <tokenid>}
set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]]
if {$posn > -1} { if {$posn > -1} {
set record [lindex $stack $posn] set record [lindex $stack $posn]

25
src/bootsupport/modules/modpod-0.1.3.tm

@ -134,12 +134,12 @@ namespace eval modpod {
#old tar connect mechanism - review - not needed? #old tar connect mechanism - review - not needed?
proc connect {args} { proc connect {args} {
puts stderr "modpod::connect--->>$args" puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::modpod::connect @id -id ::modpod::connect
-type -default "" -type -default ""
@values -min 1 -max 1 @values -min 1 -max 1
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args] }]
catch { catch {
punk::lib::showdict $argd ;#heavy dependencies punk::lib::showdict $argd ;#heavy dependencies
} }
@ -168,7 +168,7 @@ namespace eval modpod {
} else { } else {
#connect to .tm but may still be unwrapped version available #connect to .tm but may still be unwrapped version available
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname $modpodpath] set this_pkg_tm_folder [file dirname $modpodpath]
if {$connected(type,$modpodpath) ne "unwrapped"} { if {$connected(type,$modpodpath) ne "unwrapped"} {
#Not directly connected to unwrapped version - but may still be redirected there #Not directly connected to unwrapped version - but may still be redirected there
@ -225,11 +225,15 @@ namespace eval modpod {
if {$connected(startdata,$modpodpath) >= 0} { if {$connected(startdata,$modpodpath) >= 0} {
#verify we have a valid tar header #verify we have a valid tar header
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} {
seek $fh $connected(startdata,$modpodpath) start seek $fh $connected(startdata,$modpodpath) start
return [list ok $fh] return [list ok $fh]
} else { } else {
#error "cannot verify tar header" #error "cannot verify tar header"
#try zipfs
if {[info commands tcl::zipfs::mount] ne ""} {
}
} }
} }
lpop connected(to) end lpop connected(to) end
@ -262,11 +266,12 @@ namespace eval modpod {
return 1 return 1
} }
proc get {args} { proc get {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::modpod::get
-from -default "" -help "path to pod" -from -default "" -help "path to pod"
*values -min 1 -max 1 @values -min 1 -max 1
filename filename
} $args] }]
set frompod [dict get $argd opts -from] set frompod [dict get $argd opts -from]
set filename [dict get $argd values filename] set filename [dict get $argd values filename]
@ -329,7 +334,7 @@ namespace eval modpod::lib {
#zipfile is a pure zip at this point - ie no script/exe header #zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} { proc make_zip_modpod {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::modpod::lib::make_zip_modpod @id -id ::modpod::lib::make_zip_modpod
-offsettype -default "archive" -choices {archive file} -help\ -offsettype -default "archive" -choices {archive file} -help\
"Whether zip offsets are relative to start of file or start of zip-data within the file. "Whether zip offsets are relative to start of file or start of zip-data within the file.
@ -340,7 +345,7 @@ namespace eval modpod::lib {
@values -min 2 -max 2 @values -min 2 -max 2
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm"
} $args] }]
set zipfile [dict get $argd values zipfile] set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile] set outfile [dict get $argd values outfile]
set opt_offsettype [dict get $argd opts -offsettype] set opt_offsettype [dict get $argd opts -offsettype]
@ -359,7 +364,7 @@ namespace eval modpod::lib {
set moddir [file dirname $modfile] set moddir [file dirname $modfile]
set mod_and_ver [file rootname [file tail $modfile]] set mod_and_ver [file rootname [file tail $modfile]]
lassign [split $mod_and_ver -] moduletail version lassign [split $mod_and_ver -] moduletail version
if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { if {[file exists $moddir/#modpod-$mod_and_ver]} {
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm
} else { } else {
#determine module namespace so we can mount appropriately #determine module namespace so we can mount appropriately

1
src/bootsupport/modules/punk/aliascore-0.1.0.tm

@ -135,6 +135,7 @@ tcl::namespace::eval punk::aliascore {
smcup ::punk::console::enable_alt_screen\ smcup ::punk::console::enable_alt_screen\
rmcup ::punk::console::disable_alt_screen\ rmcup ::punk::console::disable_alt_screen\
config ::punk::config\ config ::punk::config\
s ::punk::ns::synopsis\
] ]
#*** !doctools #*** !doctools

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

@ -3465,26 +3465,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
foreach {pt code} $parts { foreach {pt code} $parts {
switch -- [llength $codestack] { switch -- [llength $codestack] {
0 { 0 {
append emit $base$pt$R append emit $base $pt $R
} }
1 { 1 {
if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} {
append emit $base$pt$R append emit $base $pt $R
set codestack [list] set codestack [list]
} else { } else {
#append emit [lindex $o_codestack 0]$pt #append emit [lindex $o_codestack 0]$pt
if {$fullmerge} { if {$fullmerge} {
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R
} }
} }
} }
default { default {
if {$fullmerge} { if {$fullmerge} {
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R
} }
} }
} }
@ -3528,7 +3528,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append emit $code append emit $code
} }
} }
return $emit$R return [append emit $R]
} else { } else {
return $base$text$R return $base$text$R
} }

6400
src/bootsupport/modules/punk/args-0.1.6.tm

File diff suppressed because it is too large Load Diff

6458
src/bootsupport/modules/punk/args-0.1.7.tm

File diff suppressed because it is too large Load Diff

72
src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm

@ -250,16 +250,11 @@ namespace eval punk::cap::handlers::templates {
namespace export * namespace export *
namespace eval class { namespace eval class {
variable PUNKARGS variable PUNKARGS
#set argd [punk::args::get_dict { #lappend PUNKARGS [list {
# @id -id "::punk::cap::handlers::templates::class::api folders" # @id -id "::punk::cap::handlers::templates::class::api folders"
# -startdir -default "" # -startdir -default ""
# @values -max 0 # @values -max 0
#} $args] #}]
lappend PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api folders"
-startdir -default ""
@values -max 0
}]
oo::class create api { oo::class create api {
#return a dict keyed on folder with source pkg as value #return a dict keyed on folder with source pkg as value
@ -269,9 +264,18 @@ namespace eval punk::cap::handlers::templates {
set cname [string map {. _} $capname] set cname [string map {. _} $capname]
set capabilityname $capname set capabilityname $capname
} }
set class_ns [uplevel 1 [list namespace current]]
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api folders"
@cmd -name "punk::cap::handlers::templates::class::api folders"
-startdir -default "" -help\
"Defaults to CWD if not supplied"
@values -max 0
}]
method folders {args} { method folders {args} {
#puts "--folders $args" #puts "--folders $args"
set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] set argd [punk::args::parse $args withid "[self class] folders"]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set opt_startdir [dict get $opts -startdir] set opt_startdir [dict get $opts -startdir]
@ -488,14 +492,19 @@ namespace eval punk::cap::handlers::templates {
} }
return $folderdict return $folderdict
} }
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\
""
@opts -anyopts 1
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
}]
method get_itemdict_projectlayouts {args} { method get_itemdict_projectlayouts {args} {
set argd [punk::args::get_dict {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" set argd [punk::args::parse $args withid "[self class] get_itemdict_projectlayouts"]
@opts -anyopts 1
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
} $args]
set opt_startdir [dict get $argd opts -startdir] set opt_startdir [dict get $argd opts -startdir]
if {$opt_startdir eq ""} { if {$opt_startdir eq ""} {
@ -663,23 +672,26 @@ namespace eval punk::cap::handlers::templates {
my _get_itemdict {*}$arglist my _get_itemdict {*}$arglist
} }
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api _get_itemdict"
@cmd -name _get_itemdict
@opts -anyopts 0
-startdir -default ""
-templatefolder_subdir -optional 0
-command_get_items_from_base -optional 0
-command_get_item_name -optional 0
-not -default "" -multiple 1
@values -maxvalues -1
globsearches -default * -multiple 1
}]
#shared algorithm for get_itemdict_* methods #shared algorithm for get_itemdict_* methods
#requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search
#and a file selection mechanism command -command_get_items_from_base #and a file selection mechanism command -command_get_items_from_base
#and a name determining command -command_get_item_name #and a name determining command -command_get_item_name
method _get_itemdict {args} { method _get_itemdict {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid "[self class] _get_itemdict"]
@id -id "::punk::cap::handlers::templates::class::api _get_itemdict"
@cmd -name _get_itemdict
@opts -anyopts 0
-startdir -default ""
-templatefolder_subdir -optional 0
-command_get_items_from_base -optional 0
-command_get_item_name -optional 0
-not -default "" -multiple 1
@values -maxvalues -1
globsearches -default * -multiple 1
} $args]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results
#puts stderr "=-=============>globsearches:$globsearches" #puts stderr "=-=============>globsearches:$globsearches"

37
src/bootsupport/modules/punk/config-0.1.tm

@ -44,8 +44,11 @@ tcl::namespace::eval punk::config {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
proc dir {args} { proc dir {args} {
#set be_quiet [dict exists $received -quiet]
if {"-quiet" in $args} { if {"-quiet" in $args} {
set be_quiet [dict exists $received -quiet] set be_quiet 1
} else {
set be_quiet 0
} }
set was_noisy 0 set was_noisy 0
@ -445,6 +448,7 @@ tcl::namespace::eval punk::config {
"Get configuration values from a config. "Get configuration values from a config.
Accepts globs eg XDG*" Accepts globs eg XDG*"
@leaders -min 1 -max 1 @leaders -min 1 -max 1
#todo - load more whichconfig choices?
whichconfig -type string -choices {config startup-configuration running-configuration} whichconfig -type string -choices {config startup-configuration running-configuration}
@values -min 0 -max -1 @values -min 0 -max -1
globkey -type string -default * -optional 1 -multiple 1 globkey -type string -default * -optional 1 -multiple 1
@ -526,18 +530,23 @@ tcl::namespace::eval punk::config {
error "setting value not implemented" error "setting value not implemented"
} }
lappend PUNKARGS [list { namespace eval argdoc {
@dynamic set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}}
@id -id ::punk::config::show set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}}
@cmd -name punk::config::get -help\
"Display configuration values from a config. lappend PUNKARGS [list {
Accepts globs eg XDG*" @dynamic
@leaders -min 1 -max 1 @id -id ::punk::config::show
}\ @cmd -name punk::config::get -help\
{${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ "Display configuration values from a config.
"@values -min 0 -max -1"\ Accepts globs eg XDG*"
{${[punk::args::resolved_def -types values ::punk::config::get]}}\ @leaders -min 1 -max 1
] }\
{${$DYN_GET_LEADERS}}\
"@values -min 0 -max -1"\
{${$DYN_GET_VALUES}}\
]
}
proc show {args} { proc show {args} {
#todo - tables for console #todo - tables for console
set configrecords [punk::config::get {*}$args] set configrecords [punk::config::get {*}$args]
@ -568,7 +577,7 @@ tcl::namespace::eval punk::config {
toconfig -help\ toconfig -help\
"running or startup or file name (not fully implemented)" "running or startup or file name (not fully implemented)"
} }
set argd [punk::args::get_dict $argdef $args] set argd [punk::args::parse $args withdef $argdef]
set fromconfig [dict get $argd values fromconfig] set fromconfig [dict get $argd values fromconfig]
set toconfig [dict get $argd values toconfig] set toconfig [dict get $argd values toconfig]
set fromconfig [string map {-config ""} $fromconfig] set fromconfig [string map {-config ""} $fromconfig]

8
src/bootsupport/modules/punk/du-0.1.0.tm

@ -562,13 +562,13 @@ namespace eval punk::du {
proc Get_attributes_from_iteminfo {args} { proc Get_attributes_from_iteminfo {args} {
variable win_reparse_tags_by_int variable win_reparse_tags_by_int
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::du::lib::Get_attributes_from_iteminfo @id -id ::punk::du::lib::Get_attributes_from_iteminfo
-debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)"
-debugchannel -default stderr -help "channel to write debug output, or none to append to output" -debugchannel -default stderr -help "channel to write debug output, or none to append to output"
@values -min 1 -max 1 @values -min 1 -max 1
iteminfo -help "iteminfo dict as set by 'twapi::find_file_next <iterator> iteminfo'" iteminfo -help "iteminfo dict as set by 'twapi::find_file_next <iterator> iteminfo'"
} $args] }]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set iteminfo [dict get $argd values iteminfo] set iteminfo [dict get $argd values iteminfo]
set opt_debug [dict get $opts -debug] set opt_debug [dict get $opts -debug]
@ -621,14 +621,14 @@ namespace eval punk::du {
proc attributes_twapi {args} { proc attributes_twapi {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::du::lib::attributes_twapi @id -id ::punk::du::lib::attributes_twapi
-debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)"
-debugchannel -default stderr -help "channel to write debug output, or none to append to output" -debugchannel -default stderr -help "channel to write debug output, or none to append to output"
-detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field"
@values -min 1 -max 1 @values -min 1 -max 1
path -help "path to file or folder for which to retrieve attributes" path -help "path to file or folder for which to retrieve attributes"
} $args] }]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set path [dict get $argd values path] set path [dict get $argd values path]
set opt_detail [dict get $opts -detail] set opt_detail [dict get $opts -detail]

4
src/bootsupport/modules/punk/fileline-0.1.0.tm

@ -1559,9 +1559,9 @@ namespace eval punk::fileline::lib {
} }
proc range_boundaries {start end chunksizes args} { proc range_boundaries {start end chunksizes args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
-offset -default 0 -offset -default 0
} $args] }]
lassign [dict values $argd] leaders opts remainingargs lassign [dict values $argd] leaders opts remainingargs
} }

1472
src/bootsupport/modules/punk/lib-0.1.0.tm

File diff suppressed because it is too large Load Diff

29
src/bootsupport/modules/punk/lib-0.1.1.tm → src/bootsupport/modules/punk/lib-0.1.2.tm

@ -8,7 +8,7 @@
# (C) 2024 # (C) 2024
# #
# @@ Meta Begin # @@ Meta Begin
# Application punk::lib 0.1.1 # Application punk::lib 0.1.2
# Meta platform tcl # Meta platform tcl
# Meta license BSD # Meta license BSD
# @@ Meta End # @@ Meta End
@ -18,7 +18,7 @@
# doctools header # doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools #*** !doctools
#[manpage_begin punkshell_module_punk::lib 0 0.1.1] #[manpage_begin punkshell_module_punk::lib 0 0.1.2]
#[copyright "2024"] #[copyright "2024"]
#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] #[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk library}] [comment {-- Description at end of page heading --}] #[moddesc {punk library}] [comment {-- Description at end of page heading --}]
@ -1105,7 +1105,7 @@ namespace eval punk::lib {
} }
}] }]
#puts stderr "$argspec" #puts stderr "$argspec"
set argd [punk::args::get_dict $argspec $args] set argd [punk::args::parse $args withdef $argspec]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set dvar [dict get $argd values dictvar] set dvar [dict get $argd values dictvar]
@ -1147,7 +1147,7 @@ namespace eval punk::lib {
#package require punk ;#we need pipeline pattern matching features #package require punk ;#we need pipeline pattern matching features
package require textblock package require textblock
set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] {
@id -id ::punk::lib::showdict @id -id ::punk::lib::showdict
@cmd -name punk::lib::showdict -help "display dictionary keys and values" @cmd -name punk::lib::showdict -help "display dictionary keys and values"
#todo - table tableobject #todo - table tableobject
@ -1178,7 +1178,7 @@ namespace eval punk::lib {
"dict or list value" "dict or list value"
patterns -default "*" -type string -multiple 1 -help\ patterns -default "*" -type string -multiple 1 -help\
"key or key glob pattern" "key or key glob pattern"
}] $args] }]]
#for punk::lib - we want to reduce pkg dependencies. #for punk::lib - we want to reduce pkg dependencies.
# - so we won't even use the tcllib debug pkg here # - so we won't even use the tcllib debug pkg here
@ -2870,7 +2870,7 @@ namespace eval punk::lib {
proc list_as_lines {args} { proc list_as_lines {args} {
#*** !doctools #*** !doctools
#[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]]
#[para]This simply joines the elements of the list with -joinchar #[para]This simply joins the elements of the list with -joinchar
#[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines <le> #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines <le>
#[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line.
if {[set eop [lsearch $args --]] == [llength $args]-2} { if {[set eop [lsearch $args --]] == [llength $args]-2} {
@ -2890,12 +2890,11 @@ namespace eval punk::lib {
} }
proc list_as_lines2 {args} { proc list_as_lines2 {args} {
#eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible?
lassign [tcl::dict::values [punk::args::get_dict { lassign [tcl::dict::values [punk::args::parse $args withdef {
-joinchar -default \n -joinchar -default \n
@values -min 1 -max 1 @values -min 1 -max 1
} $args]] leaders opts values }]] leaders opts values
puts "opts:$opts"
puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]]
} }
@ -2932,10 +2931,10 @@ namespace eval punk::lib {
#-anyopts 1 avoids having to know what to say if odd numbers of options passed etc #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc
#we don't have to decide what is an opt vs a value #we don't have to decide what is an opt vs a value
#even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block)
lassign [tcl::dict::values [punk::args::get_dict { lassign [tcl::dict::values [punk::args::parse $args withdef {
@opts -any 1 @opts -any 1
-block -default {} -block -default {}
} $args]] leaderdict opts valuedict }]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict]
} }
@ -4198,10 +4197,10 @@ tcl::namespace::eval punk::lib::system {
#get info about punk nestindex key ie type: list,dict,undetermined #get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel # pdict devel
proc nestindex_info {args} { proc nestindex_info {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
-parent -default "" -parent -default ""
nestindex nestindex
} $args] }]
set opt_parent [dict get $argd opts -parent] set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} { if {$opt_parent eq ""} {
set parent_type undetermined set parent_type undetermined
@ -4229,7 +4228,7 @@ namespace eval ::punk::args::register {
package provide punk::lib [tcl::namespace::eval punk::lib { package provide punk::lib [tcl::namespace::eval punk::lib {
variable pkg punk::lib variable pkg punk::lib
variable version variable version
set version 0.1.1 set version 0.1.2
}] }]
return return

1061
src/bootsupport/modules/punk/libunknown-0.1.tm

File diff suppressed because it is too large Load Diff

8
src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm

@ -167,17 +167,17 @@ namespace eval punk::mix::commandset::doc {
cd $original_wd cd $original_wd
} }
proc validate {args} { proc validate {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::mix::commandset::doc::validate @id -id ::punk::mix::commandset::doc::validate
-- -type none -optional 1 -help "end of options marker --" -- -type none -optional 1 -help "end of options marker --"
-individual -type boolean -default 1 -individual -type boolean -default 1
@values -min 0 -max -1 @values -min 0 -max -1
patterns -default {*.man} -type any -multiple 1 patterns -default {*.man} -type any -multiple 1
} $args] }]
set opt_individual [tcl::dict::get $argd opts -individual] set opt_individual [tcl::dict::get $argd opts -individual]
set patterns [tcl::dict::get $argd values patterns] set patterns [tcl::dict::get $argd values patterns]
#todo - run and validate punk::docgen output #todo - run and validate punk::docgen output
set projectdir [punk::repo::find_project] set projectdir [punk::repo::find_project]
if {$projectdir eq ""} { if {$projectdir eq ""} {

16
src/bootsupport/modules/punk/mix/commandset/layout-0.1.0.tm

@ -113,14 +113,16 @@ namespace eval punk::mix::commandset::layout {
return [join $layouts \n] return [join $layouts \n]
} }
punk::args::define {
@id -id ::punk::mix::commandset::layout::collection::_default
@cmd -name ::punk::mix::commandset::layout::collection::_default
-startdir -type string
-not -type string -multiple 1
globsearches -default * -multiple 1
}
proc _default {args} { proc _default {args} {
punk::args::get_dict [subst { punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default
@id -id ::punk::mix::commandset::layout::collection::_default
@cmd -name ::punk::mix::commandset::layout::collection::_default
-startdir -type string
-not -type string -multiple 1
globsearches -default * -multiple 1
}] $args
set tdict_low_to_high [as_dict {*}$args] set tdict_low_to_high [as_dict {*}$args]
#convert to screen order - with higher priority at the top #convert to screen order - with higher priority at the top

39
src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm

@ -1249,29 +1249,28 @@ namespace eval punk::mix::commandset::scriptwrap {
namespace eval lib { namespace eval lib {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}]
#[para] Library API functions for punk::mix::commandset::scriptwrap #[para] Library API functions for punk::mix::commandset::scriptwrap
#[list_begin definitions] #[list_begin definitions]
punk::args::define {
@id -id ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders
#*** !doctools
#[call [fun get_wrapper_folders] [arg args] ]
#[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo
#[para] Arguments:
# [list_begin arguments]
# [arg_def string args] name-value pairs -scriptpath <path>
# [list_end]
@cmd -name punk::mix::commandset::scriptwrap::lib::get_wrapper_folders -help\
"Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo"
@opts -anyopts 0
-scriptpath -default "" -type directory\
-help ""
#todo -help folder within a punk.templates provided area???
@values -minvalues 0 -maxvalues 0
}
proc get_wrapper_folders {args} { proc get_wrapper_folders {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders]
#*** !doctools
#[call [fun get_wrapper_folders] [arg args] ]
#[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo
#[para] Arguments:
# [list_begin arguments]
# [arg_def string args] name-value pairs -scriptpath <path>
# [list_end]
@id -id ::punk::mix::commandset::scriptwrap
@cmd -name punk::mix::commandset::get_wrapper_folders
@opts -anyopts 0
-scriptpath -default "" -type directory\
-help ""
#todo -help folder within a punk.templates provided area???
@values -minvalues 0 -maxvalues 0
} $args]
# -- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- ---
set opt_scriptpath [dict get $argd opts -scriptpath] set opt_scriptpath [dict get $argd opts -scriptpath]

23
src/bootsupport/modules/punk/nav/fs-0.1.0.tm

@ -726,18 +726,19 @@ tcl::namespace::eval punk::nav::fs {
# #
#if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern.
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
punk::args::define {
@id -id ::punk::nav::fs::dirfiles_dict
@cmd -name punk::nav::fs::dirfiles_dict
@opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
}
proc dirfiles_dict {args} { proc dirfiles_dict {args} {
set argspecs { set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
@id -id ::punk::nav::fs::dirfiles_dict
@opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] leaders opts vals lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals] set searchspecs [dict values $vals]

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

File diff suppressed because it is too large Load Diff

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

@ -174,7 +174,7 @@ tcl::namespace::eval punk::packagepreference {
set is_exact 1 set is_exact 1
} else { } else {
set pkg [lindex $args 1] set pkg [lindex $args 1]
set vwant [lrange $args 2 end] ;#rare - but version can be a list of options set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements
if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} {
#only one version - and it has a dash #only one version - and it has a dash
lassign [split [lindex $vwant 0] -] a b lassign [split [lindex $vwant 0] -] a b

14
src/bootsupport/modules/punk/repo-0.1.1.tm

@ -100,8 +100,12 @@ namespace eval punk::repo {
subcommand -type string -choicecolumns 8 -choicegroups { subcommand -type string -choicecolumns 8 -choicegroups {
"frequently used commands" {${$maincommands}} "frequently used commands" {${$maincommands}}
"" {${$othercmds}} "" {${$othercmds}}
} } -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}}
}] }]
#-choiceinfo {
# add {{doctype punkargs}}
# diff {{doctype punkargs}}
#}
return $result return $result
} }
@ -112,7 +116,7 @@ namespace eval punk::repo {
# @id -id ::punk::repo::fossil_proxy # @id -id ::punk::repo::fossil_proxy
# @cmd -name fossil -help "fossil executable # @cmd -name fossil -help "fossil executable
# " # "
# @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} # @formdisplay -header "fossil help" -body {${[runout -n fossil help]}}
# } ""] # } ""]
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -129,7 +133,7 @@ namespace eval punk::repo {
@dynamic @dynamic
@id -id "::punk::repo::fossil_proxy diff" @id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff" -help "fossil diff" @cmd -name "fossil diff" -help "fossil diff"
@argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} @formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""] } ""]
lappend PUNKARGS [list { lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive #todo - remove this comment - testing dynamic directive
@ -137,7 +141,7 @@ namespace eval punk::repo {
@id -id "::punk::repo::fossil_proxy add" @id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add @cmd -name "fossil add" -help "fossil add
" "
@argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
} ""] } ""]
#TODO #TODO
#lappend PUNKARGS [list { #lappend PUNKARGS [list {
@ -145,7 +149,7 @@ namespace eval punk::repo {
# @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs}
# @cmd -name "fossil add" -help "fossil add # @cmd -name "fossil add" -help "fossil add
# " # "
# @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} # @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
# } ""] # } ""]
lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"}
lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"}

179
src/bootsupport/modules/punk/zip-0.1.1.tm

@ -168,45 +168,45 @@ tcl::namespace::eval punk::zip {
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) expr {(($year-1980) << 25) | ($month << 21) | ($day << 16)
| ($hour << 11) | ($min << 5) | ($sec >> 1)} | ($hour << 11) | ($min << 5) | ($sec >> 1)}
} }
punk::args::define {
@id -id ::punk::zip::walk
@cmd -name punk::zip::walk -help\
"Walk the directory structure starting at base/<-subpath>
and return a list of the files and folders encountered.
Resulting paths are relative to base unless -resultrelative
is supplied.
Folder names will end with a trailing slash.
"
-resultrelative -optional 1 -help\
"Resulting paths are relative to this value.
Defaults to the value of base. If empty string
is given to -resultrelative the paths returned
are effectively absolute paths."
-emptydirs -default 0 -type boolean -help\
"Whether to include directory trees in the result which had no
matches for the given fileglobs.
Intermediate dirs are always returned if there is a match with
fileglobs further down even if -emptdirs is 0.
"
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
}
proc walk {args} { proc walk {args} {
#*** !doctools #*** !doctools
#[call [fun walk] [arg ?options?] [arg base]] #[call [fun walk] [arg ?options?] [arg base]]
#[para] Walk a directory tree rooted at base #[para] Walk a directory tree rooted at base
#[para] the -excludes list can be a set of glob expressions to match against files and avoid #[para] the -excludes list can be a set of glob expressions to match against files and avoid
#[para] e.g #[para] e.g
#[example { #[example {
# punk::zip::walk -exclude {CVS/* *~.#*} library # punk::zip::walk -exclude {CVS/* *~.#*} library
#}] #}]
#todo: -relative 0|1 flag? #todo: -relative 0|1 flag?
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::walk]
@id -id ::punk::zip::walk
@cmd -name punk::zip::walk -help\
"Walk the directory structure starting at base/<-subpath>
and return a list of the files and folders encountered.
Resulting paths are relative to base unless -resultrelative
is supplied.
Folder names will end with a trailing slash.
"
-resultrelative -optional 1 -help\
"Resulting paths are relative to this value.
Defaults to the value of base. If empty string
is given to -resultrelative the paths returned
are effectively absolute paths."
-emptydirs -default 0 -type boolean -help\
"Whether to include directory trees in the result which had no
matches for the given fileglobs.
Intermediate dirs are always returned if there is a match with
fileglobs further down even if -emptdirs is 0.
"
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base] set base [dict get $argd values base]
set fileglobs [dict get $argd values fileglobs] set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath] set subpath [dict get $argd opts -subpath]
@ -416,6 +416,20 @@ tcl::namespace::eval punk::zip {
punk::args::define {
@id -id ::punk::zip::Addentry
@cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan'
return a central directory file record"
@opts
-comment -default "" -help "An optional comment specific to the added file"
@values -min 3 -max 4
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header"
base -help "base path for entries"
path -type file -help "path of file to add"
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'"
}
# Addentry - was Mkzipfile -- # Addentry - was Mkzipfile --
# #
# FIX ME: should handle the current offset for non-seekable channels # FIX ME: should handle the current offset for non-seekable channels
@ -428,20 +442,7 @@ tcl::namespace::eval punk::zip {
#[para] You can provide a -comment for the file. #[para] You can provide a -comment for the file.
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive.
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::Addentry]
@id -id ::punk::zip::Addentry
@cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan'
return a central directory file record"
@opts
-comment -default "" -help "An optional comment specific to the added file"
@values -min 3 -max 4
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header"
base -help "base path for entries"
path -type file -help "path of file to add"
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'"
} $args]
set zipchan [dict get $argd values zipchan] set zipchan [dict get $argd values zipchan]
set base [dict get $argd values base] set base [dict get $argd values base]
set path [dict get $argd values path] set path [dict get $argd values path]
@ -558,10 +559,55 @@ tcl::namespace::eval punk::zip {
# we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip)
#### ####
punk::args::define {
@id -id ::punk::zip::mkzip
@cmd -name punk::zip::mkzip\
-help "Create a zip archive in 'filename'"
@opts
-offsettype -default "archive" -choices {archive file}\
-help "zip offsets stored relative to start of entire file or relative to start of zip-archive
Only relevant if the created file has a script/runtime prefix.
"
-return -default "pretty" -choices {pretty list none}\
-help "mkzip can return a list of the files and folders added to the archive
the option -return pretty is the default and uses the punk::lib pdict/plist system
to return a formatted list for the terminal
"
-zipkit -default 0 -type none\
-help "whether to add mounting script
mutually exclusive with -runtime option
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs
"
-runtime -default ""\
-help "specify a prefix file
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip
will create a self-extracting zip archive from the subdir/ folder.
Expects runtime with no existing vfs attached (review)
"
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
-help "The new zip archive will scan for contents within this folder or current directory if not provided.
Note that this will
"
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"}
@values -min 1 -max -1
filename -type file -default ""\
-help "name of zipfile to create"
globs -default {*} -multiple 1\
-help "list of glob patterns to match.
Only directories with matching files will be included in the archive."
}
# zip::mkzip -- # zip::mkzip --
# #
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt
# #
proc mkzip {args} { proc mkzip {args} {
#todo - doctools - [arg ?globs...?] syntax? #todo - doctools - [arg ?globs...?] syntax?
@ -581,50 +627,7 @@ tcl::namespace::eval punk::zip {
#[para] If a file already exists, an error will be raised. #[para] If a file already exists, an error will be raised.
#[para] Call 'punk::zip::mkzip' with no arguments for usage display. #[para] Call 'punk::zip::mkzip' with no arguments for usage display.
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::mkzip]
@id -id ::punk::zip::mkzip
@cmd -name punk::zip::mkzip\
-help "Create a zip archive in 'filename'"
@opts
-offsettype -default "archive" -choices {archive file}\
-help "zip offsets stored relative to start of entire file or relative to start of zip-archive
Only relevant if the created file has a script/runtime prefix.
"
-return -default "pretty" -choices {pretty list none}\
-help "mkzip can return a list of the files and folders added to the archive
the option -return pretty is the default and uses the punk::lib pdict/plist system
to return a formatted list for the terminal
"
-zipkit -default 0 -type none\
-help "whether to add mounting script
mutually exclusive with -runtime option
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs
"
-runtime -default ""\
-help "specify a prefix file
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip
will create a self-extracting zip archive from the subdir/ folder.
Expects runtime with no existing vfs attached (review)
"
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
-help "The new zip archive will scan for contents within this folder or current directory if not provided.
Note that this will
"
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"}
@values -min 1 -max -1
filename -type file -default ""\
-help "name of zipfile to create"
globs -default {*} -multiple 1\
-help "list of glob patterns to match.
Only directories with matching files will be included in the archive."
} $args]
set filename [dict get $argd values filename] set filename [dict get $argd values filename]
if {$filename eq ""} { if {$filename eq ""} {
error "mkzip filename cannot be empty string" error "mkzip filename cannot be empty string"

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

@ -140,16 +140,18 @@ tcl::namespace::eval textblock {
# hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
# "algorithm choice" # "algorithm choice"
namespace eval argdoc {
punk::args::define { set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]}
@dynamic punk::args::define {
@id -id ::textblock::use_hash @dynamic
@cmd -name "textblock::use_hash" -help\ @id -id ::textblock::use_hash
"Hashing algorithm to use for framecache lookup. @cmd -name "textblock::use_hash" -help\
'none' may be slightly faster but less compact "Hashing algorithm to use for framecache lookup.
when viewing textblock::framecache" 'none' may be slightly faster but less compact
@values -min 0 -max 1 when viewing textblock::framecache"
hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} @values -min 0 -max 1
hash_algorithm -optional 1 ${$DYN_HASH_ALGORITHM_CHOICES_AND_HELP}
}
} }
proc use_hash {args} { proc use_hash {args} {
#set argd [punk::args::get_by_id ::textblock::use_hash $args] #set argd [punk::args::get_by_id ::textblock::use_hash $args]
@ -4667,17 +4669,19 @@ tcl::namespace::eval textblock {
-size -type integer\ -size -type integer\
-default 15\ -default 15\
-optional 1\ -optional 1\
-range {1 15} -range {1 ""}
-direction -default horizontal\ -direction -default horizontal\
-choices {horizontal vertical}\ -choices {horizontal vertical}\
-help\ -help\
"When rainbow is in the colour list, "Direction of character increments.
this also affects the direction of When rainbow is in the colour list,
colour changes" the colour stripes will be oriented
@values -min 0 -max 2 in this direction.
"
@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 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
@ -4725,7 +4729,16 @@ tcl::namespace::eval textblock {
set chars [list {*}[punk::lib::range 1 9] A B C D E F] set chars [list {*}[punk::lib::range 1 9] A B C D E F]
set charsubset [lrange $chars 0 $size-1] if {$size <= 15} {
set charsubset [lrange $chars 0 $size-1]
} else {
set numsets [expr {int(ceil($size / 15.0))}]
set longset [concat {*}[lrepeat $numsets $chars]]
set charsubset [lrange $longset 0 $size-1]
set longbows [concat {*}[lrepeat $numsets $rainbow_list]]
set rainbow_list [lrange $longbows 0 $size-1]
}
if {"noreset" in $colour} { if {"noreset" in $colour} {
set RST "" set RST ""
} else { } else {
@ -4760,21 +4773,32 @@ tcl::namespace::eval textblock {
append row $c append row $c
} }
append row $RST append row $RST
append block $row\n append block $row \n
} }
set block [tcl::string::trimright $block \n] set block [tcl::string::trimright $block \n]
return $block return $block
} else { } else {
#row first - if {$direction eq "vertical"} {
set rows [list] #row first -
foreach ch $charsubset { set rows [list]
lappend rows [tcl::string::repeat $ch $size] foreach ch $charsubset {
} lappend rows [tcl::string::repeat $ch $size]
set block [::join $rows \n] }
if {$colour ne ""} { set block [::join $rows \n]
set block [a+ {*}$colour]$block$RST if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
return $block
} else {
set block ""
for {set r 0} {$r < $size} {incr r} {
append block [::join $charsubset ""] \n
}
if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
return $block
} }
return $block
} }
} }
interp alias {} testblock {} textblock::testblock interp alias {} testblock {} textblock::testblock
@ -5500,10 +5524,11 @@ tcl::namespace::eval textblock {
proc ::textblock::join1 {args} { proc ::textblock::join1 {args} {
lassign [punk::args::get_dict { lassign [punk::args::parse $args withdef {
@id -id ::textblock::join1
-ansiresets -default 1 -type integer -ansiresets -default 1 -type integer
blocks -type string -multiple 1 blocks -type string -multiple 1
} $args] _l leaders _o opts _v values }] _l leaders _o opts _v values
set blocks [tcl::dict::get $values blocks] set blocks [tcl::dict::get $values blocks]
set idx 0 set idx 0
@ -5578,11 +5603,12 @@ tcl::namespace::eval textblock {
#@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width.
# Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
#" #"
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::textblock::join_basic2
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto -ansiresets -type any -default auto
blocks -type any -multiple 1 blocks -type any -multiple 1
} $args] }]
set ansiresets [tcl::dict::get $argd opts -ansiresets] set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks] set blocks [tcl::dict::get $argd values blocks]
@ -5619,12 +5645,6 @@ tcl::namespace::eval textblock {
#for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed
#they may however still be 'ragged' ie differing line lengths #they may however still be 'ragged' ie differing line lengths
proc ::textblock::join {args} { proc ::textblock::join {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
#we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets
@ -5709,11 +5729,6 @@ tcl::namespace::eval textblock {
} }
proc ::textblock::join2 {args} { proc ::textblock::join2 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
@ -5801,11 +5816,6 @@ tcl::namespace::eval textblock {
} }
# This calls textblock::pad per cell :/ # This calls textblock::pad per cell :/
proc ::textblock::join3 {args} { proc ::textblock::join3 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
@ -5984,7 +5994,7 @@ tcl::namespace::eval textblock {
NOTE: more options available - argument definition NOTE: more options available - argument definition
is incomplete" is incomplete"
@opts @opts
-return -choices {table tableobject} -return -default table -choices {table tableobject}
-rows -type list -default "" -help\ -rows -type list -default "" -help\
"A list of lists. "A list of lists.
Each toplevel element represents a row. Each toplevel element represents a row.
@ -6213,7 +6223,7 @@ tcl::namespace::eval textblock {
-help "restrict to keys matching memberglob." -help "restrict to keys matching memberglob."
}] }]
#append spec \n "frametype -help \"A predefined \"" #append spec \n "frametype -help \"A predefined \""
punk::args::get_dict $spec $args punk::args::parse $args withdef $spec
return return
} }

56
src/modules/argparsingtest-999999.0a1.0.tm

@ -10,7 +10,7 @@
# @@ Meta Begin # @@ Meta Begin
# Application argparsingtest 999999.0a1.0 # Application argparsingtest 999999.0a1.0
# Meta platform tcl # Meta platform tcl
# Meta license MIT # Meta license MIT
# @@ Meta End # @@ Meta End
@ -21,7 +21,7 @@
#[manpage_begin punkshell_module_argparsingtest 0 999999.0a1.0] #[manpage_begin punkshell_module_argparsingtest 0 999999.0a1.0]
#[copyright "2024"] #[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}] #[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require argparsingtest] #[require argparsingtest]
#[keywords module] #[keywords module]
#[description] #[description]
@ -106,7 +106,7 @@ namespace eval argparsingtest {
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest}] #[subsection {Namespace argparsingtest}]
#[para] Core API functions for argparsingtest #[para] Core API functions for argparsingtest
#[list_begin definitions] #[list_begin definitions]
proc test1_ni {args} { proc test1_ni {args} {
@ -277,8 +277,8 @@ namespace eval argparsingtest {
#punk::args is slower than argp - but comparable, and argp doesn't support solo flags #punk::args is slower than argp - but comparable, and argp doesn't support solo flags
proc test1_punkargs {args} { proc test1_punkargs {args} {
set argd [punk::args::parse $args withdef { set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs @id -id ::argparsingtest::test1_punkargs
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -298,7 +298,7 @@ namespace eval argparsingtest {
punk::args::define { punk::args::define {
@id -id ::test1_punkargs_by_id @id -id ::test1_punkargs_by_id
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -320,7 +320,7 @@ namespace eval argparsingtest {
punk::args::define { punk::args::define {
@id -id ::argparsingtest::test1_punkargs2 @id -id ::argparsingtest::test1_punkargs2
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -334,7 +334,7 @@ namespace eval argparsingtest {
-2 -default 2 -type integer -2 -default 2 -type integer
-3 -default 3 -type integer -3 -default 3 -type integer
@values @values
} }
proc test1_punkargs2 {args} { proc test1_punkargs2 {args} {
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
@ -342,9 +342,9 @@ namespace eval argparsingtest {
proc test1_punkargs_validate_ansistripped {args} { proc test1_punkargs_validate_ansistripped {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs_validate_ansistripped @id -id ::argparsingtest::test1_punkargs_validate_ansistripped
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -choices {string object} -help "return type" -return -default string -type string -choices {string object} -help "return type"
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -358,7 +358,7 @@ namespace eval argparsingtest {
-2 -default 2 -type integer -validate_ansistripped true -2 -default 2 -type integer -validate_ansistripped true
-3 -default 3 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true
@values @values
} $args] }]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
} }
@ -387,11 +387,11 @@ namespace eval argparsingtest {
package require cmdline package require cmdline
#cmdline::getoptions is much faster than typedGetoptions #cmdline::getoptions is much faster than typedGetoptions
proc test1_cmdline_untyped {args} { proc test1_cmdline_untyped {args} {
set cmdlineopts_untyped { set cmdlineopts_untyped {
{return.arg "string" "return val"} {return.arg "string" "return val"}
{frametype.arg \uFFEF "frame type"} {frametype.arg \uFFEF "frame type"}
{show_edge.arg \uFFEF "show table borders"} {show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"} {show_seps.arg \uFFEF "show table seps"}
{join "join the things"} {join "join the things"}
{x.arg "" "arg x"} {x.arg "" "arg x"}
{y.arg b "arg y"} {y.arg b "arg y"}
@ -405,11 +405,11 @@ namespace eval argparsingtest {
return [::cmdline::getoptions args $cmdlineopts_untyped $usage] return [::cmdline::getoptions args $cmdlineopts_untyped $usage]
} }
proc test1_cmdline_typed {args} { proc test1_cmdline_typed {args} {
set cmdlineopts_typed { set cmdlineopts_typed {
{return.arg "string" "return val"} {return.arg "string" "return val"}
{frametype.arg \uFFEF "frame type"} {frametype.arg \uFFEF "frame type"}
{show_edge.arg \uFFEF "show table borders"} {show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"} {show_seps.arg \uFFEF "show table seps"}
{join "join the things"} {join "join the things"}
{x.arg "" "arg x"} {x.arg "" "arg x"}
{y.arg b "arg y"} {y.arg b "arg y"}
@ -465,7 +465,7 @@ namespace eval argparsingtest {
#multiline values use first line of each record to determine amount of indent to trim #multiline values use first line of each record to determine amount of indent to trim
proc test_multiline {args} { proc test_multiline {args} {
set t3 [textblock::frame t3] set t3 [textblock::frame t3]
set argd [punk::args::get_dict [subst { set argd [punk::args::parse $args withdef [subst {
-template1 -default { -template1 -default {
****** ******
* t1 * * t1 *
@ -476,7 +476,7 @@ namespace eval argparsingtest {
* t2 * * t2 *
******} ******}
-template3 -default {$t3} -template3 -default {$t3}
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately
-template3b -default { -template3b -default {
$t3 $t3
----------------- -----------------
@ -491,20 +491,20 @@ namespace eval argparsingtest {
" "
-flag -default 0 -type boolean -flag -default 0 -type boolean
}] $args] }]]
return $argd return $argd
} }
#proc sample1 {p1 n args} { #proc sample1 {p1 n args} {
# #*** !doctools # #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1 # #[para]Description of sample1
# #[para] Arguments: # #[para] Arguments:
# # [list_begin arguments] # # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1. # # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n. # # [arg_def integer n] A description of integer argument n.
# # [list_end] # # [list_end]
# return "ok" # return "ok"
#} #}
@ -524,14 +524,14 @@ namespace eval argparsingtest::lib {
namespace path [namespace parent] namespace path [namespace parent]
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest::lib}] #[subsection {Namespace argparsingtest::lib}]
#[para] Secondary functions that are part of the API #[para] Secondary functions that are part of the API
#[list_begin definitions] #[list_begin definitions]
#proc utility1 {p1 args} { #proc utility1 {p1 args} {
# #*** !doctools # #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1 # #[para]Description of utility1
# return 1 # return 1
#} #}
@ -549,17 +549,17 @@ namespace eval argparsingtest::lib {
namespace eval argparsingtest::system { namespace eval argparsingtest::system {
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest::system}] #[subsection {Namespace argparsingtest::system}]
#[para] Internal functions that are not part of the API #[para] Internal functions that are not part of the API
} }
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready
package provide argparsingtest [namespace eval argparsingtest { package provide argparsingtest [namespace eval argparsingtest {
variable pkg argparsingtest variable pkg argparsingtest
variable version variable version
set version 999999.0a1.0 set version 999999.0a1.0
}] }]
return return

2
src/modules/patternpunk-1.1.tm

@ -346,7 +346,7 @@ _+ +_
package require punk::args package require punk::args
set standard_frame_types [textblock::frametypes] set standard_frame_types [textblock::frametypes]
set argd [punk::args::parse $args withdef [tstr -return string { set argd [punk::args::parse $args withdef [tstr -return string {
@id -id ">punk . deck" @id -id "::>punk . deck"
@cmd -name "deck" -help "Punk Deck mascot" @cmd -name "deck" -help "Punk Deck mascot"
-frame -default arc -choices "${$standard_frame_types}" -choicerestricted 0 -choiceprefix 1 -frame -default arc -choices "${$standard_frame_types}" -choicerestricted 0 -choiceprefix 1
-boxmap -default {} -type dict -boxmap -default {} -type dict

46
src/modules/punk-0.1.tm

@ -6798,28 +6798,30 @@ namespace eval punk {
return $linelist return $linelist
} }
namespace eval argdoc {
punk::args::define { set DYN_ANTIGLOB_PATHS {${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]}}
@dynamic punk::args::define {
@id -id ::punk::LOC @dynamic
@cmd -name punk::LOC -help\ @id -id ::punk::LOC
"LOC - lines of code. @cmd -name punk::LOC -help\
An implementation of a notoriously controversial metric" "LOC - lines of code.
-return -default showdict -choices {dict showdict} An implementation of a notoriously controversial metric"
-dir -default "\uFFFF" -return -default showdict -choices {dict showdict}
-exclude_dupfiles -default 1 -type boolean -dir -default "\uFFFF"
${[punk::args::resolved_def -types opts ::punk::path::treefilenames -antiglob_paths]} -exclude_dupfiles -default 1 -type boolean
-antiglob_files -default "" -type list -help\ ${$DYN_ANTIGLOB_PATHS}
"Exclude if file tail matches any of these patterns" -antiglob_files -default "" -type list -help\
-exclude_punctlines -default 1 -type boolean "Exclude if file tail matches any of these patterns"
-show_largest -default 0 -type integer -help\ -exclude_punctlines -default 1 -type boolean
"Report the top largest linecount files. -show_largest -default 0 -type integer -help\
The value represents the number of files "Report the top largest linecount files.
to report on." The value represents the number of files
} " to report on."
#we could map away whitespace and use string is punct - but not as flexible? review } "
-punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } #we could map away whitespace and use string is punct - but not as flexible? review
" -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] }
"
}
#An implementation of a notoriously controversial metric. #An implementation of a notoriously controversial metric.
proc LOC {args} { proc LOC {args} {
set argd [punk::args::parse $args withid ::punk::LOC] set argd [punk::args::parse $args withid ::punk::LOC]

1
src/modules/punk/aliascore-999999.0a1.0.tm

@ -135,6 +135,7 @@ tcl::namespace::eval punk::aliascore {
smcup ::punk::console::enable_alt_screen\ smcup ::punk::console::enable_alt_screen\
rmcup ::punk::console::disable_alt_screen\ rmcup ::punk::console::disable_alt_screen\
config ::punk::config\ config ::punk::config\
s ::punk::ns::synopsis\
] ]
#*** !doctools #*** !doctools

14
src/modules/punk/ansi-999999.0a1.0.tm

@ -3465,26 +3465,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
foreach {pt code} $parts { foreach {pt code} $parts {
switch -- [llength $codestack] { switch -- [llength $codestack] {
0 { 0 {
append emit $base$pt$R append emit $base $pt $R
} }
1 { 1 {
if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} {
append emit $base$pt$R append emit $base $pt $R
set codestack [list] set codestack [list]
} else { } else {
#append emit [lindex $o_codestack 0]$pt #append emit [lindex $o_codestack 0]$pt
if {$fullmerge} { if {$fullmerge} {
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R
} }
} }
} }
default { default {
if {$fullmerge} { if {$fullmerge} {
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R
} }
} }
} }
@ -3528,7 +3528,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append emit $code append emit $code
} }
} }
return $emit$R return [append emit $R]
} else { } else {
return $base$text$R return $base$text$R
} }

1939
src/modules/punk/args-999999.0a1.0.tm

File diff suppressed because it is too large Load Diff

2
src/modules/punk/args-buildversion.txt

@ -1,3 +1,3 @@
0.1.4 0.1.7
#First line must be a semantic version number #First line must be a semantic version number
#all other lines are ignored. #all other lines are ignored.

1495
src/modules/punk/args/tclcore-999999.0a1.0.tm

File diff suppressed because it is too large Load Diff

72
src/modules/punk/cap/handlers/templates-999999.0a1.0.tm

@ -250,16 +250,11 @@ namespace eval punk::cap::handlers::templates {
namespace export * namespace export *
namespace eval class { namespace eval class {
variable PUNKARGS variable PUNKARGS
#set argd [punk::args::get_dict { #lappend PUNKARGS [list {
# @id -id "::punk::cap::handlers::templates::class::api folders" # @id -id "::punk::cap::handlers::templates::class::api folders"
# -startdir -default "" # -startdir -default ""
# @values -max 0 # @values -max 0
#} $args] #}]
lappend PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api folders"
-startdir -default ""
@values -max 0
}]
oo::class create api { oo::class create api {
#return a dict keyed on folder with source pkg as value #return a dict keyed on folder with source pkg as value
@ -269,9 +264,18 @@ namespace eval punk::cap::handlers::templates {
set cname [string map {. _} $capname] set cname [string map {. _} $capname]
set capabilityname $capname set capabilityname $capname
} }
set class_ns [uplevel 1 [list namespace current]]
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api folders"
@cmd -name "punk::cap::handlers::templates::class::api folders"
-startdir -default "" -help\
"Defaults to CWD if not supplied"
@values -max 0
}]
method folders {args} { method folders {args} {
#puts "--folders $args" #puts "--folders $args"
set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] set argd [punk::args::parse $args withid "[self class] folders"]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set opt_startdir [dict get $opts -startdir] set opt_startdir [dict get $opts -startdir]
@ -488,14 +492,19 @@ namespace eval punk::cap::handlers::templates {
} }
return $folderdict return $folderdict
} }
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\
""
@opts -anyopts 1
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
}]
method get_itemdict_projectlayouts {args} { method get_itemdict_projectlayouts {args} {
set argd [punk::args::get_dict {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" set argd [punk::args::parse $args withid "[self class] get_itemdict_projectlayouts"]
@opts -anyopts 1
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
} $args]
set opt_startdir [dict get $argd opts -startdir] set opt_startdir [dict get $argd opts -startdir]
if {$opt_startdir eq ""} { if {$opt_startdir eq ""} {
@ -663,23 +672,26 @@ namespace eval punk::cap::handlers::templates {
my _get_itemdict {*}$arglist my _get_itemdict {*}$arglist
} }
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api _get_itemdict"
@cmd -name _get_itemdict
@opts -anyopts 0
-startdir -default ""
-templatefolder_subdir -optional 0
-command_get_items_from_base -optional 0
-command_get_item_name -optional 0
-not -default "" -multiple 1
@values -maxvalues -1
globsearches -default * -multiple 1
}]
#shared algorithm for get_itemdict_* methods #shared algorithm for get_itemdict_* methods
#requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search
#and a file selection mechanism command -command_get_items_from_base #and a file selection mechanism command -command_get_items_from_base
#and a name determining command -command_get_item_name #and a name determining command -command_get_item_name
method _get_itemdict {args} { method _get_itemdict {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid "[self class] _get_itemdict"]
@id -id "::punk::cap::handlers::templates::class::api _get_itemdict"
@cmd -name _get_itemdict
@opts -anyopts 0
-startdir -default ""
-templatefolder_subdir -optional 0
-command_get_items_from_base -optional 0
-command_get_item_name -optional 0
-not -default "" -multiple 1
@values -maxvalues -1
globsearches -default * -multiple 1
} $args]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results
#puts stderr "=-=============>globsearches:$globsearches" #puts stderr "=-=============>globsearches:$globsearches"

37
src/modules/punk/config-0.1.tm

@ -44,8 +44,11 @@ tcl::namespace::eval punk::config {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
proc dir {args} { proc dir {args} {
#set be_quiet [dict exists $received -quiet]
if {"-quiet" in $args} { if {"-quiet" in $args} {
set be_quiet [dict exists $received -quiet] set be_quiet 1
} else {
set be_quiet 0
} }
set was_noisy 0 set was_noisy 0
@ -445,6 +448,7 @@ tcl::namespace::eval punk::config {
"Get configuration values from a config. "Get configuration values from a config.
Accepts globs eg XDG*" Accepts globs eg XDG*"
@leaders -min 1 -max 1 @leaders -min 1 -max 1
#todo - load more whichconfig choices?
whichconfig -type string -choices {config startup-configuration running-configuration} whichconfig -type string -choices {config startup-configuration running-configuration}
@values -min 0 -max -1 @values -min 0 -max -1
globkey -type string -default * -optional 1 -multiple 1 globkey -type string -default * -optional 1 -multiple 1
@ -526,18 +530,23 @@ tcl::namespace::eval punk::config {
error "setting value not implemented" error "setting value not implemented"
} }
lappend PUNKARGS [list { namespace eval argdoc {
@dynamic set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}}
@id -id ::punk::config::show set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}}
@cmd -name punk::config::get -help\
"Display configuration values from a config. lappend PUNKARGS [list {
Accepts globs eg XDG*" @dynamic
@leaders -min 1 -max 1 @id -id ::punk::config::show
}\ @cmd -name punk::config::get -help\
{${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ "Display configuration values from a config.
"@values -min 0 -max -1"\ Accepts globs eg XDG*"
{${[punk::args::resolved_def -types values ::punk::config::get]}}\ @leaders -min 1 -max 1
] }\
{${$DYN_GET_LEADERS}}\
"@values -min 0 -max -1"\
{${$DYN_GET_VALUES}}\
]
}
proc show {args} { proc show {args} {
#todo - tables for console #todo - tables for console
set configrecords [punk::config::get {*}$args] set configrecords [punk::config::get {*}$args]
@ -568,7 +577,7 @@ tcl::namespace::eval punk::config {
toconfig -help\ toconfig -help\
"running or startup or file name (not fully implemented)" "running or startup or file name (not fully implemented)"
} }
set argd [punk::args::get_dict $argdef $args] set argd [punk::args::parse $args withdef $argdef]
set fromconfig [dict get $argd values fromconfig] set fromconfig [dict get $argd values fromconfig]
set toconfig [dict get $argd values toconfig] set toconfig [dict get $argd values toconfig]
set fromconfig [string map {-config ""} $fromconfig] set fromconfig [string map {-config ""} $fromconfig]

8
src/modules/punk/du-999999.0a1.0.tm

@ -562,13 +562,13 @@ namespace eval punk::du {
proc Get_attributes_from_iteminfo {args} { proc Get_attributes_from_iteminfo {args} {
variable win_reparse_tags_by_int variable win_reparse_tags_by_int
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::du::lib::Get_attributes_from_iteminfo @id -id ::punk::du::lib::Get_attributes_from_iteminfo
-debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)"
-debugchannel -default stderr -help "channel to write debug output, or none to append to output" -debugchannel -default stderr -help "channel to write debug output, or none to append to output"
@values -min 1 -max 1 @values -min 1 -max 1
iteminfo -help "iteminfo dict as set by 'twapi::find_file_next <iterator> iteminfo'" iteminfo -help "iteminfo dict as set by 'twapi::find_file_next <iterator> iteminfo'"
} $args] }]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set iteminfo [dict get $argd values iteminfo] set iteminfo [dict get $argd values iteminfo]
set opt_debug [dict get $opts -debug] set opt_debug [dict get $opts -debug]
@ -621,14 +621,14 @@ namespace eval punk::du {
proc attributes_twapi {args} { proc attributes_twapi {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::du::lib::attributes_twapi @id -id ::punk::du::lib::attributes_twapi
-debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)"
-debugchannel -default stderr -help "channel to write debug output, or none to append to output" -debugchannel -default stderr -help "channel to write debug output, or none to append to output"
-detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field"
@values -min 1 -max 1 @values -min 1 -max 1
path -help "path to file or folder for which to retrieve attributes" path -help "path to file or folder for which to retrieve attributes"
} $args] }]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set path [dict get $argd values path] set path [dict get $argd values path]
set opt_detail [dict get $opts -detail] set opt_detail [dict get $opts -detail]

4
src/modules/punk/fileline-999999.0a1.0.tm

@ -1559,9 +1559,9 @@ namespace eval punk::fileline::lib {
} }
proc range_boundaries {start end chunksizes args} { proc range_boundaries {start end chunksizes args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
-offset -default 0 -offset -default 0
} $args] }]
lassign [dict values $argd] leaders opts remainingargs lassign [dict values $argd] leaders opts remainingargs
} }

23
src/modules/punk/lib-999999.0a1.0.tm

@ -1105,7 +1105,7 @@ namespace eval punk::lib {
} }
}] }]
#puts stderr "$argspec" #puts stderr "$argspec"
set argd [punk::args::get_dict $argspec $args] set argd [punk::args::parse $args withdef $argspec]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set dvar [dict get $argd values dictvar] set dvar [dict get $argd values dictvar]
@ -1147,7 +1147,7 @@ namespace eval punk::lib {
#package require punk ;#we need pipeline pattern matching features #package require punk ;#we need pipeline pattern matching features
package require textblock package require textblock
set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] {
@id -id ::punk::lib::showdict @id -id ::punk::lib::showdict
@cmd -name punk::lib::showdict -help "display dictionary keys and values" @cmd -name punk::lib::showdict -help "display dictionary keys and values"
#todo - table tableobject #todo - table tableobject
@ -1178,7 +1178,7 @@ namespace eval punk::lib {
"dict or list value" "dict or list value"
patterns -default "*" -type string -multiple 1 -help\ patterns -default "*" -type string -multiple 1 -help\
"key or key glob pattern" "key or key glob pattern"
}] $args] }]]
#for punk::lib - we want to reduce pkg dependencies. #for punk::lib - we want to reduce pkg dependencies.
# - so we won't even use the tcllib debug pkg here # - so we won't even use the tcllib debug pkg here
@ -2870,7 +2870,7 @@ namespace eval punk::lib {
proc list_as_lines {args} { proc list_as_lines {args} {
#*** !doctools #*** !doctools
#[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]]
#[para]This simply joines the elements of the list with -joinchar #[para]This simply joins the elements of the list with -joinchar
#[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines <le> #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines <le>
#[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line.
if {[set eop [lsearch $args --]] == [llength $args]-2} { if {[set eop [lsearch $args --]] == [llength $args]-2} {
@ -2890,12 +2890,11 @@ namespace eval punk::lib {
} }
proc list_as_lines2 {args} { proc list_as_lines2 {args} {
#eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible?
lassign [tcl::dict::values [punk::args::get_dict { lassign [tcl::dict::values [punk::args::parse $args withdef {
-joinchar -default \n -joinchar -default \n
@values -min 1 -max 1 @values -min 1 -max 1
} $args]] leaders opts values }]] leaders opts values
puts "opts:$opts"
puts "values:$values"
return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]]
} }
@ -2932,10 +2931,10 @@ namespace eval punk::lib {
#-anyopts 1 avoids having to know what to say if odd numbers of options passed etc #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc
#we don't have to decide what is an opt vs a value #we don't have to decide what is an opt vs a value
#even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block)
lassign [tcl::dict::values [punk::args::get_dict { lassign [tcl::dict::values [punk::args::parse $args withdef {
@opts -any 1 @opts -any 1
-block -default {} -block -default {}
} $args]] leaderdict opts valuedict }]] leaderdict opts valuedict
tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict]
} }
@ -4198,10 +4197,10 @@ tcl::namespace::eval punk::lib::system {
#get info about punk nestindex key ie type: list,dict,undetermined #get info about punk nestindex key ie type: list,dict,undetermined
# pdict devel # pdict devel
proc nestindex_info {args} { proc nestindex_info {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
-parent -default "" -parent -default ""
nestindex nestindex
} $args] }]
set opt_parent [dict get $argd opts -parent] set opt_parent [dict get $argd opts -parent]
if {$opt_parent eq ""} { if {$opt_parent eq ""} {
set parent_type undetermined set parent_type undetermined

2
src/modules/punk/lib-buildversion.txt

@ -1,3 +1,3 @@
0.1.1 0.1.2
#First line must be a semantic version number #First line must be a semantic version number
#all other lines are ignored. #all other lines are ignored.

8
src/modules/punk/mix/commandset/doc-999999.0a1.0.tm

@ -167,17 +167,17 @@ namespace eval punk::mix::commandset::doc {
cd $original_wd cd $original_wd
} }
proc validate {args} { proc validate {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::mix::commandset::doc::validate @id -id ::punk::mix::commandset::doc::validate
-- -type none -optional 1 -help "end of options marker --" -- -type none -optional 1 -help "end of options marker --"
-individual -type boolean -default 1 -individual -type boolean -default 1
@values -min 0 -max -1 @values -min 0 -max -1
patterns -default {*.man} -type any -multiple 1 patterns -default {*.man} -type any -multiple 1
} $args] }]
set opt_individual [tcl::dict::get $argd opts -individual] set opt_individual [tcl::dict::get $argd opts -individual]
set patterns [tcl::dict::get $argd values patterns] set patterns [tcl::dict::get $argd values patterns]
#todo - run and validate punk::docgen output #todo - run and validate punk::docgen output
set projectdir [punk::repo::find_project] set projectdir [punk::repo::find_project]
if {$projectdir eq ""} { if {$projectdir eq ""} {

16
src/modules/punk/mix/commandset/layout-999999.0a1.0.tm

@ -113,14 +113,16 @@ namespace eval punk::mix::commandset::layout {
return [join $layouts \n] return [join $layouts \n]
} }
punk::args::define {
@id -id ::punk::mix::commandset::layout::collection::_default
@cmd -name ::punk::mix::commandset::layout::collection::_default
-startdir -type string
-not -type string -multiple 1
globsearches -default * -multiple 1
}
proc _default {args} { proc _default {args} {
punk::args::get_dict [subst { punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default
@id -id ::punk::mix::commandset::layout::collection::_default
@cmd -name ::punk::mix::commandset::layout::collection::_default
-startdir -type string
-not -type string -multiple 1
globsearches -default * -multiple 1
}] $args
set tdict_low_to_high [as_dict {*}$args] set tdict_low_to_high [as_dict {*}$args]
#convert to screen order - with higher priority at the top #convert to screen order - with higher priority at the top

39
src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm

@ -1249,29 +1249,28 @@ namespace eval punk::mix::commandset::scriptwrap {
namespace eval lib { namespace eval lib {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}]
#[para] Library API functions for punk::mix::commandset::scriptwrap #[para] Library API functions for punk::mix::commandset::scriptwrap
#[list_begin definitions] #[list_begin definitions]
punk::args::define {
@id -id ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders
#*** !doctools
#[call [fun get_wrapper_folders] [arg args] ]
#[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo
#[para] Arguments:
# [list_begin arguments]
# [arg_def string args] name-value pairs -scriptpath <path>
# [list_end]
@cmd -name punk::mix::commandset::scriptwrap::lib::get_wrapper_folders -help\
"Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo"
@opts -anyopts 0
-scriptpath -default "" -type directory\
-help ""
#todo -help folder within a punk.templates provided area???
@values -minvalues 0 -maxvalues 0
}
proc get_wrapper_folders {args} { proc get_wrapper_folders {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders]
#*** !doctools
#[call [fun get_wrapper_folders] [arg args] ]
#[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo
#[para] Arguments:
# [list_begin arguments]
# [arg_def string args] name-value pairs -scriptpath <path>
# [list_end]
@id -id ::punk::mix::commandset::scriptwrap
@cmd -name punk::mix::commandset::get_wrapper_folders
@opts -anyopts 0
-scriptpath -default "" -type directory\
-help ""
#todo -help folder within a punk.templates provided area???
@values -minvalues 0 -maxvalues 0
} $args]
# -- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- ---
set opt_scriptpath [dict get $argd opts -scriptpath] set opt_scriptpath [dict get $argd opts -scriptpath]

23
src/modules/punk/nav/fs-999999.0a1.0.tm

@ -726,18 +726,19 @@ tcl::namespace::eval punk::nav::fs {
# #
#if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern.
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
punk::args::define {
@id -id ::punk::nav::fs::dirfiles_dict
@cmd -name punk::nav::fs::dirfiles_dict
@opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
}
proc dirfiles_dict {args} { proc dirfiles_dict {args} {
set argspecs { set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
@id -id ::punk::nav::fs::dirfiles_dict
@opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] leaders opts vals lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals] set searchspecs [dict values $vals]

60
src/modules/punk/netbox-999999.0a1.0.tm

@ -1424,7 +1424,6 @@ tcl::namespace::eval punk::netbox::ipam {
NOTE1: tenant is the tenant_id (why?) NOTE1: tenant is the tenant_id (why?)
NOTE: This always uses next available IPs. NOTE: This always uses next available IPs.
To create a specific IP, use api/ipam/ip-addresses endpoint. To create a specific IP, use api/ipam/ip-addresses endpoint.
The returned json is just an object if one address created, The returned json is just an object if one address created,
but a list if multiple. :/ but a list if multiple. :/
@ -1434,6 +1433,65 @@ tcl::namespace::eval punk::netbox::ipam {
] ]
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_create api/ipam/prefixes/{id}/available-ips/ -verb post -body required ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_create api/ipam/prefixes/{id}/available-ips/ -verb post -body required
punk::args::define {*}[list\
{
@dynamic
@id -id ::punk::netbox::ipam::prefixes_available-prefixes_list
@cmd -name punk::netbox::ipam::prefixes_available-prefixes_list -help\
"ipam_prefixes_available-prefixes_list
GET request for endpoint /ipam/prefixes/{id}/available-prefixes/"
@leaders -min 1 -max 1
apicontextid -help\
"The name of the stored api context to use.
A contextid can be created in-memory using
api_context_create, or loaded from a .toml
file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}}
@opts
}\
[set ::punk::netbox::argdoc::_page_options]\
[set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\
[set ::punk::netbox::argdoc::_RETURN_LISTOFDICTS]\
{
@values -min 1 -max 1
id -type integer -help\
"A unique integer value identifying this prefix"
}\
]
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_list api/ipam/prefixes/{id}/available-prefixes/ -verb get -body none
punk::args::define {*}[list\
{
@dynamic
@id -id ::punk::netbox::ipam::prefixes_available-prefixes_create
@cmd -name punk::netbox::ipam::prefixes_available-prefixes_create -help\
"ipam_prefixes_available-prefixes_create
POST request for endpoint /ipam/prefixes/{id}/available-prefixes/"
@leaders -min 1 -max 1
apicontextid -help\
"The name of the stored api context to use.
A contextid can be created in-memory using
api_context_create, or loaded from a .toml
file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}}
@opts
}\
[set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\
[set ::punk::netbox::argdoc::_RETURN_LIST]\
{
@values -min 1 -max 2
id -type integer -help\
"A unique integer value identifying this prefix"
body -type string -default "" -help\
{
{
"prefix_length": 0
}
}
}\
]
::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_create api/ipam/prefixes/{id}/available-prefixes/ -verb post -body required
punk::args::define {*}[list\ punk::args::define {*}[list\
{ {
@dynamic @dynamic

787
src/modules/punk/netbox/man-999999.0a1.0.tm

@ -100,23 +100,68 @@ package require rest
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::netbox::man { tcl::namespace::eval punk::netbox::man {
namespace export {[a-z]*}
variable PUNKARGS variable PUNKARGS
namespace path ::punk::netbox
#review + ? #create ensemble further down - after sub ensembles exist
proc uri_part_decode {uripart} {
set specialMap {"[" "%5B" "]" "%5D" + " "} namespace eval contextcommands {
set seqRE {%([0-9a-fA-F]{2})} variable nextid 0
set replacement {[format "%c" [scan "\1" "%2x"]]} variable commandinfo [dict create]
set modstr [regsub -all $seqRE [string map $specialMap $uripart] $replacement] namespace export {man#*}
return [encoding convertfrom utf-8 [subst -nobackslash -novariable $modstr]] proc _cleanup {id args} {
#called by trace on command deletion (trace target must accept args even though not used)
variable commandinfo
dict unset $commandinfo $id
}
proc info {id} {
variable commandinfo
punk::netbox::api_contexts [dict get $commandinfo $id context]
}
} }
proc uri_get_querystring_as_keyval_list {uri} { punk::args::define {*}[list\
set parts [uri::split $uri] {
set query ?[dict get $parts query] @dynamic
set raw_plist [rest::parameters $query] ;#not a dict - can have repeated params (important for <name>_FILTER methods) @id -id ::punk::netbox::man::new
return [lmap v $raw_plist {uri_part_decode $v}] @cmd -name punk::netbox::man::new -help\
"Create a command with the apicontextid 'curried' in.
e.g
set svr1 [man tclread new]
$svr1 status
$svr1 tenancy tenants list"
@leaders -min 1 -max 1
apicontextid -help\
"The name of the stored api context to use.
A contextid can be created in-memory using
api_context_create, or loaded from a .toml
file using api_context_load."\
-choices {${[punk::netbox::api_context_names]}}
@opts
}\
]
proc new {args} {
set argd [punk::args::parse $args withid ::punk::netbox::man::new]
set apicontextid [dict get $argd leaders apicontextid]
upvar ::punk::netbox::man::contextcommands::nextid nextid
upvar ::punk::netbox::man::contextcommands::commandinfo commandinfo
set objname "::punk::netbox::man::contextcommands::man#[incr nextid]"
dict set commandinfo $nextid context $apicontextid
set map [dict create\
about [list ::punk::netbox::man::about]\
status [list ::punk::netbox::status $apicontextid]\
info [list ::punk::netbox::man::contextcommands::info $nextid]\
destroy [list ::rename $objname ""]\
]
set nslist [punk::ns::nslist_dict ::punk::netbox::man::*]
set info [lindex $nslist 0]
set subensembles [dict get $info ensembles]
foreach se $subensembles {
#e.g ip-addresses, tenancy
dict set map $se [list ::punk::netbox::man $apicontextid $se]
}
namespace ensemble create -command $objname -map $map
trace add command $objname delete [list ::punk::netbox::man::contextcommands::_cleanup $nextid]
return $objname
} }
} }
@ -131,11 +176,11 @@ tcl::namespace::eval punk::netbox::man::prefixes {
#[list_begin definitions] #[list_begin definitions]
namespace export {[a-z]*} namespace export {[a-z]*}
namespace ensemble create namespace ensemble create -parameters {apicontextid}
variable PUNKARGS variable PUNKARGS
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
[punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes list"}} ::punk::netbox::ipam::prefixes_list]\ [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes::list"}} ::punk::netbox::ipam::prefixes_list]\
{-RETURN -default table -choices {table tableobject list}}\ {-RETURN -default table -choices {table tableobject list}}\
{-MAXRESULTS -type integer -default -1}\ {-MAXRESULTS -type integer -default -1}\
{@values -min 0 -max 0}\ {@values -min 0 -max 0}\
@ -143,12 +188,12 @@ tcl::namespace::eval punk::netbox::man::prefixes {
#caution: must use ::list to avoid loop #caution: must use ::list to avoid loop
proc list {args} { proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes list"] set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::list"]
set token tclread ;#todo
set urlnext "" set urlnext ""
set requests_allowed 1000 ;#review set requests_allowed 1000 ;#review
set resultlist [::list] set resultlist [::list]
set token [dict get $argd leaders apicontextid]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set vals [dict get $argd values] set vals [dict get $argd values]
set multis [dict get $argd multis] set multis [dict get $argd multis]
@ -179,7 +224,7 @@ tcl::namespace::eval punk::netbox::man::prefixes {
set to_go [expr {$maxresults - [llength $resultlist]}] set to_go [expr {$maxresults - [llength $resultlist]}]
while {$urlnext ne "null"} { while {$urlnext ne "null"} {
if {$urlnext ne ""} { if {$urlnext ne ""} {
set urlnext_params [punk::netbox::man::uri_get_querystring_as_keyval_list $urlnext] set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext]
if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} {
punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go
} }
@ -240,117 +285,606 @@ tcl::namespace::eval punk::netbox::man::prefixes {
#return [showdict $resultd] #return [showdict $resultd]
} }
tcl::namespace::eval available-ips {
namespace export {[a-z]*}
namespace ensemble create -parameters {apicontextid}
variable PUNKARGS
lappend PUNKARGS [::list\
[punk::args::resolved_def\
-antiglobs {@leaders -offset}\
-override {\
@id {-id "::punk::netbox::man::prefixes::available-ips::create"}\
-RETURN {-default table -choices {list linelist showlistofdicts}}\
@values {-min 2 -max 2}\
body {-optional 0}\
}\
::punk::netbox::ipam::prefixes_available-ips_create\
]\
]
proc create {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::create"]
set resultlist [::list]
set token [dict get $argd leaders apicontextid]
set opts [dict get $argd opts]
set valuedict [dict get $argd values]
set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func
set multis [dict get $argd multis]
set outer_return [dict get $opts -RETURN]
set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely
#we can't just pass through 'multi' opts even if only one was supplied - list level is wrong
set nextopts [::list]
dict for {opt val} $opts {
if {$opt ni $multis} {
lappend nextopts $opt $val
} else {
foreach v $val {
lappend nextopts $opt $v
}
}
}
#Now opts is a list with possible repeated options! (for flags that have -multiple true)
set resultlist [punk::netbox::ipam::prefixes_available-ips_create $token {*}$nextopts -RETURN list {*}$vals]
switch -- $outer_return {
linelist {
set ret ""
foreach r $resultlist {
append ret $r \n
}
return $ret
}
showlistofdicts {
return [punk::lib::showdict $resultlist {@*/@*.@*}]
}
jsondump {
#todo
package require huddle::json
#pretty-print via huddle (inefficient review)
set h [huddle::json::json2huddle parse $resultlist]
return [huddle::jsondump $h]
}
default {
return $resultlist
}
}
#lappend PUNKARGS [::list\
# [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\
# {-RETURN -default table -choices {table tableobject list}}
# ]
lappend PUNKARGS [::list\
[punk::args::resolved_def\
-antiglobs {apicontextid @leaders -offset}\
-override {\
@id {-id "::punk::netbox::man::prefixes available-ips_list"}\
-limit {-default 254 -help "Maximum number of entries to return"}\
-RETURN {-default table -choices {table tableobject list linelist}}\
@values {-min 1 -max 1}\
}\
::punk::netbox::ipam::prefixes_available-ips_list\
]\
]
proc available-ips_list {args} { }
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes available-ips_list"]
set token tclread ;#todo
set resultlist [::list] #lappend PUNKARGS [::list\
set opts [dict get $argd opts] # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\
set valuedict [dict get $argd values] # {-RETURN -default table -choices {table tableobject list}}
set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func # ]
set multis [dict get $argd multis] lappend PUNKARGS [::list\
set outer_return [dict get $opts -RETURN] [punk::args::resolved_def\
set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely -antiglobs {@leaders -offset}\
#we can't just pass through 'multi' opts even if only one was supplied - list level is wrong -override {\
set nextopts [::list] @id {-id "::punk::netbox::man::prefixes::available-ips::list"}\
dict for {opt val} $opts { -limit {-default 254 -help "Maximum number of entries to return"}\
if {$opt ni $multis} { -RETURN {-default table -choices {table tableobject list linelist}}\
lappend nextopts $opt $val @values {-min 1 -max 1}\
} else { }\
foreach v $val { ::punk::netbox::ipam::prefixes_available-ips_list\
lappend nextopts $opt $v ]\
]
proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::list"]
set resultlist [::list]
set token [dict get $argd leaders apicontextid]
set opts [dict get $argd opts]
set valuedict [dict get $argd values]
set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func
set multis [dict get $argd multis]
set outer_return [dict get $opts -RETURN]
set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely
#we can't just pass through 'multi' opts even if only one was supplied - list level is wrong
set nextopts [::list]
dict for {opt val} $opts {
if {$opt ni $multis} {
lappend nextopts $opt $val
} else {
foreach v $val {
lappend nextopts $opt $v
}
}
}
#Now opts is a list with possible repeated options! (for flags that have -multiple true)
#No paging available at endpoint ipam/prefixes/available-ips - but we can still use limit (but offset doesn't seem to work)
#REVIEW - no way to know if *all* available in a prefix were returned - could/should? have been limited by server setting
#Especially in an ipv6 context - we're *very* unlikely to want to try to get all! (even for a /16 ipv4 it's probably not a very sensible query)
#Default netbox server limit seems to be 1000? review
#setting -limit 0 seems to allow this to be overridden - giving results bounded only by size of the prefix?
set resultlist [punk::netbox::ipam::prefixes_available-ips_list $token {*}$nextopts -RETURN list {*}$vals]
if {$outer_return in {table tableobject}} {
package require textblock
set t [textblock::list_as_table -return tableobject -colheaders {address family vrf}]
foreach ip $resultlist {
if {[dict exists $ip vrf id]} {
set vrfinfo "[dict get $ip vrf id]: [dict get $ip vrf name]"
} else {
set vrfinfo "-"
}
set r [::list\
[dict get $ip address]\
[dict get $ip family]\
$vrfinfo\
]
$t add_row $r
} }
} }
switch -- $outer_return {
table {
set result [$t print]
$t destroy
return $result
}
tableobject {
return $t
}
linelist {
set ret ""
foreach r $resultlist {
append ret $r \n
}
return $ret
}
jsondump {
#todo
package require huddle::json
#pretty-print via huddle (inefficient review)
set h [huddle::json::json2huddle parse $result]
return [huddle::jsondump $h]
}
default {
return $resultlist
}
}
#return [showdict $resultd]
} }
#Now opts is a list with possible repeated options! (for flags that have -multiple true)
#No paging available at endpoint ipam/prefixes/available-ips - but we can still use limit (but offset doesn't seem to work)
#REVIEW - no way to know if *all* available in a prefix were returned - could/should? have been limited by server setting
#Especially in an ipv6 context - we're *very* unlikely to want to try to get all! (even for a /16 ipv4 it's probably not a very sensible query)
#Default netbox server limit seems to be 1000? review
#setting -limit 0 seems to allow this to be overridden - giving results bounded only by size of the prefix?
set resultlist [punk::netbox::ipam::prefixes_available-ips_list $token {*}$nextopts -RETURN list {*}$vals]
if {$outer_return in {table tableobject}} { }
package require textblock
set t [textblock::list_as_table -return tableobject -colheaders {address family vrf}] tcl::namespace::eval available-prefixes {
foreach ip $resultlist { namespace export {[a-z]*}
if {[dict exists $ip vrf id]} { namespace ensemble create -parameters {apicontextid}
set vrfinfo "[dict get $ip vrf id]: [dict get $ip vrf name]" variable PUNKARGS
lappend PUNKARGS [::list\
[punk::args::resolved_def\
-antiglobs {@leaders -offset}\
-override {\
@id {-id "::punk::netbox::man::prefixes::available-prefixes::create"}\
-RETURN {-default table -choices {list linelist showlistofdicts}}\
@values {-min 2 -max 2}\
body {-optional 0}\
}\
::punk::netbox::ipam::prefixes_available-prefixes_create\
]\
]
proc create {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::create"]
set resultlist [::list]
set token [dict get $argd leaders apicontextid]
set opts [dict get $argd opts]
set valuedict [dict get $argd values]
set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func
set multis [dict get $argd multis]
set outer_return [dict get $opts -RETURN]
set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely
#we can't just pass through 'multi' opts even if only one was supplied - list level is wrong
set nextopts [::list]
dict for {opt val} $opts {
if {$opt ni $multis} {
lappend nextopts $opt $val
} else { } else {
set vrfinfo "-" foreach v $val {
lappend nextopts $opt $v
}
} }
set r [::list\
[dict get $ip address]\
[dict get $ip family]\
$vrfinfo\
]
$t add_row $r
}
}
switch -- $outer_return {
table {
set result [$t print]
$t destroy
return $result
} }
tableobject { #Now opts is a list with possible repeated options! (for flags that have -multiple true)
return $t set resultlist [punk::netbox::ipam::prefixes_available-prefixes_create $token {*}$nextopts -RETURN list {*}$vals]
switch -- $outer_return {
linelist {
set ret ""
foreach r $resultlist {
append ret $r \n
}
return $ret
}
showlistofdicts {
return [punk::lib::showdict $resultlist {@*/@*.@*}]
}
jsondump {
#todo
package require huddle::json
#pretty-print via huddle (inefficient review)
set h [huddle::json::json2huddle parse $resultlist]
return [huddle::jsondump $h]
}
default {
return $resultlist
}
} }
linelist {
set ret ""
foreach r $resultlist { }
append ret $r \n
#lappend PUNKARGS [::list\
# [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\
# {-RETURN -default table -choices {table tableobject list}}
# ]
lappend PUNKARGS [::list\
[punk::args::resolved_def\
-antiglobs {@leaders -offset}\
-override {\
@id {-id "::punk::netbox::man::prefixes::available-prefixes::list"}\
-limit {-default 254 -help "Maximum number of entries to return"}\
-RETURN {-default table -choices {table tableobject list linelist}}\
@values {-min 1 -max 1}\
}\
::punk::netbox::ipam::prefixes_available-prefixes_list\
]\
]
proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::list"]
set resultlist [::list]
set token [dict get $argd leaders apicontextid]
set opts [dict get $argd opts]
set valuedict [dict get $argd values]
set vals [dict values $valuedict] ;#we don't need the keys to pass on to next func
set multis [dict get $argd multis]
set outer_return [dict get $opts -RETURN]
set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely
#we can't just pass through 'multi' opts even if only one was supplied - list level is wrong
set nextopts [::list]
dict for {opt val} $opts {
if {$opt ni $multis} {
lappend nextopts $opt $val
} else {
foreach v $val {
lappend nextopts $opt $v
}
} }
return $ret
} }
jsondump { #Now opts is a list with possible repeated options! (for flags that have -multiple true)
#todo
package require huddle::json set resultlist [punk::netbox::ipam::prefixes_available-prefixes_list $token {*}$nextopts -RETURN list {*}$vals]
#pretty-print via huddle (inefficient review)
set h [huddle::json::json2huddle parse $result] if {$outer_return in {table tableobject}} {
return [huddle::jsondump $h] package require textblock
set t [textblock::list_as_table -return tableobject -colheaders {address family vrf}]
foreach pfx $resultlist {
if {[dict exists $pfx vrf id]} {
set vrfinfo "[dict get $pfx vrf id]: [dict get $pfx vrf name]"
} else {
set vrfinfo "-"
}
set r [::list\
[dict get $pfx prefix]\
[dict get $pfx family]\
$vrfinfo\
]
$t add_row $r
}
} }
default { switch -- $outer_return {
return $resultlist table {
set result [$t print]
$t destroy
return $result
}
tableobject {
return $t
}
linelist {
set ret ""
foreach r $resultlist {
append ret $r \n
}
return $ret
}
jsondump {
#todo
package require huddle::json
#pretty-print via huddle (inefficient review)
set h [huddle::json::json2huddle parse $result]
return [huddle::jsondump $h]
}
default {
return $resultlist
}
} }
#return [showdict $resultd]
} }
#return [showdict $resultd]
} }
#*** !doctools #*** !doctools
#[list_end] [comment {--- end definitions namespace punk::netbox::man ---}] #[list_end] [comment {--- end definitions namespace punk::netbox::man ---}]
} }
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::netbox::man::tenancy {
namespace export {[a-z]*}
namespace ensemble create -parameters {apicontextid}
variable PUNKARGS
tcl::namespace::eval tenants {
namespace export {[a-z]*}
namespace ensemble create -parameters {apicontextid}
variable PUNKARGS
#we're overriding a resolved_def which was dynamic
# - we need to ensure the new definition is also dynamic
# - todo - override rawdef instead? (convenience functions for override of rawdef is missing in punk::args)
lappend PUNKARGS [::list\
@dynamic\
[punk::args::resolved_def\
-antiglobs {@leaders @values -RETURN}\
-override {@id {-id "::punk::netbox::man::tenancy::tenants::list"} apicontextid {-choices {${[punk::netbox::api_context_names]}}}}\
::punk::netbox::tenancy::tenants_list\
]\
{-RETURN -default table -choices {table tableobject list linelist}}\
{-MAXRESULTS -type integer -default -1}\
{@values -min 0 -max 0}\
]
proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::tenancy::tenants::list"]
set urlnext ""
set requests_allowed 1000 ;#Sanity check - consider making an option - review
set resultlist [::list]
set token [dict get $argd leaders apicontextid]
set opts [dict get $argd opts]
set vals [dict get $argd values]
set multis [dict get $argd multis]
set outer_return [dict get $opts -RETURN]
set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely
set maxresults [dict get $opts -MAXRESULTS]
set opts [dict remove $opts -MAXRESULTS]
set initial_pagelimit [dict get $opts -limit]
#we can't just pass through 'multi' opts even if only one was supplied - list level is wrong
set nextopts [::list]
dict for {opt val} $opts {
if {$opt ni $multis} {
lappend nextopts $opt $val
} else {
foreach v $val {
lappend nextopts $opt $v
}
}
}
#Now opts is a list with possible repeated options! (for flags that have -multiple true)
if {$maxresults == -1} {
set maxresults $initial_pagelimit
}
if {$maxresults < $initial_pagelimit} {
punk::netbox::man::system::dupkeylist_setfirst nextopts -limit $maxresults
}
set to_go [expr {$maxresults - [llength $resultlist]}]
while {$urlnext ne "null"} {
if {$urlnext ne ""} {
set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext]
if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} {
punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go
}
punk::netbox::man::system::optionlistvar_sync_from_urlparams nextopts $urlnext_params
}
puts "-->next:$urlnext nextopts:$nextopts vals:$vals"
set resultd [punk::netbox::tenancy::tenants_list $token {*}$nextopts -RETURN dict {*}$vals]
set urlnext [dict get $resultd next]
set batch [dict get $resultd results]
lappend resultlist {*}$batch
set to_go [expr {$maxresults - [llength $resultlist]}]
if {$to_go <= 0} {break}
incr requests_allowed -1
if {$requests_allowed < 1} {break}
}
if {$outer_return in {table tableobject}} {
package require textblock
set t [textblock::list_as_table -return tableobject -colheaders {id name slug description group sites racks devices vms IPs}]
foreach ten $resultlist {
if {[dict exists $ten group id]} {
set group "[dict get $ten group id]: [dict get $ten group slug]"
} else {
set group [dict get $ten group] ;#probably null
}
set r [::list\
[dict get $ten id]\
[dict get $ten name]\
[dict get $ten slug]\
[dict get $ten description]\
$group\
[dict get $ten site_count]\
[dict get $ten rack_count]\
[dict get $ten device_count]\
[dict get $ten virtualmachine_count]\
[dict get $ten ipaddress_count]\
]
$t add_row $r
}
}
switch -- $outer_return {
table {
set result [$t print]
$t destroy
return $result
}
tableobject {
return $t
}
linelist {
set ret ""
foreach r $resultlist {
append ret $r \n
}
return $ret
}
default {
return $resultlist
}
}
}
}
}
tcl::namespace::eval punk::netbox::man::virtualization {
namespace export {[a-z]*}
namespace ensemble create -parameters {apicontextid}
variable PUNKARGS
tcl::namespace::eval virtual-machines {
namespace export {[a-z]*}
namespace ensemble create -parameters {apicontextid}
variable PUNKARGS
lappend PUNKARGS [::list\
[punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::virtualization::virtual-machines::list"}} ::punk::netbox::virtualization::virtual-machines_list]\
{-RETURN -default table -choices {table tableobject list linelist}}\
{-MAXRESULTS -type integer -default -1}\
{@values -min 0 -max 0}\
]
proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::virtualization::virtual-machines::list"]
set urlnext ""
set requests_allowed 1000 ;#Sanity check - consider making an option - review
set resultlist [::list]
set token [dict get $argd leaders apicontextid]
set opts [dict get $argd opts]
set vals [dict get $argd values]
set multis [dict get $argd multis]
set outer_return [dict get $opts -RETURN]
set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely
set maxresults [dict get $opts -MAXRESULTS]
set opts [dict remove $opts -MAXRESULTS]
set initial_pagelimit [dict get $opts -limit]
#we can't just pass through 'multi' opts even if only one was supplied - list level is wrong
set nextopts [::list]
dict for {opt val} $opts {
if {$opt ni $multis} {
lappend nextopts $opt $val
} else {
foreach v $val {
lappend nextopts $opt $v
}
}
}
#Now opts is a list with possible repeated options! (for flags that have -multiple true)
if {$maxresults == -1} {
set maxresults $initial_pagelimit
}
if {$maxresults < $initial_pagelimit} {
punk::netbox::man::system::dupkeylist_setfirst nextopts -limit $maxresults
}
set to_go [expr {$maxresults - [llength $resultlist]}]
while {$urlnext ne "null"} {
if {$urlnext ne ""} {
set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext]
if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} {
punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go
}
punk::netbox::man::system::optionlistvar_sync_from_urlparams nextopts $urlnext_params
}
puts "-->next:$urlnext nextopts:$nextopts vals:$vals"
set resultd [punk::netbox::virtualization::virtual-machines_list $token {*}$nextopts -RETURN dict {*}$vals]
set urlnext [dict get $resultd next]
set batch [dict get $resultd results]
lappend resultlist {*}$batch
set to_go [expr {$maxresults - [llength $resultlist]}]
if {$to_go <= 0} {break}
incr requests_allowed -1
if {$requests_allowed < 1} {break}
}
if {$outer_return in {table tableobject}} {
package require textblock
set t [textblock::list_as_table -return tableobject -colheaders {id name site primary_ip4 tags}]
foreach vm $resultlist {
if {[dict exists $vm site id]} {
set site "[dict get $vm site id]: [dict get $vm site slug]"
} else {
set site [dict get $vm site] ;#probably null
}
if {[dict exists $vm primary_ip4 id]} {
set ip4 [dict get $vm primary_ip4 address]
} else {
set ip4 ""
}
set taglist [dict get $vm tags]
set tagblock ""
foreach taginfo $taglist {
set slug [dict get $taginfo slug]
set rgb [dict get $taginfo color]
append tagblock "[a+ Rgb#$rgb rgb#$rgb-contrasting]$slug[a] "
}
set r [::list\
[dict get $vm id]\
[dict get $vm name]\
$site\
$ip4\
$tagblock\
]
$t add_row $r
}
}
switch -- $outer_return {
table {
set result [$t print]
$t destroy
return $result
}
tableobject {
return $t
}
linelist {
set ret ""
foreach r $resultlist {
append ret $r \n
}
return $ret
}
default {
return $resultlist
}
}
}
}
}
tcl::namespace::eval punk::netbox::man::ip-addresses { tcl::namespace::eval punk::netbox::man::ip-addresses {
namespace export {[a-z]*} namespace export {[a-z]*}
namespace ensemble create namespace ensemble create -parameters {apicontextid}
variable PUNKARGS variable PUNKARGS
lappend PUNKARGS [::list\ lappend PUNKARGS [::list\
[punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::ip-addresses list"}} ::punk::netbox::ipam::ip-addresses_list]\ [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::ip-addresses::list"}} ::punk::netbox::ipam::ip-addresses_list]\
{-RETURN -default table -choices {table tableobject list linelist}}\ {-RETURN -default table -choices {table tableobject list linelist}}\
{-MAXRESULTS -type integer -default -1}\ {-MAXRESULTS -type integer -default -1}\
{@values -min 0 -max 0}\ {@values -min 0 -max 0}\
@ -358,15 +892,15 @@ tcl::namespace::eval punk::netbox::man::ip-addresses {
#caution: must use ::list to avoid loop #caution: must use ::list to avoid loop
proc list {args} { proc list {args} {
set argd [punk::args::parse $args withid "::punk::netbox::man::ip-addresses list"] set argd [punk::args::parse $args withid "::punk::netbox::man::ip-addresses::list"]
set token tclread ;#todo
set urlnext "" set urlnext ""
set requests_allowed 1000 ;#Sanity check - consider making an option - review set requests_allowed 1000 ;#Sanity check - consider making an option - review
set resultlist [::list] set resultlist [::list]
set opts [dict get $argd opts] set token [dict get $argd leaders apicontextid]
set vals [dict get $argd values] set opts [dict get $argd opts]
set multis [dict get $argd multis] set vals [dict get $argd values]
set multis [dict get $argd multis]
set outer_return [dict get $opts -RETURN] set outer_return [dict get $opts -RETURN]
set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely set opts [dict remove $opts -RETURN] ;#opts from punk::args::parse is a dict (no dup keys) - can use 'dict remove' safely
set maxresults [dict get $opts -MAXRESULTS] set maxresults [dict get $opts -MAXRESULTS]
@ -394,7 +928,7 @@ tcl::namespace::eval punk::netbox::man::ip-addresses {
set to_go [expr {$maxresults - [llength $resultlist]}] set to_go [expr {$maxresults - [llength $resultlist]}]
while {$urlnext ne "null"} { while {$urlnext ne "null"} {
if {$urlnext ne ""} { if {$urlnext ne ""} {
set urlnext_params [punk::netbox::man::uri_get_querystring_as_keyval_list $urlnext] set urlnext_params [punk::netbox::man::system::uri_get_querystring_as_keyval_list $urlnext]
if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} { if {[punk::netbox::man::system::dupkeylist_getfirst $nextopts -limit] > $to_go} {
punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go punk::netbox::man::system::dupkeylist_setfirst urlnext_params limit $to_go
} }
@ -479,7 +1013,41 @@ tcl::namespace::eval punk::netbox::man::ip-addresses {
} }
#now all sub-ensembles exist - create the ensemble for punk::netbox::man
# - we use a map to exclude any exported procs within the man namespace that don't accept the apicontextid parameter (e.g about)
tcl::namespace::eval punk::netbox::man {
namespace export {[a-z]*}
set emap [dict create\
new [list ::punk::netbox::man::new]\
status [list ::punk::netbox::status]\
]
set nslist [punk::ns::nslist_dict ::punk::netbox::man::*]
set info [lindex $nslist 0]
set subensembles [dict get $info ensembles]
foreach se $subensembles {
#e.g ip-addresses, tenancy
dict set emap $se [list ::punk::netbox::man::$se]
}
namespace ensemble create -parameters apicontextid -map $emap
}
tcl::namespace::eval punk::netbox::man::system { tcl::namespace::eval punk::netbox::man::system {
#review + ?
proc uri_part_decode {uripart} {
set specialMap {"[" "%5B" "]" "%5D" + " "}
set seqRE {%([0-9a-fA-F]{2})}
set replacement {[format "%c" [scan "\1" "%2x"]]}
set modstr [regsub -all $seqRE [string map $specialMap $uripart] $replacement]
return [encoding convertfrom utf-8 [subst -nobackslash -novariable $modstr]]
}
proc uri_get_querystring_as_keyval_list {uri} {
set parts [uri::split $uri]
set query ?[dict get $parts query]
set raw_plist [rest::parameters $query] ;#not a dict - can have repeated params (important for <name>_FILTER methods)
return [lmap v $raw_plist {uri_part_decode $v}]
}
#update/add specific members of optionlistvar params in dashed -option format from urlparams in undashed format #update/add specific members of optionlistvar params in dashed -option format from urlparams in undashed format
#members: offset,limit -> -offset,-limit #members: offset,limit -> -offset,-limit
@ -584,8 +1152,7 @@ tcl::namespace::eval punk::netbox::man {
lappend PUNKARGS [list { lappend PUNKARGS [list {
@id -id "(package)punk::netbox::man" @id -id "(package)punk::netbox::man"
@package -name "punk::netbox::man" -help\ @package -name "punk::netbox::man" -help\
"Package "Management wrapper over netbox rest API"
Description"
}] }]
namespace eval argdoc { namespace eval argdoc {
@ -675,7 +1242,13 @@ namespace eval ::punk::args::register {
lappend ::punk::args::register::NAMESPACES\ lappend ::punk::args::register::NAMESPACES\
::punk::netbox::man\ ::punk::netbox::man\
::punk::netbox::man::prefixes\ ::punk::netbox::man::prefixes\
::punk::netbox::man::ip-addresses ::punk::netbox::man::prefixes::available-ips\
::punk::netbox::man::prefixes::available-prefixes\
::punk::netbox::man::ip-addresses\
::punk::netbox::man::tenancy\
::punk::netbox::man::tenancy::tenants\
::punk::netbox::man::virtualization\
::punk::netbox::man::virtualization::virtual-machines\
} }
# ----------------------------------------------------------------------------- # -----------------------------------------------------------------------------

1408
src/modules/punk/ns-999999.0a1.0.tm

File diff suppressed because it is too large Load Diff

14
src/modules/punk/repo-999999.0a1.0.tm

@ -100,8 +100,12 @@ namespace eval punk::repo {
subcommand -type string -choicecolumns 8 -choicegroups { subcommand -type string -choicecolumns 8 -choicegroups {
"frequently used commands" {${$maincommands}} "frequently used commands" {${$maincommands}}
"" {${$othercmds}} "" {${$othercmds}}
} } -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}}
}] }]
#-choiceinfo {
# add {{doctype punkargs}}
# diff {{doctype punkargs}}
#}
return $result return $result
} }
@ -112,7 +116,7 @@ namespace eval punk::repo {
# @id -id ::punk::repo::fossil_proxy # @id -id ::punk::repo::fossil_proxy
# @cmd -name fossil -help "fossil executable # @cmd -name fossil -help "fossil executable
# " # "
# @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} # @formdisplay -header "fossil help" -body {${[runout -n fossil help]}}
# } ""] # } ""]
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -129,7 +133,7 @@ namespace eval punk::repo {
@dynamic @dynamic
@id -id "::punk::repo::fossil_proxy diff" @id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff" -help "fossil diff" @cmd -name "fossil diff" -help "fossil diff"
@argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} @formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""] } ""]
lappend PUNKARGS [list { lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive #todo - remove this comment - testing dynamic directive
@ -137,7 +141,7 @@ namespace eval punk::repo {
@id -id "::punk::repo::fossil_proxy add" @id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add @cmd -name "fossil add" -help "fossil add
" "
@argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
} ""] } ""]
#TODO #TODO
#lappend PUNKARGS [list { #lappend PUNKARGS [list {
@ -145,7 +149,7 @@ namespace eval punk::repo {
# @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs}
# @cmd -name "fossil add" -help "fossil add # @cmd -name "fossil add" -help "fossil add
# " # "
# @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} # @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
# } ""] # } ""]
lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"}
lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"}

179
src/modules/punk/zip-999999.0a1.0.tm

@ -168,45 +168,45 @@ tcl::namespace::eval punk::zip {
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) expr {(($year-1980) << 25) | ($month << 21) | ($day << 16)
| ($hour << 11) | ($min << 5) | ($sec >> 1)} | ($hour << 11) | ($min << 5) | ($sec >> 1)}
} }
punk::args::define {
@id -id ::punk::zip::walk
@cmd -name punk::zip::walk -help\
"Walk the directory structure starting at base/<-subpath>
and return a list of the files and folders encountered.
Resulting paths are relative to base unless -resultrelative
is supplied.
Folder names will end with a trailing slash.
"
-resultrelative -optional 1 -help\
"Resulting paths are relative to this value.
Defaults to the value of base. If empty string
is given to -resultrelative the paths returned
are effectively absolute paths."
-emptydirs -default 0 -type boolean -help\
"Whether to include directory trees in the result which had no
matches for the given fileglobs.
Intermediate dirs are always returned if there is a match with
fileglobs further down even if -emptdirs is 0.
"
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
}
proc walk {args} { proc walk {args} {
#*** !doctools #*** !doctools
#[call [fun walk] [arg ?options?] [arg base]] #[call [fun walk] [arg ?options?] [arg base]]
#[para] Walk a directory tree rooted at base #[para] Walk a directory tree rooted at base
#[para] the -excludes list can be a set of glob expressions to match against files and avoid #[para] the -excludes list can be a set of glob expressions to match against files and avoid
#[para] e.g #[para] e.g
#[example { #[example {
# punk::zip::walk -exclude {CVS/* *~.#*} library # punk::zip::walk -exclude {CVS/* *~.#*} library
#}] #}]
#todo: -relative 0|1 flag? #todo: -relative 0|1 flag?
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::walk]
@id -id ::punk::zip::walk
@cmd -name punk::zip::walk -help\
"Walk the directory structure starting at base/<-subpath>
and return a list of the files and folders encountered.
Resulting paths are relative to base unless -resultrelative
is supplied.
Folder names will end with a trailing slash.
"
-resultrelative -optional 1 -help\
"Resulting paths are relative to this value.
Defaults to the value of base. If empty string
is given to -resultrelative the paths returned
are effectively absolute paths."
-emptydirs -default 0 -type boolean -help\
"Whether to include directory trees in the result which had no
matches for the given fileglobs.
Intermediate dirs are always returned if there is a match with
fileglobs further down even if -emptdirs is 0.
"
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base] set base [dict get $argd values base]
set fileglobs [dict get $argd values fileglobs] set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath] set subpath [dict get $argd opts -subpath]
@ -416,6 +416,20 @@ tcl::namespace::eval punk::zip {
punk::args::define {
@id -id ::punk::zip::Addentry
@cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan'
return a central directory file record"
@opts
-comment -default "" -help "An optional comment specific to the added file"
@values -min 3 -max 4
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header"
base -help "base path for entries"
path -type file -help "path of file to add"
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'"
}
# Addentry - was Mkzipfile -- # Addentry - was Mkzipfile --
# #
# FIX ME: should handle the current offset for non-seekable channels # FIX ME: should handle the current offset for non-seekable channels
@ -428,20 +442,7 @@ tcl::namespace::eval punk::zip {
#[para] You can provide a -comment for the file. #[para] You can provide a -comment for the file.
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive.
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::Addentry]
@id -id ::punk::zip::Addentry
@cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan'
return a central directory file record"
@opts
-comment -default "" -help "An optional comment specific to the added file"
@values -min 3 -max 4
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header"
base -help "base path for entries"
path -type file -help "path of file to add"
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'"
} $args]
set zipchan [dict get $argd values zipchan] set zipchan [dict get $argd values zipchan]
set base [dict get $argd values base] set base [dict get $argd values base]
set path [dict get $argd values path] set path [dict get $argd values path]
@ -558,10 +559,55 @@ tcl::namespace::eval punk::zip {
# we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip)
#### ####
punk::args::define {
@id -id ::punk::zip::mkzip
@cmd -name punk::zip::mkzip\
-help "Create a zip archive in 'filename'"
@opts
-offsettype -default "archive" -choices {archive file}\
-help "zip offsets stored relative to start of entire file or relative to start of zip-archive
Only relevant if the created file has a script/runtime prefix.
"
-return -default "pretty" -choices {pretty list none}\
-help "mkzip can return a list of the files and folders added to the archive
the option -return pretty is the default and uses the punk::lib pdict/plist system
to return a formatted list for the terminal
"
-zipkit -default 0 -type none\
-help "whether to add mounting script
mutually exclusive with -runtime option
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs
"
-runtime -default ""\
-help "specify a prefix file
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip
will create a self-extracting zip archive from the subdir/ folder.
Expects runtime with no existing vfs attached (review)
"
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
-help "The new zip archive will scan for contents within this folder or current directory if not provided.
Note that this will
"
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"}
@values -min 1 -max -1
filename -type file -default ""\
-help "name of zipfile to create"
globs -default {*} -multiple 1\
-help "list of glob patterns to match.
Only directories with matching files will be included in the archive."
}
# zip::mkzip -- # zip::mkzip --
# #
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt
# #
proc mkzip {args} { proc mkzip {args} {
#todo - doctools - [arg ?globs...?] syntax? #todo - doctools - [arg ?globs...?] syntax?
@ -581,50 +627,7 @@ tcl::namespace::eval punk::zip {
#[para] If a file already exists, an error will be raised. #[para] If a file already exists, an error will be raised.
#[para] Call 'punk::zip::mkzip' with no arguments for usage display. #[para] Call 'punk::zip::mkzip' with no arguments for usage display.
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::mkzip]
@id -id ::punk::zip::mkzip
@cmd -name punk::zip::mkzip\
-help "Create a zip archive in 'filename'"
@opts
-offsettype -default "archive" -choices {archive file}\
-help "zip offsets stored relative to start of entire file or relative to start of zip-archive
Only relevant if the created file has a script/runtime prefix.
"
-return -default "pretty" -choices {pretty list none}\
-help "mkzip can return a list of the files and folders added to the archive
the option -return pretty is the default and uses the punk::lib pdict/plist system
to return a formatted list for the terminal
"
-zipkit -default 0 -type none\
-help "whether to add mounting script
mutually exclusive with -runtime option
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs
"
-runtime -default ""\
-help "specify a prefix file
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip
will create a self-extracting zip archive from the subdir/ folder.
Expects runtime with no existing vfs attached (review)
"
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
-help "The new zip archive will scan for contents within this folder or current directory if not provided.
Note that this will
"
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"}
@values -min 1 -max -1
filename -type file -default ""\
-help "name of zipfile to create"
globs -default {*} -multiple 1\
-help "list of glob patterns to match.
Only directories with matching files will be included in the archive."
} $args]
set filename [dict get $argd values filename] set filename [dict get $argd values filename]
if {$filename eq ""} { if {$filename eq ""} {
error "mkzip filename cannot be empty string" error "mkzip filename cannot be empty string"

128
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/args.test

@ -0,0 +1,128 @@
package require tcltest
namespace eval ::testspace {
namespace import ::tcltest::*
variable common {
set result ""
}
test parse_withdef_leaders_min_max {Test anonymous leaders with @leaders -min and -max}\
-setup $common -body {
set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 3} ]
lappend result [dict get $argd leaders]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{0 a 1 b 2 c} {3 d}
]
test parse_withdef_leaders_ordering_defaults {Test ordering of leaders when some have defaults}\
-setup $common -body {
set argd [punk::args::parse {a b} withdef @leaders x {y -default 1}]
set vals [dict get $argd leaders]
set result $vals
}\
-cleanup {
}\
-result [list\
x a y b
]
test parse_withdef_option_ordering_defaults {Test ordering of options when some have defaults}\
-setup $common -body {
#for consistency with leaders and values dicts - try to maintain definition order for options too
set argd [punk::args::parse {-x a -y b} withdef @opts -x {-y -default 1}]
set vals [dict get $argd opts]
set result $vals
}\
-cleanup {
}\
-result [list\
-x a -y b
]
test parse_withdef_option_ordering_defaults2 {Test ordering of options when some have defaults and -any is true}\
-setup $common -body {
#for consistency with leaders and values dicts - try to maintain definition order for options too
set argd [punk::args::parse {-blah etc -x a -y b -solo -z c} withdef {@opts -any 1} -x {-y -default 1} {-solo -type none} -z]
set vals [dict get $argd opts]
set result $vals
}\
-cleanup {
}\
-result [list\
-x a -y b -solo 1 -z c -blah etc
]
test parse_withdef_values_ordering_defaults {Test ordering of values when some have defaults}\
-setup $common -body {
set argd [punk::args::parse {a b} withdef @values x {y -default 1}]
set vals [dict get $argd values]
set result $vals
}\
-cleanup {
}\
-result [list\
x a y b
]
test parse_withdef_leader_min_max {Test unnamed leaders with -min and -max}\
-setup $common -body {
#should not error - should allocate d to values
set argd [punk::args::parse {a b c d} withdef {@leaders -min 1 -max 4} {@values -min 1 -max 1}]
lappend result [dict get $argd leaders]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{0 a 1 b 2 c} {3 d}
]
test parse_withdef_leader_stride {Test stride leaders}\
-setup $common -body {
#see for example ::tcl::dict::create which has a stride of 2
set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@leaders} {"key val etc" -multiple 0} {"key val" -multiple 1} {@values -min 0 -max 0}]
lappend result [dict get $argd leaders]
}\
-cleanup {
}\
-result [list\
{{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}}
]
test parse_withdef_value_stride {Test stride values}\
-setup $common -body {
#see for example ::tcl::dict::create which has a stride of 2
set argd [punk::args::parse {k v e k1 v1 k2 v2} withdef {@values} {"key val etc" -multiple 0} {"key val" -multiple 1}]
lappend result [dict get $argd values]
}\
-cleanup {
}\
-result [list\
{{key val etc} {k v e} {key val} {{k1 v1} {k2 v2}}}
]
test parse_withdef_value_stride_error {Test stride values with error due to not enough args for stride}\
-setup $common -body {
#see for example ::tcl::dict::create which has a stride of 2
if {[catch {punk::args::parse {k v} withdef {@values} {"key val etc" -multiple 0}} emsg eopts]} {
set expected [dict get $eopts -errorcode]
if {[lindex $expected 0] eq "PUNKARGS" && [lindex $expected 1] eq "VALIDATION" && [lindex $expected 2 0] eq "stridevaluecount"} {
lappend result "RECEIVED_EXPECTED_ERROR"
} else {
lappend result "WRONG_ERROR_RECEIVED - $expected (expected PUNKARGS VALIDATION {stridevaluecount ...} ..."
}
} else {
lappend result "MISSING_REQUIRED_ERROR"
}
}\
-cleanup {
}\
-result [list\
"RECEIVED_EXPECTED_ERROR"
]
}

125
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/define.test

@ -0,0 +1,125 @@
package require tcltest
namespace eval ::testspace {
namespace import ::tcltest::*
variable common {
set result ""
}
test define_tstr_template1 {Test basic tstr substitution finds vars in namespace in which define was called}\
-setup $common -body {
namespace eval whatever {
set plus +++
set minus ---
punk::args::define {
@id -id ::testspace::test1
@values
param -type string -default "${$plus}XXX${$minus}YYY"
}
}
set argd [punk::args::parse {} withid ::testspace::test1]
set vals [dict get $argd values]
lappend result [dict get $vals param]
}\
-cleanup {
namespace delete ::testspace::whatever
}\
-result [list\
+++XXX---YYY
]
test define_tstr_template2 {Test basic tstr substitution when @dynamic}\
-setup $common -body {
namespace eval whatever {
set plus +++
set minus ---
punk::args::define {
@dynamic
@id -id ::testspace::test2
@values
param -type string -default "${$plus}XXX${$minus}YYY"
}
}
set argd [punk::args::parse {} withid ::testspace::test2]
puts ">>>>define_tstr_template2 argd:$argd"
set vals [dict get $argd values]
lappend result [dict get $vals param]
}\
-cleanup {
namespace delete ::testspace::whatever
}\
-result [list\
+++XXX---YYY
]
test define_tstr_template3 {Test double tstr substitution when @dynamic}\
-setup $common -body {
variable test_list
set test_list {A B C}
proc ::testspace::get_list {} {
variable test_list
return $test_list
}
namespace eval whatever {
set plus +++
set minus ---
set DYN_LIST {${[::testspace::get_list]}}
set DYN_CLOCKSECONDS {${[clock seconds]}}
punk::args::define {
@dynamic
@id -id ::testspace::test2
@values
param1 -type string -default "${$plus}XXX${$minus}YYY"
param2 -type list -default "${$DYN_LIST}"
param3 -type string -default "${[clock seconds]}"
param4 -type string -default "${$DYN_CLOCKSECONDS}"
}
}
set argd [punk::args::parse {} withid ::testspace::test2]
set vals [dict get $argd values]
lappend result [dict get $vals param1]
lappend result [dict get $vals param2]
set c1_at_define [dict get $vals param3]
set c1_at_resolve [dict get $vals param4]
#update test_list to ensure parse is actually dynamic
set ::testspace::test_list {X Y Z}
#update plus - should not affect output as it is resolved at define time
set ::testspace::whatever::plus "new+"
#unset minus - should not cause error
unset ::testspace::whatever::minus
after 1100 ;#ensure more than 1 sec apart
set argd [punk::args::parse {} withid ::testspace::test2]
set vals [dict get $argd values]
lappend result [dict get $vals param1]
lappend result [dict get $vals param2]
set c2_at_define [dict get $vals param3]
set c2_at_resolve [dict get $vals param4]
if {$c1_at_define == $c2_at_define} {
lappend result "OK_define_time_var_match"
} else {
lappend result "UNEXPECTED_define_time_var_mismatch"
}
if {$c1_at_resolve < $c2_at_resolve} {
lappend result "OK_resolve_time_2_greater"
} else {
lappend result "UNEXPECTED_resolve_time_2_not_greater"
}
}\
-cleanup {
namespace delete ::testspace::whatever
}\
-result [list\
+++XXX---YYY {A B C} +++XXX---YYY {X Y Z} OK_define_time_var_match OK_resolve_time_2_greater
]
}

60
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/args/synopsis.test

@ -0,0 +1,60 @@
package require tcltest
namespace eval ::testspace {
namespace import ::tcltest::*
namespace import ::punk::ansi::a+ ::punk::ansi::a
variable common {
set result ""
}
test synopsis_basic {test basic synopsis of punkargs definition}\
-setup $common -body {
namespace eval testns {
punk::args::define {
@id -id ::testspace::testns::t1
@leaders
a1 -optional 0
@opts
-o1 -type boolean
@values
v1 -optional 1
}
}
lappend result [punk::ns::synopsis ::testspace::testns::t1]
}\
-cleanup {
namespace delete ::testspace::testns
}\
-result [list\
"::testspace::testns::t1 [a+ italic]a1[a] ?-o1 <bool>? ?[a+ italic]v1[a]?"
]
test synopsis_basic_ensemble-like {test basic synopsis of punkargs ensemble-like definition}\
-setup $common -body {
namespace eval testns {
punk::args::define {
@id -id ::testspace::testns::t1
@leaders -min 1
subcmd -default c1 -choices {c1 c2}
@values -min 0 -max 0
}
punk::args::define {
@id -id "::testspace::testns::t1 c1"
@values -min 0 -max 1
v1 -type string
}
}
lappend result [punk::ns::synopsis ::testspace::testns::t1]
lappend result [punk::ns::synopsis ::testspace::testns::t1 c1]
}\
-cleanup {
namespace delete ::testspace::testns
}\
-result [list\
"::testspace::testns::t1 [a+ italic]subcmd[a]"\
"::testspace::testns::t1 c1 [a+ italic]v1[a]"
]
}

0
src/modules/test/punk/#modpod-args-999999.0a1.0/args-0.1.5_testsuites/tests/args.test#..+args+args.test.fauxlink

226
src/modules/test/punk/#modpod-args-999999.0a1.0/args-999999.0a1.0.tm

@ -0,0 +1,226 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm
#
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem.
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2025
#
# @@ Meta Begin
# Application test::punk::args 999999.0a1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_test::punk::args 0 999999.0a1.0]
#[copyright "2025"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require test::punk::args]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of test::punk::args
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by test::punk::args
#[list_begin itemized]
package require Tcl 8.6-
#*** !doctools
#[item] [package {Tcl 8.6}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
tcl::namespace::eval test::punk::args {
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection {Namespace test::punk::args}]
#[para] Core API functions for test::punk::args
#[list_begin definitions]
variable PUNKARGS
variable pkg test::punk::args
variable version
set version 999999.0a1.0
package require packageTest
packageTest::makeAPI test::punk::args $version punk::args; #will package provide test::punk::args $version
package forget punk::args
package require punk::args
#*** !doctools
#[list_end] [comment {--- end definitions namespace test::punk::args ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval test::punk::args::system {
#*** !doctools
#[subsection {Namespace test::punk::args::system}]
#[para] Internal functions that are not part of the API
#}
# == === === === === === === === === === === === === === ===
# Sample 'about' function with punk::args documentation
# == === === === === === === === === === === === === === ===
tcl::namespace::eval test::punk::args {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
variable PUNKARGS
variable PUNKARGS_aliases
lappend PUNKARGS [list {
@id -id "(package)test::punk::args"
@package -name "test::punk::args" -help\
"Package
Description"
}]
namespace eval argdoc {
#namespace for custom argument documentation
proc package_name {} {
return test::punk::args
}
proc about_topics {} {
#info commands results are returned in an arbitrary order (like array keys)
set topic_funs [info commands [namespace current]::get_topic_*]
set about_topics [list]
foreach f $topic_funs {
set tail [namespace tail $f]
lappend about_topics [string range $tail [string length get_topic_] end]
}
#Adjust this function or 'default_topics' if a different order is required
return [lsort $about_topics]
}
proc default_topics {} {return [list Description *]}
# -------------------------------------------------------------
# get_topic_ functions add more to auto-include in about topics
# -------------------------------------------------------------
proc get_topic_Description {} {
punk::args::lib::tstr [string trim {
package test::punk::args
test suite for punk::args
} \n]
}
proc get_topic_License {} {
return "MIT"
}
proc get_topic_Version {} {
return "$::test::punk::args::version"
}
proc get_topic_Contributors {} {
set authors {{<julian@precisium.com> Julian Noble}}
set contributors ""
foreach a $authors {
append contributors $a \n
}
if {[string index $contributors end] eq "\n"} {
set contributors [string range $contributors 0 end-1]
}
return $contributors
}
proc get_topic_custom-topic {} {
punk::args::lib::tstr -return string {
A custom
topic
etc
}
}
# -------------------------------------------------------------
}
# we re-use the argument definition from punk::args::standard_about and override some items
set overrides [dict create]
dict set overrides @id -id "::test::punk::args::about"
dict set overrides @cmd -name "test::punk::args::about"
dict set overrides @cmd -help [string trim [punk::args::lib::tstr {
About test::punk::args
}] \n]
dict set overrides topic -choices [list {*}[test::punk::args::argdoc::about_topics] *]
dict set overrides topic -choicerestricted 1
dict set overrides topic -default [test::punk::args::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *]
lappend PUNKARGS [list $newdef]
proc about {args} {
package require punk::args
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on
set argd [punk::args::parse $args withid ::test::punk::args::about]
lassign [dict values $argd] _leaders opts values _received
punk::args::package::standard_about -package_about_namespace ::test::punk::args::argdoc {*}$opts {*}[dict get $values topic]
}
}
# end of sample 'about' function
# == === === === === === === === === === === === === === ===
# -----------------------------------------------------------------------------
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked
# -----------------------------------------------------------------------------
# variable PUNKARGS
# variable PUNKARGS_aliases
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::test::punk::args
}
# -----------------------------------------------------------------------------
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide test::punk::args [tcl::namespace::eval test::punk::args {
variable pkg test::punk::args
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/modules/test/punk/args-buildversion.txt

@ -0,0 +1,3 @@
0.1.5
#First line must be a semantic version number
#all other lines are ignored.

108
src/modules/textblock-999999.0a1.0.tm

@ -140,16 +140,18 @@ tcl::namespace::eval textblock {
# hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
# "algorithm choice" # "algorithm choice"
namespace eval argdoc {
punk::args::define { set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]}
@dynamic punk::args::define {
@id -id ::textblock::use_hash @dynamic
@cmd -name "textblock::use_hash" -help\ @id -id ::textblock::use_hash
"Hashing algorithm to use for framecache lookup. @cmd -name "textblock::use_hash" -help\
'none' may be slightly faster but less compact "Hashing algorithm to use for framecache lookup.
when viewing textblock::framecache" 'none' may be slightly faster but less compact
@values -min 0 -max 1 when viewing textblock::framecache"
hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} @values -min 0 -max 1
hash_algorithm -optional 1 ${$DYN_HASH_ALGORITHM_CHOICES_AND_HELP}
}
} }
proc use_hash {args} { proc use_hash {args} {
#set argd [punk::args::get_by_id ::textblock::use_hash $args] #set argd [punk::args::get_by_id ::textblock::use_hash $args]
@ -4667,17 +4669,19 @@ tcl::namespace::eval textblock {
-size -type integer\ -size -type integer\
-default 15\ -default 15\
-optional 1\ -optional 1\
-range {1 15} -range {1 ""}
-direction -default horizontal\ -direction -default horizontal\
-choices {horizontal vertical}\ -choices {horizontal vertical}\
-help\ -help\
"When rainbow is in the colour list, "Direction of character increments.
this also affects the direction of When rainbow is in the colour list,
colour changes" the colour stripes will be oriented
@values -min 0 -max 2 in this direction.
"
@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 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
@ -4725,7 +4729,16 @@ tcl::namespace::eval textblock {
set chars [list {*}[punk::lib::range 1 9] A B C D E F] set chars [list {*}[punk::lib::range 1 9] A B C D E F]
set charsubset [lrange $chars 0 $size-1] if {$size <= 15} {
set charsubset [lrange $chars 0 $size-1]
} else {
set numsets [expr {int(ceil($size / 15.0))}]
set longset [concat {*}[lrepeat $numsets $chars]]
set charsubset [lrange $longset 0 $size-1]
set longbows [concat {*}[lrepeat $numsets $rainbow_list]]
set rainbow_list [lrange $longbows 0 $size-1]
}
if {"noreset" in $colour} { if {"noreset" in $colour} {
set RST "" set RST ""
} else { } else {
@ -4760,21 +4773,32 @@ tcl::namespace::eval textblock {
append row $c append row $c
} }
append row $RST append row $RST
append block $row\n append block $row \n
} }
set block [tcl::string::trimright $block \n] set block [tcl::string::trimright $block \n]
return $block return $block
} else { } else {
#row first - if {$direction eq "vertical"} {
set rows [list] #row first -
foreach ch $charsubset { set rows [list]
lappend rows [tcl::string::repeat $ch $size] foreach ch $charsubset {
} lappend rows [tcl::string::repeat $ch $size]
set block [::join $rows \n] }
if {$colour ne ""} { set block [::join $rows \n]
set block [a+ {*}$colour]$block$RST if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
return $block
} else {
set block ""
for {set r 0} {$r < $size} {incr r} {
append block [::join $charsubset ""] \n
}
if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
return $block
} }
return $block
} }
} }
interp alias {} testblock {} textblock::testblock interp alias {} testblock {} textblock::testblock
@ -5500,10 +5524,11 @@ tcl::namespace::eval textblock {
proc ::textblock::join1 {args} { proc ::textblock::join1 {args} {
lassign [punk::args::get_dict { lassign [punk::args::parse $args withdef {
@id -id ::textblock::join1
-ansiresets -default 1 -type integer -ansiresets -default 1 -type integer
blocks -type string -multiple 1 blocks -type string -multiple 1
} $args] _l leaders _o opts _v values }] _l leaders _o opts _v values
set blocks [tcl::dict::get $values blocks] set blocks [tcl::dict::get $values blocks]
set idx 0 set idx 0
@ -5578,11 +5603,12 @@ tcl::namespace::eval textblock {
#@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width.
# Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
#" #"
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::textblock::join_basic2
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto -ansiresets -type any -default auto
blocks -type any -multiple 1 blocks -type any -multiple 1
} $args] }]
set ansiresets [tcl::dict::get $argd opts -ansiresets] set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks] set blocks [tcl::dict::get $argd values blocks]
@ -5619,12 +5645,6 @@ tcl::namespace::eval textblock {
#for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed
#they may however still be 'ragged' ie differing line lengths #they may however still be 'ragged' ie differing line lengths
proc ::textblock::join {args} { proc ::textblock::join {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
#we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets
@ -5709,11 +5729,6 @@ tcl::namespace::eval textblock {
} }
proc ::textblock::join2 {args} { proc ::textblock::join2 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
@ -5801,11 +5816,6 @@ tcl::namespace::eval textblock {
} }
# This calls textblock::pad per cell :/ # This calls textblock::pad per cell :/
proc ::textblock::join3 {args} { proc ::textblock::join3 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
@ -5984,7 +5994,7 @@ tcl::namespace::eval textblock {
NOTE: more options available - argument definition NOTE: more options available - argument definition
is incomplete" is incomplete"
@opts @opts
-return -choices {table tableobject} -return -default table -choices {table tableobject}
-rows -type list -default "" -help\ -rows -type list -default "" -help\
"A list of lists. "A list of lists.
Each toplevel element represents a row. Each toplevel element represents a row.
@ -6213,7 +6223,7 @@ tcl::namespace::eval textblock {
-help "restrict to keys matching memberglob." -help "restrict to keys matching memberglob."
}] }]
#append spec \n "frametype -help \"A predefined \"" #append spec \n "frametype -help \"A predefined \""
punk::args::get_dict $spec $args punk::args::parse $args withdef $spec
return return
} }

4
src/project_layouts/custom/_project/punk.basic/src/make.tcl

@ -2044,6 +2044,10 @@ if {[file exists $mapfile]} {
} }
# -- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- ---
puts "-- runtime_vfs_map --" puts "-- runtime_vfs_map --"
set ver [package require punk::args]
puts "punk::args ver: $ver"
set ifneeded [package ifneeded punk::args $ver]
puts "punk::args ifneeded: $ifneeded"
punk::lib::pdict runtime_vfs_map punk::lib::pdict runtime_vfs_map
puts "---------------------" puts "---------------------"
puts "-- vfs_runtime_map--" puts "-- vfs_runtime_map--"

56
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm

@ -10,7 +10,7 @@
# @@ Meta Begin # @@ Meta Begin
# Application argparsingtest 0.1.0 # Application argparsingtest 0.1.0
# Meta platform tcl # Meta platform tcl
# Meta license MIT # Meta license MIT
# @@ Meta End # @@ Meta End
@ -21,7 +21,7 @@
#[manpage_begin punkshell_module_argparsingtest 0 0.1.0] #[manpage_begin punkshell_module_argparsingtest 0 0.1.0]
#[copyright "2024"] #[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}] #[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require argparsingtest] #[require argparsingtest]
#[keywords module] #[keywords module]
#[description] #[description]
@ -106,7 +106,7 @@ namespace eval argparsingtest {
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest}] #[subsection {Namespace argparsingtest}]
#[para] Core API functions for argparsingtest #[para] Core API functions for argparsingtest
#[list_begin definitions] #[list_begin definitions]
proc test1_ni {args} { proc test1_ni {args} {
@ -277,8 +277,8 @@ namespace eval argparsingtest {
#punk::args is slower than argp - but comparable, and argp doesn't support solo flags #punk::args is slower than argp - but comparable, and argp doesn't support solo flags
proc test1_punkargs {args} { proc test1_punkargs {args} {
set argd [punk::args::parse $args withdef { set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs @id -id ::argparsingtest::test1_punkargs
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -298,7 +298,7 @@ namespace eval argparsingtest {
punk::args::define { punk::args::define {
@id -id ::test1_punkargs_by_id @id -id ::test1_punkargs_by_id
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -320,7 +320,7 @@ namespace eval argparsingtest {
punk::args::define { punk::args::define {
@id -id ::argparsingtest::test1_punkargs2 @id -id ::argparsingtest::test1_punkargs2
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -334,7 +334,7 @@ namespace eval argparsingtest {
-2 -default 2 -type integer -2 -default 2 -type integer
-3 -default 3 -type integer -3 -default 3 -type integer
@values @values
} }
proc test1_punkargs2 {args} { proc test1_punkargs2 {args} {
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
@ -342,9 +342,9 @@ namespace eval argparsingtest {
proc test1_punkargs_validate_ansistripped {args} { proc test1_punkargs_validate_ansistripped {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs_validate_ansistripped @id -id ::argparsingtest::test1_punkargs_validate_ansistripped
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -choices {string object} -help "return type" -return -default string -type string -choices {string object} -help "return type"
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -358,7 +358,7 @@ namespace eval argparsingtest {
-2 -default 2 -type integer -validate_ansistripped true -2 -default 2 -type integer -validate_ansistripped true
-3 -default 3 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true
@values @values
} $args] }]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
} }
@ -387,11 +387,11 @@ namespace eval argparsingtest {
package require cmdline package require cmdline
#cmdline::getoptions is much faster than typedGetoptions #cmdline::getoptions is much faster than typedGetoptions
proc test1_cmdline_untyped {args} { proc test1_cmdline_untyped {args} {
set cmdlineopts_untyped { set cmdlineopts_untyped {
{return.arg "string" "return val"} {return.arg "string" "return val"}
{frametype.arg \uFFEF "frame type"} {frametype.arg \uFFEF "frame type"}
{show_edge.arg \uFFEF "show table borders"} {show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"} {show_seps.arg \uFFEF "show table seps"}
{join "join the things"} {join "join the things"}
{x.arg "" "arg x"} {x.arg "" "arg x"}
{y.arg b "arg y"} {y.arg b "arg y"}
@ -405,11 +405,11 @@ namespace eval argparsingtest {
return [::cmdline::getoptions args $cmdlineopts_untyped $usage] return [::cmdline::getoptions args $cmdlineopts_untyped $usage]
} }
proc test1_cmdline_typed {args} { proc test1_cmdline_typed {args} {
set cmdlineopts_typed { set cmdlineopts_typed {
{return.arg "string" "return val"} {return.arg "string" "return val"}
{frametype.arg \uFFEF "frame type"} {frametype.arg \uFFEF "frame type"}
{show_edge.arg \uFFEF "show table borders"} {show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"} {show_seps.arg \uFFEF "show table seps"}
{join "join the things"} {join "join the things"}
{x.arg "" "arg x"} {x.arg "" "arg x"}
{y.arg b "arg y"} {y.arg b "arg y"}
@ -465,7 +465,7 @@ namespace eval argparsingtest {
#multiline values use first line of each record to determine amount of indent to trim #multiline values use first line of each record to determine amount of indent to trim
proc test_multiline {args} { proc test_multiline {args} {
set t3 [textblock::frame t3] set t3 [textblock::frame t3]
set argd [punk::args::get_dict [subst { set argd [punk::args::parse $args withdef [subst {
-template1 -default { -template1 -default {
****** ******
* t1 * * t1 *
@ -476,7 +476,7 @@ namespace eval argparsingtest {
* t2 * * t2 *
******} ******}
-template3 -default {$t3} -template3 -default {$t3}
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately
-template3b -default { -template3b -default {
$t3 $t3
----------------- -----------------
@ -491,20 +491,20 @@ namespace eval argparsingtest {
" "
-flag -default 0 -type boolean -flag -default 0 -type boolean
}] $args] }]]
return $argd return $argd
} }
#proc sample1 {p1 n args} { #proc sample1 {p1 n args} {
# #*** !doctools # #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1 # #[para]Description of sample1
# #[para] Arguments: # #[para] Arguments:
# # [list_begin arguments] # # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1. # # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n. # # [arg_def integer n] A description of integer argument n.
# # [list_end] # # [list_end]
# return "ok" # return "ok"
#} #}
@ -524,14 +524,14 @@ namespace eval argparsingtest::lib {
namespace path [namespace parent] namespace path [namespace parent]
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest::lib}] #[subsection {Namespace argparsingtest::lib}]
#[para] Secondary functions that are part of the API #[para] Secondary functions that are part of the API
#[list_begin definitions] #[list_begin definitions]
#proc utility1 {p1 args} { #proc utility1 {p1 args} {
# #*** !doctools # #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1 # #[para]Description of utility1
# return 1 # return 1
#} #}
@ -549,17 +549,17 @@ namespace eval argparsingtest::lib {
namespace eval argparsingtest::system { namespace eval argparsingtest::system {
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest::system}] #[subsection {Namespace argparsingtest::system}]
#[para] Internal functions that are not part of the API #[para] Internal functions that are not part of the API
} }
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready
package provide argparsingtest [namespace eval argparsingtest { package provide argparsingtest [namespace eval argparsingtest {
variable pkg argparsingtest variable pkg argparsingtest
variable version variable version
set version 0.1.0 set version 0.1.0
}] }]
return return

6
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.3.tm

@ -99,8 +99,11 @@ namespace eval commandstack {
} }
} }
proc get_stack {command} { proc get_stack {{command ""}} {
variable all_stacks variable all_stacks
if {$command eq ""} {
return $all_stacks
}
set command [uplevel 1 [list namespace which $command]] set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} { if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command] return [dict get $all_stacks $command]
@ -116,6 +119,7 @@ namespace eval commandstack {
variable all_stacks variable all_stacks
if {[dict exists $all_stacks $command]} { if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command] set stack [dict get $all_stacks $command]
#stack is a list of dicts, 1st entry is token {<cmd> <renamer> <tokenid>}
set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]]
if {$posn > -1} { if {$posn > -1} {
set record [lindex $stack $posn] set record [lindex $stack $posn]

25
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/modpod-0.1.3.tm

@ -134,12 +134,12 @@ namespace eval modpod {
#old tar connect mechanism - review - not needed? #old tar connect mechanism - review - not needed?
proc connect {args} { proc connect {args} {
puts stderr "modpod::connect--->>$args" puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::modpod::connect @id -id ::modpod::connect
-type -default "" -type -default ""
@values -min 1 -max 1 @values -min 1 -max 1
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args] }]
catch { catch {
punk::lib::showdict $argd ;#heavy dependencies punk::lib::showdict $argd ;#heavy dependencies
} }
@ -168,7 +168,7 @@ namespace eval modpod {
} else { } else {
#connect to .tm but may still be unwrapped version available #connect to .tm but may still be unwrapped version available
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname $modpodpath] set this_pkg_tm_folder [file dirname $modpodpath]
if {$connected(type,$modpodpath) ne "unwrapped"} { if {$connected(type,$modpodpath) ne "unwrapped"} {
#Not directly connected to unwrapped version - but may still be redirected there #Not directly connected to unwrapped version - but may still be redirected there
@ -225,11 +225,15 @@ namespace eval modpod {
if {$connected(startdata,$modpodpath) >= 0} { if {$connected(startdata,$modpodpath) >= 0} {
#verify we have a valid tar header #verify we have a valid tar header
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} {
seek $fh $connected(startdata,$modpodpath) start seek $fh $connected(startdata,$modpodpath) start
return [list ok $fh] return [list ok $fh]
} else { } else {
#error "cannot verify tar header" #error "cannot verify tar header"
#try zipfs
if {[info commands tcl::zipfs::mount] ne ""} {
}
} }
} }
lpop connected(to) end lpop connected(to) end
@ -262,11 +266,12 @@ namespace eval modpod {
return 1 return 1
} }
proc get {args} { proc get {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::modpod::get
-from -default "" -help "path to pod" -from -default "" -help "path to pod"
*values -min 1 -max 1 @values -min 1 -max 1
filename filename
} $args] }]
set frompod [dict get $argd opts -from] set frompod [dict get $argd opts -from]
set filename [dict get $argd values filename] set filename [dict get $argd values filename]
@ -329,7 +334,7 @@ namespace eval modpod::lib {
#zipfile is a pure zip at this point - ie no script/exe header #zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} { proc make_zip_modpod {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::modpod::lib::make_zip_modpod @id -id ::modpod::lib::make_zip_modpod
-offsettype -default "archive" -choices {archive file} -help\ -offsettype -default "archive" -choices {archive file} -help\
"Whether zip offsets are relative to start of file or start of zip-data within the file. "Whether zip offsets are relative to start of file or start of zip-data within the file.
@ -340,7 +345,7 @@ namespace eval modpod::lib {
@values -min 2 -max 2 @values -min 2 -max 2
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm"
} $args] }]
set zipfile [dict get $argd values zipfile] set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile] set outfile [dict get $argd values outfile]
set opt_offsettype [dict get $argd opts -offsettype] set opt_offsettype [dict get $argd opts -offsettype]
@ -359,7 +364,7 @@ namespace eval modpod::lib {
set moddir [file dirname $modfile] set moddir [file dirname $modfile]
set mod_and_ver [file rootname [file tail $modfile]] set mod_and_ver [file rootname [file tail $modfile]]
lassign [split $mod_and_ver -] moduletail version lassign [split $mod_and_ver -] moduletail version
if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { if {[file exists $moddir/#modpod-$mod_and_ver]} {
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm
} else { } else {
#determine module namespace so we can mount appropriately #determine module namespace so we can mount appropriately

1
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm

@ -135,6 +135,7 @@ tcl::namespace::eval punk::aliascore {
smcup ::punk::console::enable_alt_screen\ smcup ::punk::console::enable_alt_screen\
rmcup ::punk::console::disable_alt_screen\ rmcup ::punk::console::disable_alt_screen\
config ::punk::config\ config ::punk::config\
s ::punk::ns::synopsis\
] ]
#*** !doctools #*** !doctools

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

@ -3465,26 +3465,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
foreach {pt code} $parts { foreach {pt code} $parts {
switch -- [llength $codestack] { switch -- [llength $codestack] {
0 { 0 {
append emit $base$pt$R append emit $base $pt $R
} }
1 { 1 {
if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} {
append emit $base$pt$R append emit $base $pt $R
set codestack [list] set codestack [list]
} else { } else {
#append emit [lindex $o_codestack 0]$pt #append emit [lindex $o_codestack 0]$pt
if {$fullmerge} { if {$fullmerge} {
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R
} }
} }
} }
default { default {
if {$fullmerge} { if {$fullmerge} {
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R
} }
} }
} }
@ -3528,7 +3528,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append emit $code append emit $code
} }
} }
return $emit$R return [append emit $R]
} else { } else {
return $base$text$R return $base$text$R
} }

6400
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.6.tm

File diff suppressed because it is too large Load Diff

6458
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.7.tm

File diff suppressed because it is too large Load Diff

72
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm

@ -250,16 +250,11 @@ namespace eval punk::cap::handlers::templates {
namespace export * namespace export *
namespace eval class { namespace eval class {
variable PUNKARGS variable PUNKARGS
#set argd [punk::args::get_dict { #lappend PUNKARGS [list {
# @id -id "::punk::cap::handlers::templates::class::api folders" # @id -id "::punk::cap::handlers::templates::class::api folders"
# -startdir -default "" # -startdir -default ""
# @values -max 0 # @values -max 0
#} $args] #}]
lappend PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api folders"
-startdir -default ""
@values -max 0
}]
oo::class create api { oo::class create api {
#return a dict keyed on folder with source pkg as value #return a dict keyed on folder with source pkg as value
@ -269,9 +264,18 @@ namespace eval punk::cap::handlers::templates {
set cname [string map {. _} $capname] set cname [string map {. _} $capname]
set capabilityname $capname set capabilityname $capname
} }
set class_ns [uplevel 1 [list namespace current]]
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api folders"
@cmd -name "punk::cap::handlers::templates::class::api folders"
-startdir -default "" -help\
"Defaults to CWD if not supplied"
@values -max 0
}]
method folders {args} { method folders {args} {
#puts "--folders $args" #puts "--folders $args"
set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] set argd [punk::args::parse $args withid "[self class] folders"]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set opt_startdir [dict get $opts -startdir] set opt_startdir [dict get $opts -startdir]
@ -488,14 +492,19 @@ namespace eval punk::cap::handlers::templates {
} }
return $folderdict return $folderdict
} }
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\
""
@opts -anyopts 1
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
}]
method get_itemdict_projectlayouts {args} { method get_itemdict_projectlayouts {args} {
set argd [punk::args::get_dict {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" set argd [punk::args::parse $args withid "[self class] get_itemdict_projectlayouts"]
@opts -anyopts 1
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
} $args]
set opt_startdir [dict get $argd opts -startdir] set opt_startdir [dict get $argd opts -startdir]
if {$opt_startdir eq ""} { if {$opt_startdir eq ""} {
@ -663,23 +672,26 @@ namespace eval punk::cap::handlers::templates {
my _get_itemdict {*}$arglist my _get_itemdict {*}$arglist
} }
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api _get_itemdict"
@cmd -name _get_itemdict
@opts -anyopts 0
-startdir -default ""
-templatefolder_subdir -optional 0
-command_get_items_from_base -optional 0
-command_get_item_name -optional 0
-not -default "" -multiple 1
@values -maxvalues -1
globsearches -default * -multiple 1
}]
#shared algorithm for get_itemdict_* methods #shared algorithm for get_itemdict_* methods
#requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search
#and a file selection mechanism command -command_get_items_from_base #and a file selection mechanism command -command_get_items_from_base
#and a name determining command -command_get_item_name #and a name determining command -command_get_item_name
method _get_itemdict {args} { method _get_itemdict {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid "[self class] _get_itemdict"]
@id -id "::punk::cap::handlers::templates::class::api _get_itemdict"
@cmd -name _get_itemdict
@opts -anyopts 0
-startdir -default ""
-templatefolder_subdir -optional 0
-command_get_items_from_base -optional 0
-command_get_item_name -optional 0
-not -default "" -multiple 1
@values -maxvalues -1
globsearches -default * -multiple 1
} $args]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results
#puts stderr "=-=============>globsearches:$globsearches" #puts stderr "=-=============>globsearches:$globsearches"

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

@ -44,8 +44,11 @@ tcl::namespace::eval punk::config {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
proc dir {args} { proc dir {args} {
#set be_quiet [dict exists $received -quiet]
if {"-quiet" in $args} { if {"-quiet" in $args} {
set be_quiet [dict exists $received -quiet] set be_quiet 1
} else {
set be_quiet 0
} }
set was_noisy 0 set was_noisy 0
@ -445,6 +448,7 @@ tcl::namespace::eval punk::config {
"Get configuration values from a config. "Get configuration values from a config.
Accepts globs eg XDG*" Accepts globs eg XDG*"
@leaders -min 1 -max 1 @leaders -min 1 -max 1
#todo - load more whichconfig choices?
whichconfig -type string -choices {config startup-configuration running-configuration} whichconfig -type string -choices {config startup-configuration running-configuration}
@values -min 0 -max -1 @values -min 0 -max -1
globkey -type string -default * -optional 1 -multiple 1 globkey -type string -default * -optional 1 -multiple 1
@ -526,18 +530,23 @@ tcl::namespace::eval punk::config {
error "setting value not implemented" error "setting value not implemented"
} }
lappend PUNKARGS [list { namespace eval argdoc {
@dynamic set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}}
@id -id ::punk::config::show set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}}
@cmd -name punk::config::get -help\
"Display configuration values from a config. lappend PUNKARGS [list {
Accepts globs eg XDG*" @dynamic
@leaders -min 1 -max 1 @id -id ::punk::config::show
}\ @cmd -name punk::config::get -help\
{${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ "Display configuration values from a config.
"@values -min 0 -max -1"\ Accepts globs eg XDG*"
{${[punk::args::resolved_def -types values ::punk::config::get]}}\ @leaders -min 1 -max 1
] }\
{${$DYN_GET_LEADERS}}\
"@values -min 0 -max -1"\
{${$DYN_GET_VALUES}}\
]
}
proc show {args} { proc show {args} {
#todo - tables for console #todo - tables for console
set configrecords [punk::config::get {*}$args] set configrecords [punk::config::get {*}$args]
@ -568,7 +577,7 @@ tcl::namespace::eval punk::config {
toconfig -help\ toconfig -help\
"running or startup or file name (not fully implemented)" "running or startup or file name (not fully implemented)"
} }
set argd [punk::args::get_dict $argdef $args] set argd [punk::args::parse $args withdef $argdef]
set fromconfig [dict get $argd values fromconfig] set fromconfig [dict get $argd values fromconfig]
set toconfig [dict get $argd values toconfig] set toconfig [dict get $argd values toconfig]
set fromconfig [string map {-config ""} $fromconfig] set fromconfig [string map {-config ""} $fromconfig]

8
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm

@ -562,13 +562,13 @@ namespace eval punk::du {
proc Get_attributes_from_iteminfo {args} { proc Get_attributes_from_iteminfo {args} {
variable win_reparse_tags_by_int variable win_reparse_tags_by_int
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::du::lib::Get_attributes_from_iteminfo @id -id ::punk::du::lib::Get_attributes_from_iteminfo
-debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)"
-debugchannel -default stderr -help "channel to write debug output, or none to append to output" -debugchannel -default stderr -help "channel to write debug output, or none to append to output"
@values -min 1 -max 1 @values -min 1 -max 1
iteminfo -help "iteminfo dict as set by 'twapi::find_file_next <iterator> iteminfo'" iteminfo -help "iteminfo dict as set by 'twapi::find_file_next <iterator> iteminfo'"
} $args] }]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set iteminfo [dict get $argd values iteminfo] set iteminfo [dict get $argd values iteminfo]
set opt_debug [dict get $opts -debug] set opt_debug [dict get $opts -debug]
@ -621,14 +621,14 @@ namespace eval punk::du {
proc attributes_twapi {args} { proc attributes_twapi {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::du::lib::attributes_twapi @id -id ::punk::du::lib::attributes_twapi
-debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)"
-debugchannel -default stderr -help "channel to write debug output, or none to append to output" -debugchannel -default stderr -help "channel to write debug output, or none to append to output"
-detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field"
@values -min 1 -max 1 @values -min 1 -max 1
path -help "path to file or folder for which to retrieve attributes" path -help "path to file or folder for which to retrieve attributes"
} $args] }]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set path [dict get $argd values path] set path [dict get $argd values path]
set opt_detail [dict get $opts -detail] set opt_detail [dict get $opts -detail]

4
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm

@ -1559,9 +1559,9 @@ namespace eval punk::fileline::lib {
} }
proc range_boundaries {start end chunksizes args} { proc range_boundaries {start end chunksizes args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
-offset -default 0 -offset -default 0
} $args] }]
lassign [dict values $argd] leaders opts remainingargs lassign [dict values $argd] leaders opts remainingargs
} }

4237
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

@ -167,17 +167,17 @@ namespace eval punk::mix::commandset::doc {
cd $original_wd cd $original_wd
} }
proc validate {args} { proc validate {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::mix::commandset::doc::validate @id -id ::punk::mix::commandset::doc::validate
-- -type none -optional 1 -help "end of options marker --" -- -type none -optional 1 -help "end of options marker --"
-individual -type boolean -default 1 -individual -type boolean -default 1
@values -min 0 -max -1 @values -min 0 -max -1
patterns -default {*.man} -type any -multiple 1 patterns -default {*.man} -type any -multiple 1
} $args] }]
set opt_individual [tcl::dict::get $argd opts -individual] set opt_individual [tcl::dict::get $argd opts -individual]
set patterns [tcl::dict::get $argd values patterns] set patterns [tcl::dict::get $argd values patterns]
#todo - run and validate punk::docgen output #todo - run and validate punk::docgen output
set projectdir [punk::repo::find_project] set projectdir [punk::repo::find_project]
if {$projectdir eq ""} { if {$projectdir eq ""} {

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

@ -113,14 +113,16 @@ namespace eval punk::mix::commandset::layout {
return [join $layouts \n] return [join $layouts \n]
} }
punk::args::define {
@id -id ::punk::mix::commandset::layout::collection::_default
@cmd -name ::punk::mix::commandset::layout::collection::_default
-startdir -type string
-not -type string -multiple 1
globsearches -default * -multiple 1
}
proc _default {args} { proc _default {args} {
punk::args::get_dict [subst { punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default
@id -id ::punk::mix::commandset::layout::collection::_default
@cmd -name ::punk::mix::commandset::layout::collection::_default
-startdir -type string
-not -type string -multiple 1
globsearches -default * -multiple 1
}] $args
set tdict_low_to_high [as_dict {*}$args] set tdict_low_to_high [as_dict {*}$args]
#convert to screen order - with higher priority at the top #convert to screen order - with higher priority at the top

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

@ -1249,29 +1249,28 @@ namespace eval punk::mix::commandset::scriptwrap {
namespace eval lib { namespace eval lib {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}]
#[para] Library API functions for punk::mix::commandset::scriptwrap #[para] Library API functions for punk::mix::commandset::scriptwrap
#[list_begin definitions] #[list_begin definitions]
punk::args::define {
@id -id ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders
#*** !doctools
#[call [fun get_wrapper_folders] [arg args] ]
#[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo
#[para] Arguments:
# [list_begin arguments]
# [arg_def string args] name-value pairs -scriptpath <path>
# [list_end]
@cmd -name punk::mix::commandset::scriptwrap::lib::get_wrapper_folders -help\
"Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo"
@opts -anyopts 0
-scriptpath -default "" -type directory\
-help ""
#todo -help folder within a punk.templates provided area???
@values -minvalues 0 -maxvalues 0
}
proc get_wrapper_folders {args} { proc get_wrapper_folders {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders]
#*** !doctools
#[call [fun get_wrapper_folders] [arg args] ]
#[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo
#[para] Arguments:
# [list_begin arguments]
# [arg_def string args] name-value pairs -scriptpath <path>
# [list_end]
@id -id ::punk::mix::commandset::scriptwrap
@cmd -name punk::mix::commandset::get_wrapper_folders
@opts -anyopts 0
-scriptpath -default "" -type directory\
-help ""
#todo -help folder within a punk.templates provided area???
@values -minvalues 0 -maxvalues 0
} $args]
# -- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- ---
set opt_scriptpath [dict get $argd opts -scriptpath] set opt_scriptpath [dict get $argd opts -scriptpath]

23
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm

@ -726,18 +726,19 @@ tcl::namespace::eval punk::nav::fs {
# #
#if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern.
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
punk::args::define {
@id -id ::punk::nav::fs::dirfiles_dict
@cmd -name punk::nav::fs::dirfiles_dict
@opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
}
proc dirfiles_dict {args} { proc dirfiles_dict {args} {
set argspecs { set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
@id -id ::punk::nav::fs::dirfiles_dict
@opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] leaders opts vals lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals] set searchspecs [dict values $vals]

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

File diff suppressed because it is too large Load Diff

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

@ -174,7 +174,7 @@ tcl::namespace::eval punk::packagepreference {
set is_exact 1 set is_exact 1
} else { } else {
set pkg [lindex $args 1] set pkg [lindex $args 1]
set vwant [lrange $args 2 end] ;#rare - but version can be a list of options set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements
if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} {
#only one version - and it has a dash #only one version - and it has a dash
lassign [split [lindex $vwant 0] -] a b lassign [split [lindex $vwant 0] -] a b

14
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm

@ -100,8 +100,12 @@ namespace eval punk::repo {
subcommand -type string -choicecolumns 8 -choicegroups { subcommand -type string -choicecolumns 8 -choicegroups {
"frequently used commands" {${$maincommands}} "frequently used commands" {${$maincommands}}
"" {${$othercmds}} "" {${$othercmds}}
} } -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}}
}] }]
#-choiceinfo {
# add {{doctype punkargs}}
# diff {{doctype punkargs}}
#}
return $result return $result
} }
@ -112,7 +116,7 @@ namespace eval punk::repo {
# @id -id ::punk::repo::fossil_proxy # @id -id ::punk::repo::fossil_proxy
# @cmd -name fossil -help "fossil executable # @cmd -name fossil -help "fossil executable
# " # "
# @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} # @formdisplay -header "fossil help" -body {${[runout -n fossil help]}}
# } ""] # } ""]
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -129,7 +133,7 @@ namespace eval punk::repo {
@dynamic @dynamic
@id -id "::punk::repo::fossil_proxy diff" @id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff" -help "fossil diff" @cmd -name "fossil diff" -help "fossil diff"
@argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} @formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""] } ""]
lappend PUNKARGS [list { lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive #todo - remove this comment - testing dynamic directive
@ -137,7 +141,7 @@ namespace eval punk::repo {
@id -id "::punk::repo::fossil_proxy add" @id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add @cmd -name "fossil add" -help "fossil add
" "
@argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
} ""] } ""]
#TODO #TODO
#lappend PUNKARGS [list { #lappend PUNKARGS [list {
@ -145,7 +149,7 @@ namespace eval punk::repo {
# @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs}
# @cmd -name "fossil add" -help "fossil add # @cmd -name "fossil add" -help "fossil add
# " # "
# @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} # @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
# } ""] # } ""]
lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"}
lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"}

179
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm

@ -168,45 +168,45 @@ tcl::namespace::eval punk::zip {
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) expr {(($year-1980) << 25) | ($month << 21) | ($day << 16)
| ($hour << 11) | ($min << 5) | ($sec >> 1)} | ($hour << 11) | ($min << 5) | ($sec >> 1)}
} }
punk::args::define {
@id -id ::punk::zip::walk
@cmd -name punk::zip::walk -help\
"Walk the directory structure starting at base/<-subpath>
and return a list of the files and folders encountered.
Resulting paths are relative to base unless -resultrelative
is supplied.
Folder names will end with a trailing slash.
"
-resultrelative -optional 1 -help\
"Resulting paths are relative to this value.
Defaults to the value of base. If empty string
is given to -resultrelative the paths returned
are effectively absolute paths."
-emptydirs -default 0 -type boolean -help\
"Whether to include directory trees in the result which had no
matches for the given fileglobs.
Intermediate dirs are always returned if there is a match with
fileglobs further down even if -emptdirs is 0.
"
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
}
proc walk {args} { proc walk {args} {
#*** !doctools #*** !doctools
#[call [fun walk] [arg ?options?] [arg base]] #[call [fun walk] [arg ?options?] [arg base]]
#[para] Walk a directory tree rooted at base #[para] Walk a directory tree rooted at base
#[para] the -excludes list can be a set of glob expressions to match against files and avoid #[para] the -excludes list can be a set of glob expressions to match against files and avoid
#[para] e.g #[para] e.g
#[example { #[example {
# punk::zip::walk -exclude {CVS/* *~.#*} library # punk::zip::walk -exclude {CVS/* *~.#*} library
#}] #}]
#todo: -relative 0|1 flag? #todo: -relative 0|1 flag?
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::walk]
@id -id ::punk::zip::walk
@cmd -name punk::zip::walk -help\
"Walk the directory structure starting at base/<-subpath>
and return a list of the files and folders encountered.
Resulting paths are relative to base unless -resultrelative
is supplied.
Folder names will end with a trailing slash.
"
-resultrelative -optional 1 -help\
"Resulting paths are relative to this value.
Defaults to the value of base. If empty string
is given to -resultrelative the paths returned
are effectively absolute paths."
-emptydirs -default 0 -type boolean -help\
"Whether to include directory trees in the result which had no
matches for the given fileglobs.
Intermediate dirs are always returned if there is a match with
fileglobs further down even if -emptdirs is 0.
"
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base] set base [dict get $argd values base]
set fileglobs [dict get $argd values fileglobs] set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath] set subpath [dict get $argd opts -subpath]
@ -416,6 +416,20 @@ tcl::namespace::eval punk::zip {
punk::args::define {
@id -id ::punk::zip::Addentry
@cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan'
return a central directory file record"
@opts
-comment -default "" -help "An optional comment specific to the added file"
@values -min 3 -max 4
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header"
base -help "base path for entries"
path -type file -help "path of file to add"
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'"
}
# Addentry - was Mkzipfile -- # Addentry - was Mkzipfile --
# #
# FIX ME: should handle the current offset for non-seekable channels # FIX ME: should handle the current offset for non-seekable channels
@ -428,20 +442,7 @@ tcl::namespace::eval punk::zip {
#[para] You can provide a -comment for the file. #[para] You can provide a -comment for the file.
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive.
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::Addentry]
@id -id ::punk::zip::Addentry
@cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan'
return a central directory file record"
@opts
-comment -default "" -help "An optional comment specific to the added file"
@values -min 3 -max 4
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header"
base -help "base path for entries"
path -type file -help "path of file to add"
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'"
} $args]
set zipchan [dict get $argd values zipchan] set zipchan [dict get $argd values zipchan]
set base [dict get $argd values base] set base [dict get $argd values base]
set path [dict get $argd values path] set path [dict get $argd values path]
@ -558,10 +559,55 @@ tcl::namespace::eval punk::zip {
# we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip)
#### ####
punk::args::define {
@id -id ::punk::zip::mkzip
@cmd -name punk::zip::mkzip\
-help "Create a zip archive in 'filename'"
@opts
-offsettype -default "archive" -choices {archive file}\
-help "zip offsets stored relative to start of entire file or relative to start of zip-archive
Only relevant if the created file has a script/runtime prefix.
"
-return -default "pretty" -choices {pretty list none}\
-help "mkzip can return a list of the files and folders added to the archive
the option -return pretty is the default and uses the punk::lib pdict/plist system
to return a formatted list for the terminal
"
-zipkit -default 0 -type none\
-help "whether to add mounting script
mutually exclusive with -runtime option
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs
"
-runtime -default ""\
-help "specify a prefix file
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip
will create a self-extracting zip archive from the subdir/ folder.
Expects runtime with no existing vfs attached (review)
"
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
-help "The new zip archive will scan for contents within this folder or current directory if not provided.
Note that this will
"
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"}
@values -min 1 -max -1
filename -type file -default ""\
-help "name of zipfile to create"
globs -default {*} -multiple 1\
-help "list of glob patterns to match.
Only directories with matching files will be included in the archive."
}
# zip::mkzip -- # zip::mkzip --
# #
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt
# #
proc mkzip {args} { proc mkzip {args} {
#todo - doctools - [arg ?globs...?] syntax? #todo - doctools - [arg ?globs...?] syntax?
@ -581,50 +627,7 @@ tcl::namespace::eval punk::zip {
#[para] If a file already exists, an error will be raised. #[para] If a file already exists, an error will be raised.
#[para] Call 'punk::zip::mkzip' with no arguments for usage display. #[para] Call 'punk::zip::mkzip' with no arguments for usage display.
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::mkzip]
@id -id ::punk::zip::mkzip
@cmd -name punk::zip::mkzip\
-help "Create a zip archive in 'filename'"
@opts
-offsettype -default "archive" -choices {archive file}\
-help "zip offsets stored relative to start of entire file or relative to start of zip-archive
Only relevant if the created file has a script/runtime prefix.
"
-return -default "pretty" -choices {pretty list none}\
-help "mkzip can return a list of the files and folders added to the archive
the option -return pretty is the default and uses the punk::lib pdict/plist system
to return a formatted list for the terminal
"
-zipkit -default 0 -type none\
-help "whether to add mounting script
mutually exclusive with -runtime option
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs
"
-runtime -default ""\
-help "specify a prefix file
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip
will create a self-extracting zip archive from the subdir/ folder.
Expects runtime with no existing vfs attached (review)
"
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
-help "The new zip archive will scan for contents within this folder or current directory if not provided.
Note that this will
"
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"}
@values -min 1 -max -1
filename -type file -default ""\
-help "name of zipfile to create"
globs -default {*} -multiple 1\
-help "list of glob patterns to match.
Only directories with matching files will be included in the archive."
} $args]
set filename [dict get $argd values filename] set filename [dict get $argd values filename]
if {$filename eq ""} { if {$filename eq ""} {
error "mkzip filename cannot be empty string" error "mkzip filename cannot be empty string"

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

@ -140,16 +140,18 @@ tcl::namespace::eval textblock {
# hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
# "algorithm choice" # "algorithm choice"
namespace eval argdoc {
punk::args::define { set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]}
@dynamic punk::args::define {
@id -id ::textblock::use_hash @dynamic
@cmd -name "textblock::use_hash" -help\ @id -id ::textblock::use_hash
"Hashing algorithm to use for framecache lookup. @cmd -name "textblock::use_hash" -help\
'none' may be slightly faster but less compact "Hashing algorithm to use for framecache lookup.
when viewing textblock::framecache" 'none' may be slightly faster but less compact
@values -min 0 -max 1 when viewing textblock::framecache"
hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} @values -min 0 -max 1
hash_algorithm -optional 1 ${$DYN_HASH_ALGORITHM_CHOICES_AND_HELP}
}
} }
proc use_hash {args} { proc use_hash {args} {
#set argd [punk::args::get_by_id ::textblock::use_hash $args] #set argd [punk::args::get_by_id ::textblock::use_hash $args]
@ -4667,17 +4669,19 @@ tcl::namespace::eval textblock {
-size -type integer\ -size -type integer\
-default 15\ -default 15\
-optional 1\ -optional 1\
-range {1 15} -range {1 ""}
-direction -default horizontal\ -direction -default horizontal\
-choices {horizontal vertical}\ -choices {horizontal vertical}\
-help\ -help\
"When rainbow is in the colour list, "Direction of character increments.
this also affects the direction of When rainbow is in the colour list,
colour changes" the colour stripes will be oriented
@values -min 0 -max 2 in this direction.
"
@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 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
@ -4725,7 +4729,16 @@ tcl::namespace::eval textblock {
set chars [list {*}[punk::lib::range 1 9] A B C D E F] set chars [list {*}[punk::lib::range 1 9] A B C D E F]
set charsubset [lrange $chars 0 $size-1] if {$size <= 15} {
set charsubset [lrange $chars 0 $size-1]
} else {
set numsets [expr {int(ceil($size / 15.0))}]
set longset [concat {*}[lrepeat $numsets $chars]]
set charsubset [lrange $longset 0 $size-1]
set longbows [concat {*}[lrepeat $numsets $rainbow_list]]
set rainbow_list [lrange $longbows 0 $size-1]
}
if {"noreset" in $colour} { if {"noreset" in $colour} {
set RST "" set RST ""
} else { } else {
@ -4760,21 +4773,32 @@ tcl::namespace::eval textblock {
append row $c append row $c
} }
append row $RST append row $RST
append block $row\n append block $row \n
} }
set block [tcl::string::trimright $block \n] set block [tcl::string::trimright $block \n]
return $block return $block
} else { } else {
#row first - if {$direction eq "vertical"} {
set rows [list] #row first -
foreach ch $charsubset { set rows [list]
lappend rows [tcl::string::repeat $ch $size] foreach ch $charsubset {
} lappend rows [tcl::string::repeat $ch $size]
set block [::join $rows \n] }
if {$colour ne ""} { set block [::join $rows \n]
set block [a+ {*}$colour]$block$RST if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
return $block
} else {
set block ""
for {set r 0} {$r < $size} {incr r} {
append block [::join $charsubset ""] \n
}
if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
return $block
} }
return $block
} }
} }
interp alias {} testblock {} textblock::testblock interp alias {} testblock {} textblock::testblock
@ -5500,10 +5524,11 @@ tcl::namespace::eval textblock {
proc ::textblock::join1 {args} { proc ::textblock::join1 {args} {
lassign [punk::args::get_dict { lassign [punk::args::parse $args withdef {
@id -id ::textblock::join1
-ansiresets -default 1 -type integer -ansiresets -default 1 -type integer
blocks -type string -multiple 1 blocks -type string -multiple 1
} $args] _l leaders _o opts _v values }] _l leaders _o opts _v values
set blocks [tcl::dict::get $values blocks] set blocks [tcl::dict::get $values blocks]
set idx 0 set idx 0
@ -5578,11 +5603,12 @@ tcl::namespace::eval textblock {
#@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width.
# Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
#" #"
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::textblock::join_basic2
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto -ansiresets -type any -default auto
blocks -type any -multiple 1 blocks -type any -multiple 1
} $args] }]
set ansiresets [tcl::dict::get $argd opts -ansiresets] set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks] set blocks [tcl::dict::get $argd values blocks]
@ -5619,12 +5645,6 @@ tcl::namespace::eval textblock {
#for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed
#they may however still be 'ragged' ie differing line lengths #they may however still be 'ragged' ie differing line lengths
proc ::textblock::join {args} { proc ::textblock::join {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
#we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets
@ -5709,11 +5729,6 @@ tcl::namespace::eval textblock {
} }
proc ::textblock::join2 {args} { proc ::textblock::join2 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
@ -5801,11 +5816,6 @@ tcl::namespace::eval textblock {
} }
# This calls textblock::pad per cell :/ # This calls textblock::pad per cell :/
proc ::textblock::join3 {args} { proc ::textblock::join3 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
@ -5984,7 +5994,7 @@ tcl::namespace::eval textblock {
NOTE: more options available - argument definition NOTE: more options available - argument definition
is incomplete" is incomplete"
@opts @opts
-return -choices {table tableobject} -return -default table -choices {table tableobject}
-rows -type list -default "" -help\ -rows -type list -default "" -help\
"A list of lists. "A list of lists.
Each toplevel element represents a row. Each toplevel element represents a row.
@ -6213,7 +6223,7 @@ tcl::namespace::eval textblock {
-help "restrict to keys matching memberglob." -help "restrict to keys matching memberglob."
}] }]
#append spec \n "frametype -help \"A predefined \"" #append spec \n "frametype -help \"A predefined \""
punk::args::get_dict $spec $args punk::args::parse $args withdef $spec
return return
} }

4
src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl

@ -2044,6 +2044,10 @@ if {[file exists $mapfile]} {
} }
# -- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- ---
puts "-- runtime_vfs_map --" puts "-- runtime_vfs_map --"
set ver [package require punk::args]
puts "punk::args ver: $ver"
set ifneeded [package ifneeded punk::args $ver]
puts "punk::args ifneeded: $ifneeded"
punk::lib::pdict runtime_vfs_map punk::lib::pdict runtime_vfs_map
puts "---------------------" puts "---------------------"
puts "-- vfs_runtime_map--" puts "-- vfs_runtime_map--"

56
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/argparsingtest-0.1.0.tm

@ -10,7 +10,7 @@
# @@ Meta Begin # @@ Meta Begin
# Application argparsingtest 0.1.0 # Application argparsingtest 0.1.0
# Meta platform tcl # Meta platform tcl
# Meta license MIT # Meta license MIT
# @@ Meta End # @@ Meta End
@ -21,7 +21,7 @@
#[manpage_begin punkshell_module_argparsingtest 0 0.1.0] #[manpage_begin punkshell_module_argparsingtest 0 0.1.0]
#[copyright "2024"] #[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}] #[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require argparsingtest] #[require argparsingtest]
#[keywords module] #[keywords module]
#[description] #[description]
@ -106,7 +106,7 @@ namespace eval argparsingtest {
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest}] #[subsection {Namespace argparsingtest}]
#[para] Core API functions for argparsingtest #[para] Core API functions for argparsingtest
#[list_begin definitions] #[list_begin definitions]
proc test1_ni {args} { proc test1_ni {args} {
@ -277,8 +277,8 @@ namespace eval argparsingtest {
#punk::args is slower than argp - but comparable, and argp doesn't support solo flags #punk::args is slower than argp - but comparable, and argp doesn't support solo flags
proc test1_punkargs {args} { proc test1_punkargs {args} {
set argd [punk::args::parse $args withdef { set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs @id -id ::argparsingtest::test1_punkargs
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -298,7 +298,7 @@ namespace eval argparsingtest {
punk::args::define { punk::args::define {
@id -id ::test1_punkargs_by_id @id -id ::test1_punkargs_by_id
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -320,7 +320,7 @@ namespace eval argparsingtest {
punk::args::define { punk::args::define {
@id -id ::argparsingtest::test1_punkargs2 @id -id ::argparsingtest::test1_punkargs2
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -return -default string -type string
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -334,7 +334,7 @@ namespace eval argparsingtest {
-2 -default 2 -type integer -2 -default 2 -type integer
-3 -default 3 -type integer -3 -default 3 -type integer
@values @values
} }
proc test1_punkargs2 {args} { proc test1_punkargs2 {args} {
set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args] set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs2 $args]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
@ -342,9 +342,9 @@ namespace eval argparsingtest {
proc test1_punkargs_validate_ansistripped {args} { proc test1_punkargs_validate_ansistripped {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs_validate_ansistripped @id -id ::argparsingtest::test1_punkargs_validate_ansistripped
@cmd -name argtest4 -help "test of punk::args::get_dict comparative performance" @cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0 @opts -anyopts 0
-return -default string -type string -choices {string object} -help "return type" -return -default string -type string -choices {string object} -help "return type"
-frametype -default \uFFEF -type string -frametype -default \uFFEF -type string
@ -358,7 +358,7 @@ namespace eval argparsingtest {
-2 -default 2 -type integer -validate_ansistripped true -2 -default 2 -type integer -validate_ansistripped true
-3 -default 3 -type integer -validate_ansistripped true -3 -default 3 -type integer -validate_ansistripped true
@values @values
} $args] }]
return [tcl::dict::get $argd opts] return [tcl::dict::get $argd opts]
} }
@ -387,11 +387,11 @@ namespace eval argparsingtest {
package require cmdline package require cmdline
#cmdline::getoptions is much faster than typedGetoptions #cmdline::getoptions is much faster than typedGetoptions
proc test1_cmdline_untyped {args} { proc test1_cmdline_untyped {args} {
set cmdlineopts_untyped { set cmdlineopts_untyped {
{return.arg "string" "return val"} {return.arg "string" "return val"}
{frametype.arg \uFFEF "frame type"} {frametype.arg \uFFEF "frame type"}
{show_edge.arg \uFFEF "show table borders"} {show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"} {show_seps.arg \uFFEF "show table seps"}
{join "join the things"} {join "join the things"}
{x.arg "" "arg x"} {x.arg "" "arg x"}
{y.arg b "arg y"} {y.arg b "arg y"}
@ -405,11 +405,11 @@ namespace eval argparsingtest {
return [::cmdline::getoptions args $cmdlineopts_untyped $usage] return [::cmdline::getoptions args $cmdlineopts_untyped $usage]
} }
proc test1_cmdline_typed {args} { proc test1_cmdline_typed {args} {
set cmdlineopts_typed { set cmdlineopts_typed {
{return.arg "string" "return val"} {return.arg "string" "return val"}
{frametype.arg \uFFEF "frame type"} {frametype.arg \uFFEF "frame type"}
{show_edge.arg \uFFEF "show table borders"} {show_edge.arg \uFFEF "show table borders"}
{show_seps.arg \uFFEF "show table seps"} {show_seps.arg \uFFEF "show table seps"}
{join "join the things"} {join "join the things"}
{x.arg "" "arg x"} {x.arg "" "arg x"}
{y.arg b "arg y"} {y.arg b "arg y"}
@ -465,7 +465,7 @@ namespace eval argparsingtest {
#multiline values use first line of each record to determine amount of indent to trim #multiline values use first line of each record to determine amount of indent to trim
proc test_multiline {args} { proc test_multiline {args} {
set t3 [textblock::frame t3] set t3 [textblock::frame t3]
set argd [punk::args::get_dict [subst { set argd [punk::args::parse $args withdef [subst {
-template1 -default { -template1 -default {
****** ******
* t1 * * t1 *
@ -476,7 +476,7 @@ namespace eval argparsingtest {
* t2 * * t2 *
******} ******}
-template3 -default {$t3} -template3 -default {$t3}
#substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately #substituted or literal values with newlines - no autoindent applied - caller will have to pad appropriately
-template3b -default { -template3b -default {
$t3 $t3
----------------- -----------------
@ -491,20 +491,20 @@ namespace eval argparsingtest {
" "
-flag -default 0 -type boolean -flag -default 0 -type boolean
}] $args] }]]
return $argd return $argd
} }
#proc sample1 {p1 n args} { #proc sample1 {p1 n args} {
# #*** !doctools # #*** !doctools
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]]
# #[para]Description of sample1 # #[para]Description of sample1
# #[para] Arguments: # #[para] Arguments:
# # [list_begin arguments] # # [list_begin arguments]
# # [arg_def tring p1] A description of string argument p1. # # [arg_def tring p1] A description of string argument p1.
# # [arg_def integer n] A description of integer argument n. # # [arg_def integer n] A description of integer argument n.
# # [list_end] # # [list_end]
# return "ok" # return "ok"
#} #}
@ -524,14 +524,14 @@ namespace eval argparsingtest::lib {
namespace path [namespace parent] namespace path [namespace parent]
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest::lib}] #[subsection {Namespace argparsingtest::lib}]
#[para] Secondary functions that are part of the API #[para] Secondary functions that are part of the API
#[list_begin definitions] #[list_begin definitions]
#proc utility1 {p1 args} { #proc utility1 {p1 args} {
# #*** !doctools # #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1 # #[para]Description of utility1
# return 1 # return 1
#} #}
@ -549,17 +549,17 @@ namespace eval argparsingtest::lib {
namespace eval argparsingtest::system { namespace eval argparsingtest::system {
#*** !doctools #*** !doctools
#[subsection {Namespace argparsingtest::system}] #[subsection {Namespace argparsingtest::system}]
#[para] Internal functions that are not part of the API #[para] Internal functions that are not part of the API
} }
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready ## Ready
package provide argparsingtest [namespace eval argparsingtest { package provide argparsingtest [namespace eval argparsingtest {
variable pkg argparsingtest variable pkg argparsingtest
variable version variable version
set version 0.1.0 set version 0.1.0
}] }]
return return

6
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.3.tm

@ -99,8 +99,11 @@ namespace eval commandstack {
} }
} }
proc get_stack {command} { proc get_stack {{command ""}} {
variable all_stacks variable all_stacks
if {$command eq ""} {
return $all_stacks
}
set command [uplevel 1 [list namespace which $command]] set command [uplevel 1 [list namespace which $command]]
if {[dict exists $all_stacks $command]} { if {[dict exists $all_stacks $command]} {
return [dict get $all_stacks $command] return [dict get $all_stacks $command]
@ -116,6 +119,7 @@ namespace eval commandstack {
variable all_stacks variable all_stacks
if {[dict exists $all_stacks $command]} { if {[dict exists $all_stacks $command]} {
set stack [dict get $all_stacks $command] set stack [dict get $all_stacks $command]
#stack is a list of dicts, 1st entry is token {<cmd> <renamer> <tokenid>}
set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]]
if {$posn > -1} { if {$posn > -1} {
set record [lindex $stack $posn] set record [lindex $stack $posn]

25
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/modpod-0.1.3.tm

@ -134,12 +134,12 @@ namespace eval modpod {
#old tar connect mechanism - review - not needed? #old tar connect mechanism - review - not needed?
proc connect {args} { proc connect {args} {
puts stderr "modpod::connect--->>$args" puts stderr "modpod::connect--->>$args"
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::modpod::connect @id -id ::modpod::connect
-type -default "" -type -default ""
@values -min 1 -max 1 @values -min 1 -max 1
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)"
} $args] }]
catch { catch {
punk::lib::showdict $argd ;#heavy dependencies punk::lib::showdict $argd ;#heavy dependencies
} }
@ -168,7 +168,7 @@ namespace eval modpod {
} else { } else {
#connect to .tm but may still be unwrapped version available #connect to .tm but may still be unwrapped version available
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) lassign [::split [file rootname [file tail $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath)
set this_pkg_tm_folder [file dirname $modpodpath] set this_pkg_tm_folder [file dirname $modpodpath]
if {$connected(type,$modpodpath) ne "unwrapped"} { if {$connected(type,$modpodpath) ne "unwrapped"} {
#Not directly connected to unwrapped version - but may still be redirected there #Not directly connected to unwrapped version - but may still be redirected there
@ -225,11 +225,15 @@ namespace eval modpod {
if {$connected(startdata,$modpodpath) >= 0} { if {$connected(startdata,$modpodpath) >= 0} {
#verify we have a valid tar header #verify we have a valid tar header
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { if {![catch {::modpod::system::tar::readHeader [read $fh 512]}]} {
seek $fh $connected(startdata,$modpodpath) start seek $fh $connected(startdata,$modpodpath) start
return [list ok $fh] return [list ok $fh]
} else { } else {
#error "cannot verify tar header" #error "cannot verify tar header"
#try zipfs
if {[info commands tcl::zipfs::mount] ne ""} {
}
} }
} }
lpop connected(to) end lpop connected(to) end
@ -262,11 +266,12 @@ namespace eval modpod {
return 1 return 1
} }
proc get {args} { proc get {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::modpod::get
-from -default "" -help "path to pod" -from -default "" -help "path to pod"
*values -min 1 -max 1 @values -min 1 -max 1
filename filename
} $args] }]
set frompod [dict get $argd opts -from] set frompod [dict get $argd opts -from]
set filename [dict get $argd values filename] set filename [dict get $argd values filename]
@ -329,7 +334,7 @@ namespace eval modpod::lib {
#zipfile is a pure zip at this point - ie no script/exe header #zipfile is a pure zip at this point - ie no script/exe header
proc make_zip_modpod {args} { proc make_zip_modpod {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::modpod::lib::make_zip_modpod @id -id ::modpod::lib::make_zip_modpod
-offsettype -default "archive" -choices {archive file} -help\ -offsettype -default "archive" -choices {archive file} -help\
"Whether zip offsets are relative to start of file or start of zip-data within the file. "Whether zip offsets are relative to start of file or start of zip-data within the file.
@ -340,7 +345,7 @@ namespace eval modpod::lib {
@values -min 2 -max 2 @values -min 2 -max 2
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries"
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm"
} $args] }]
set zipfile [dict get $argd values zipfile] set zipfile [dict get $argd values zipfile]
set outfile [dict get $argd values outfile] set outfile [dict get $argd values outfile]
set opt_offsettype [dict get $argd opts -offsettype] set opt_offsettype [dict get $argd opts -offsettype]
@ -359,7 +364,7 @@ namespace eval modpod::lib {
set moddir [file dirname $modfile] set moddir [file dirname $modfile]
set mod_and_ver [file rootname [file tail $modfile]] set mod_and_ver [file rootname [file tail $modfile]]
lassign [split $mod_and_ver -] moduletail version lassign [split $mod_and_ver -] moduletail version
if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { if {[file exists $moddir/#modpod-$mod_and_ver]} {
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm
} else { } else {
#determine module namespace so we can mount appropriately #determine module namespace so we can mount appropriately

1
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm

@ -135,6 +135,7 @@ tcl::namespace::eval punk::aliascore {
smcup ::punk::console::enable_alt_screen\ smcup ::punk::console::enable_alt_screen\
rmcup ::punk::console::disable_alt_screen\ rmcup ::punk::console::disable_alt_screen\
config ::punk::config\ config ::punk::config\
s ::punk::ns::synopsis\
] ]
#*** !doctools #*** !doctools

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

@ -3465,26 +3465,26 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
foreach {pt code} $parts { foreach {pt code} $parts {
switch -- [llength $codestack] { switch -- [llength $codestack] {
0 { 0 {
append emit $base$pt$R append emit $base $pt $R
} }
1 { 1 {
if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} { if {[punk::ansi::codetype::is_sgr_reset [lindex $codestack 0]]} {
append emit $base$pt$R append emit $base $pt $R
set codestack [list] set codestack [list]
} else { } else {
#append emit [lindex $o_codestack 0]$pt #append emit [lindex $o_codestack 0]$pt
if {$fullmerge} { if {$fullmerge} {
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R
} }
} }
} }
default { default {
if {$fullmerge} { if {$fullmerge} {
append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge [list $base {*}$codestack {*}$overrides]] $pt $R
} else { } else {
append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]]$pt$R append emit [punk::ansi::codetype::sgr_merge_singles [list $base {*}$codestack {*}$overrides]] $pt $R
} }
} }
} }
@ -3528,7 +3528,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append emit $code append emit $code
} }
} }
return $emit$R return [append emit $R]
} else { } else {
return $base$text$R return $base$text$R
} }

6400
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.6.tm

File diff suppressed because it is too large Load Diff

6458
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.7.tm

File diff suppressed because it is too large Load Diff

72
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm

@ -250,16 +250,11 @@ namespace eval punk::cap::handlers::templates {
namespace export * namespace export *
namespace eval class { namespace eval class {
variable PUNKARGS variable PUNKARGS
#set argd [punk::args::get_dict { #lappend PUNKARGS [list {
# @id -id "::punk::cap::handlers::templates::class::api folders" # @id -id "::punk::cap::handlers::templates::class::api folders"
# -startdir -default "" # -startdir -default ""
# @values -max 0 # @values -max 0
#} $args] #}]
lappend PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api folders"
-startdir -default ""
@values -max 0
}]
oo::class create api { oo::class create api {
#return a dict keyed on folder with source pkg as value #return a dict keyed on folder with source pkg as value
@ -269,9 +264,18 @@ namespace eval punk::cap::handlers::templates {
set cname [string map {. _} $capname] set cname [string map {. _} $capname]
set capabilityname $capname set capabilityname $capname
} }
set class_ns [uplevel 1 [list namespace current]]
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api folders"
@cmd -name "punk::cap::handlers::templates::class::api folders"
-startdir -default "" -help\
"Defaults to CWD if not supplied"
@values -max 0
}]
method folders {args} { method folders {args} {
#puts "--folders $args" #puts "--folders $args"
set argd [punk::args::parse $args withid "::punk::cap::handlers::templates::class::api folders"] set argd [punk::args::parse $args withid "[self class] folders"]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set opt_startdir [dict get $opts -startdir] set opt_startdir [dict get $opts -startdir]
@ -488,14 +492,19 @@ namespace eval punk::cap::handlers::templates {
} }
return $folderdict return $folderdict
} }
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\
""
@opts -anyopts 1
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
}]
method get_itemdict_projectlayouts {args} { method get_itemdict_projectlayouts {args} {
set argd [punk::args::get_dict {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" set argd [punk::args::parse $args withid "[self class] get_itemdict_projectlayouts"]
@opts -anyopts 1
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
} $args]
set opt_startdir [dict get $argd opts -startdir] set opt_startdir [dict get $argd opts -startdir]
if {$opt_startdir eq ""} { if {$opt_startdir eq ""} {
@ -663,23 +672,26 @@ namespace eval punk::cap::handlers::templates {
my _get_itemdict {*}$arglist my _get_itemdict {*}$arglist
} }
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api _get_itemdict"
@cmd -name _get_itemdict
@opts -anyopts 0
-startdir -default ""
-templatefolder_subdir -optional 0
-command_get_items_from_base -optional 0
-command_get_item_name -optional 0
-not -default "" -multiple 1
@values -maxvalues -1
globsearches -default * -multiple 1
}]
#shared algorithm for get_itemdict_* methods #shared algorithm for get_itemdict_* methods
#requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search
#and a file selection mechanism command -command_get_items_from_base #and a file selection mechanism command -command_get_items_from_base
#and a name determining command -command_get_item_name #and a name determining command -command_get_item_name
method _get_itemdict {args} { method _get_itemdict {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid "[self class] _get_itemdict"]
@id -id "::punk::cap::handlers::templates::class::api _get_itemdict"
@cmd -name _get_itemdict
@opts -anyopts 0
-startdir -default ""
-templatefolder_subdir -optional 0
-command_get_items_from_base -optional 0
-command_get_item_name -optional 0
-not -default "" -multiple 1
@values -maxvalues -1
globsearches -default * -multiple 1
} $args]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results
#puts stderr "=-=============>globsearches:$globsearches" #puts stderr "=-=============>globsearches:$globsearches"

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

@ -44,8 +44,11 @@ tcl::namespace::eval punk::config {
@values -min 0 -max 0 @values -min 0 -max 0
}] }]
proc dir {args} { proc dir {args} {
#set be_quiet [dict exists $received -quiet]
if {"-quiet" in $args} { if {"-quiet" in $args} {
set be_quiet [dict exists $received -quiet] set be_quiet 1
} else {
set be_quiet 0
} }
set was_noisy 0 set was_noisy 0
@ -445,6 +448,7 @@ tcl::namespace::eval punk::config {
"Get configuration values from a config. "Get configuration values from a config.
Accepts globs eg XDG*" Accepts globs eg XDG*"
@leaders -min 1 -max 1 @leaders -min 1 -max 1
#todo - load more whichconfig choices?
whichconfig -type string -choices {config startup-configuration running-configuration} whichconfig -type string -choices {config startup-configuration running-configuration}
@values -min 0 -max -1 @values -min 0 -max -1
globkey -type string -default * -optional 1 -multiple 1 globkey -type string -default * -optional 1 -multiple 1
@ -526,18 +530,23 @@ tcl::namespace::eval punk::config {
error "setting value not implemented" error "setting value not implemented"
} }
lappend PUNKARGS [list { namespace eval argdoc {
@dynamic set DYN_GET_LEADERS {${[punk::args::resolved_def -types leaders ::punk::config::get]}}
@id -id ::punk::config::show set DYN_GET_VALUES {${[punk::args::resolved_def -types values ::punk::config::get]}}
@cmd -name punk::config::get -help\
"Display configuration values from a config. lappend PUNKARGS [list {
Accepts globs eg XDG*" @dynamic
@leaders -min 1 -max 1 @id -id ::punk::config::show
}\ @cmd -name punk::config::get -help\
{${[punk::args::resolved_def -types leaders ::punk::config::get]}}\ "Display configuration values from a config.
"@values -min 0 -max -1"\ Accepts globs eg XDG*"
{${[punk::args::resolved_def -types values ::punk::config::get]}}\ @leaders -min 1 -max 1
] }\
{${$DYN_GET_LEADERS}}\
"@values -min 0 -max -1"\
{${$DYN_GET_VALUES}}\
]
}
proc show {args} { proc show {args} {
#todo - tables for console #todo - tables for console
set configrecords [punk::config::get {*}$args] set configrecords [punk::config::get {*}$args]
@ -568,7 +577,7 @@ tcl::namespace::eval punk::config {
toconfig -help\ toconfig -help\
"running or startup or file name (not fully implemented)" "running or startup or file name (not fully implemented)"
} }
set argd [punk::args::get_dict $argdef $args] set argd [punk::args::parse $args withdef $argdef]
set fromconfig [dict get $argd values fromconfig] set fromconfig [dict get $argd values fromconfig]
set toconfig [dict get $argd values toconfig] set toconfig [dict get $argd values toconfig]
set fromconfig [string map {-config ""} $fromconfig] set fromconfig [string map {-config ""} $fromconfig]

8
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm

@ -562,13 +562,13 @@ namespace eval punk::du {
proc Get_attributes_from_iteminfo {args} { proc Get_attributes_from_iteminfo {args} {
variable win_reparse_tags_by_int variable win_reparse_tags_by_int
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::du::lib::Get_attributes_from_iteminfo @id -id ::punk::du::lib::Get_attributes_from_iteminfo
-debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)"
-debugchannel -default stderr -help "channel to write debug output, or none to append to output" -debugchannel -default stderr -help "channel to write debug output, or none to append to output"
@values -min 1 -max 1 @values -min 1 -max 1
iteminfo -help "iteminfo dict as set by 'twapi::find_file_next <iterator> iteminfo'" iteminfo -help "iteminfo dict as set by 'twapi::find_file_next <iterator> iteminfo'"
} $args] }]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set iteminfo [dict get $argd values iteminfo] set iteminfo [dict get $argd values iteminfo]
set opt_debug [dict get $opts -debug] set opt_debug [dict get $opts -debug]
@ -621,14 +621,14 @@ namespace eval punk::du {
proc attributes_twapi {args} { proc attributes_twapi {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::du::lib::attributes_twapi @id -id ::punk::du::lib::attributes_twapi
-debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)" -debug -default 0 -help "set 1 for raw data on -debugchannel (default stderr)"
-debugchannel -default stderr -help "channel to write debug output, or none to append to output" -debugchannel -default stderr -help "channel to write debug output, or none to append to output"
-detail -default basic -choices {basic full} -help "full returns also the altname/shortname field" -detail -default basic -choices {basic full} -help "full returns also the altname/shortname field"
@values -min 1 -max 1 @values -min 1 -max 1
path -help "path to file or folder for which to retrieve attributes" path -help "path to file or folder for which to retrieve attributes"
} $args] }]
set opts [dict get $argd opts] set opts [dict get $argd opts]
set path [dict get $argd values path] set path [dict get $argd values path]
set opt_detail [dict get $opts -detail] set opt_detail [dict get $opts -detail]

4
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm

@ -1559,9 +1559,9 @@ namespace eval punk::fileline::lib {
} }
proc range_boundaries {start end chunksizes args} { proc range_boundaries {start end chunksizes args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
-offset -default 0 -offset -default 0
} $args] }]
lassign [dict values $argd] leaders opts remainingargs lassign [dict values $argd] leaders opts remainingargs
} }

4237
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.2.tm

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

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

@ -167,17 +167,17 @@ namespace eval punk::mix::commandset::doc {
cd $original_wd cd $original_wd
} }
proc validate {args} { proc validate {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::punk::mix::commandset::doc::validate @id -id ::punk::mix::commandset::doc::validate
-- -type none -optional 1 -help "end of options marker --" -- -type none -optional 1 -help "end of options marker --"
-individual -type boolean -default 1 -individual -type boolean -default 1
@values -min 0 -max -1 @values -min 0 -max -1
patterns -default {*.man} -type any -multiple 1 patterns -default {*.man} -type any -multiple 1
} $args] }]
set opt_individual [tcl::dict::get $argd opts -individual] set opt_individual [tcl::dict::get $argd opts -individual]
set patterns [tcl::dict::get $argd values patterns] set patterns [tcl::dict::get $argd values patterns]
#todo - run and validate punk::docgen output #todo - run and validate punk::docgen output
set projectdir [punk::repo::find_project] set projectdir [punk::repo::find_project]
if {$projectdir eq ""} { if {$projectdir eq ""} {

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

@ -113,14 +113,16 @@ namespace eval punk::mix::commandset::layout {
return [join $layouts \n] return [join $layouts \n]
} }
punk::args::define {
@id -id ::punk::mix::commandset::layout::collection::_default
@cmd -name ::punk::mix::commandset::layout::collection::_default
-startdir -type string
-not -type string -multiple 1
globsearches -default * -multiple 1
}
proc _default {args} { proc _default {args} {
punk::args::get_dict [subst { punk::args::parse $args withid ::punk::mix::commandset::layout::collection::_default
@id -id ::punk::mix::commandset::layout::collection::_default
@cmd -name ::punk::mix::commandset::layout::collection::_default
-startdir -type string
-not -type string -multiple 1
globsearches -default * -multiple 1
}] $args
set tdict_low_to_high [as_dict {*}$args] set tdict_low_to_high [as_dict {*}$args]
#convert to screen order - with higher priority at the top #convert to screen order - with higher priority at the top

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

@ -1249,29 +1249,28 @@ namespace eval punk::mix::commandset::scriptwrap {
namespace eval lib { namespace eval lib {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::mix::commandset::scriptwrap::lib}] #[subsection {Namespace punk::mix::commandset::scriptwrap::lib}]
#[para] Library API functions for punk::mix::commandset::scriptwrap #[para] Library API functions for punk::mix::commandset::scriptwrap
#[list_begin definitions] #[list_begin definitions]
punk::args::define {
@id -id ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders
#*** !doctools
#[call [fun get_wrapper_folders] [arg args] ]
#[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo
#[para] Arguments:
# [list_begin arguments]
# [arg_def string args] name-value pairs -scriptpath <path>
# [list_end]
@cmd -name punk::mix::commandset::scriptwrap::lib::get_wrapper_folders -help\
"Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo"
@opts -anyopts 0
-scriptpath -default "" -type directory\
-help ""
#todo -help folder within a punk.templates provided area???
@values -minvalues 0 -maxvalues 0
}
proc get_wrapper_folders {args} { proc get_wrapper_folders {args} {
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::mix::commandset::scriptwrap::lib::get_wrapper_folders]
#*** !doctools
#[call [fun get_wrapper_folders] [arg args] ]
#[para] Return list of dicts representing wrapper folders in the project. keys: basefolder sourceinfo
#[para] Arguments:
# [list_begin arguments]
# [arg_def string args] name-value pairs -scriptpath <path>
# [list_end]
@id -id ::punk::mix::commandset::scriptwrap
@cmd -name punk::mix::commandset::get_wrapper_folders
@opts -anyopts 0
-scriptpath -default "" -type directory\
-help ""
#todo -help folder within a punk.templates provided area???
@values -minvalues 0 -maxvalues 0
} $args]
# -- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- ---
set opt_scriptpath [dict get $argd opts -scriptpath] set opt_scriptpath [dict get $argd opts -scriptpath]

23
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm

@ -726,18 +726,19 @@ tcl::namespace::eval punk::nav::fs {
# #
#if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern.
# -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied
punk::args::define {
@id -id ::punk::nav::fs::dirfiles_dict
@cmd -name punk::nav::fs::dirfiles_dict
@opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
}
proc dirfiles_dict {args} { proc dirfiles_dict {args} {
set argspecs { set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
@id -id ::punk::nav::fs::dirfiles_dict
@opts -any 0
-searchbase -default ""
-tailglob -default "\uFFFF"
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
}
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] leaders opts vals lassign [dict values $argd] leaders opts vals
set searchspecs [dict values $vals] set searchspecs [dict values $vals]

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

File diff suppressed because it is too large Load Diff

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

@ -174,7 +174,7 @@ tcl::namespace::eval punk::packagepreference {
set is_exact 1 set is_exact 1
} else { } else {
set pkg [lindex $args 1] set pkg [lindex $args 1]
set vwant [lrange $args 2 end] ;#rare - but version can be a list of options set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements
if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} {
#only one version - and it has a dash #only one version - and it has a dash
lassign [split [lindex $vwant 0] -] a b lassign [split [lindex $vwant 0] -] a b

14
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm

@ -100,8 +100,12 @@ namespace eval punk::repo {
subcommand -type string -choicecolumns 8 -choicegroups { subcommand -type string -choicecolumns 8 -choicegroups {
"frequently used commands" {${$maincommands}} "frequently used commands" {${$maincommands}}
"" {${$othercmds}} "" {${$othercmds}}
} } -choiceinfo {add {{doctype punkargs}} diff {{doctype punkargs}}}
}] }]
#-choiceinfo {
# add {{doctype punkargs}}
# diff {{doctype punkargs}}
#}
return $result return $result
} }
@ -112,7 +116,7 @@ namespace eval punk::repo {
# @id -id ::punk::repo::fossil_proxy # @id -id ::punk::repo::fossil_proxy
# @cmd -name fossil -help "fossil executable # @cmd -name fossil -help "fossil executable
# " # "
# @argdisplay -header "fossil help" -body {${[runout -n fossil help]}} # @formdisplay -header "fossil help" -body {${[runout -n fossil help]}}
# } ""] # } ""]
lappend PUNKARGS [list { lappend PUNKARGS [list {
@ -129,7 +133,7 @@ namespace eval punk::repo {
@dynamic @dynamic
@id -id "::punk::repo::fossil_proxy diff" @id -id "::punk::repo::fossil_proxy diff"
@cmd -name "fossil diff" -help "fossil diff" @cmd -name "fossil diff" -help "fossil diff"
@argdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}} @formdisplay -header "fossil help diff" -body {${[runout -n fossil help diff]}}
} ""] } ""]
lappend PUNKARGS [list { lappend PUNKARGS [list {
#todo - remove this comment - testing dynamic directive #todo - remove this comment - testing dynamic directive
@ -137,7 +141,7 @@ namespace eval punk::repo {
@id -id "::punk::repo::fossil_proxy add" @id -id "::punk::repo::fossil_proxy add"
@cmd -name "fossil add" -help "fossil add @cmd -name "fossil add" -help "fossil add
" "
@argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
} ""] } ""]
#TODO #TODO
#lappend PUNKARGS [list { #lappend PUNKARGS [list {
@ -145,7 +149,7 @@ namespace eval punk::repo {
# @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs} # @id -glob 1 -id "::punk::repo::fossil_proxy *" -aliases {fs}
# @cmd -name "fossil add" -help "fossil add # @cmd -name "fossil add" -help "fossil add
# " # "
# @argdisplay -header "fossil help add" -body {${[runout -n fossil help add]}} # @formdisplay -header "fossil help add" -body {${[runout -n fossil help add]}}
# } ""] # } ""]
lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"} lappend PUNKARGS_aliases {"::fossil" "::punk::repo::fossil_proxy"}
lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"} lappend PUNKARGS_aliases {"::fossil diff" "::punk::repo::fossil_proxy diff"}

179
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm

@ -168,45 +168,45 @@ tcl::namespace::eval punk::zip {
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) expr {(($year-1980) << 25) | ($month << 21) | ($day << 16)
| ($hour << 11) | ($min << 5) | ($sec >> 1)} | ($hour << 11) | ($min << 5) | ($sec >> 1)}
} }
punk::args::define {
@id -id ::punk::zip::walk
@cmd -name punk::zip::walk -help\
"Walk the directory structure starting at base/<-subpath>
and return a list of the files and folders encountered.
Resulting paths are relative to base unless -resultrelative
is supplied.
Folder names will end with a trailing slash.
"
-resultrelative -optional 1 -help\
"Resulting paths are relative to this value.
Defaults to the value of base. If empty string
is given to -resultrelative the paths returned
are effectively absolute paths."
-emptydirs -default 0 -type boolean -help\
"Whether to include directory trees in the result which had no
matches for the given fileglobs.
Intermediate dirs are always returned if there is a match with
fileglobs further down even if -emptdirs is 0.
"
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
}
proc walk {args} { proc walk {args} {
#*** !doctools #*** !doctools
#[call [fun walk] [arg ?options?] [arg base]] #[call [fun walk] [arg ?options?] [arg base]]
#[para] Walk a directory tree rooted at base #[para] Walk a directory tree rooted at base
#[para] the -excludes list can be a set of glob expressions to match against files and avoid #[para] the -excludes list can be a set of glob expressions to match against files and avoid
#[para] e.g #[para] e.g
#[example { #[example {
# punk::zip::walk -exclude {CVS/* *~.#*} library # punk::zip::walk -exclude {CVS/* *~.#*} library
#}] #}]
#todo: -relative 0|1 flag? #todo: -relative 0|1 flag?
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::walk]
@id -id ::punk::zip::walk
@cmd -name punk::zip::walk -help\
"Walk the directory structure starting at base/<-subpath>
and return a list of the files and folders encountered.
Resulting paths are relative to base unless -resultrelative
is supplied.
Folder names will end with a trailing slash.
"
-resultrelative -optional 1 -help\
"Resulting paths are relative to this value.
Defaults to the value of base. If empty string
is given to -resultrelative the paths returned
are effectively absolute paths."
-emptydirs -default 0 -type boolean -help\
"Whether to include directory trees in the result which had no
matches for the given fileglobs.
Intermediate dirs are always returned if there is a match with
fileglobs further down even if -emptdirs is 0.
"
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
} $args]
set base [dict get $argd values base] set base [dict get $argd values base]
set fileglobs [dict get $argd values fileglobs] set fileglobs [dict get $argd values fileglobs]
set subpath [dict get $argd opts -subpath] set subpath [dict get $argd opts -subpath]
@ -416,6 +416,20 @@ tcl::namespace::eval punk::zip {
punk::args::define {
@id -id ::punk::zip::Addentry
@cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan'
return a central directory file record"
@opts
-comment -default "" -help "An optional comment specific to the added file"
@values -min 3 -max 4
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header"
base -help "base path for entries"
path -type file -help "path of file to add"
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'"
}
# Addentry - was Mkzipfile -- # Addentry - was Mkzipfile --
# #
# FIX ME: should handle the current offset for non-seekable channels # FIX ME: should handle the current offset for non-seekable channels
@ -428,20 +442,7 @@ tcl::namespace::eval punk::zip {
#[para] You can provide a -comment for the file. #[para] You can provide a -comment for the file.
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. #[para] The return value is the central directory record that will need to be used when finalizing the zip archive.
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::Addentry]
@id -id ::punk::zip::Addentry
@cmd -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan'
return a central directory file record"
@opts
-comment -default "" -help "An optional comment specific to the added file"
@values -min 3 -max 4
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header"
base -help "base path for entries"
path -type file -help "path of file to add"
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'"
} $args]
set zipchan [dict get $argd values zipchan] set zipchan [dict get $argd values zipchan]
set base [dict get $argd values base] set base [dict get $argd values base]
set path [dict get $argd values path] set path [dict get $argd values path]
@ -558,10 +559,55 @@ tcl::namespace::eval punk::zip {
# we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) # we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip)
#### ####
punk::args::define {
@id -id ::punk::zip::mkzip
@cmd -name punk::zip::mkzip\
-help "Create a zip archive in 'filename'"
@opts
-offsettype -default "archive" -choices {archive file}\
-help "zip offsets stored relative to start of entire file or relative to start of zip-archive
Only relevant if the created file has a script/runtime prefix.
"
-return -default "pretty" -choices {pretty list none}\
-help "mkzip can return a list of the files and folders added to the archive
the option -return pretty is the default and uses the punk::lib pdict/plist system
to return a formatted list for the terminal
"
-zipkit -default 0 -type none\
-help "whether to add mounting script
mutually exclusive with -runtime option
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs
"
-runtime -default ""\
-help "specify a prefix file
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip
will create a self-extracting zip archive from the subdir/ folder.
Expects runtime with no existing vfs attached (review)
"
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
-help "The new zip archive will scan for contents within this folder or current directory if not provided.
Note that this will
"
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"}
@values -min 1 -max -1
filename -type file -default ""\
-help "name of zipfile to create"
globs -default {*} -multiple 1\
-help "list of glob patterns to match.
Only directories with matching files will be included in the archive."
}
# zip::mkzip -- # zip::mkzip --
# #
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt
# #
proc mkzip {args} { proc mkzip {args} {
#todo - doctools - [arg ?globs...?] syntax? #todo - doctools - [arg ?globs...?] syntax?
@ -581,50 +627,7 @@ tcl::namespace::eval punk::zip {
#[para] If a file already exists, an error will be raised. #[para] If a file already exists, an error will be raised.
#[para] Call 'punk::zip::mkzip' with no arguments for usage display. #[para] Call 'punk::zip::mkzip' with no arguments for usage display.
set argd [punk::args::get_dict { set argd [punk::args::parse $args withid ::punk::zip::mkzip]
@id -id ::punk::zip::mkzip
@cmd -name punk::zip::mkzip\
-help "Create a zip archive in 'filename'"
@opts
-offsettype -default "archive" -choices {archive file}\
-help "zip offsets stored relative to start of entire file or relative to start of zip-archive
Only relevant if the created file has a script/runtime prefix.
"
-return -default "pretty" -choices {pretty list none}\
-help "mkzip can return a list of the files and folders added to the archive
the option -return pretty is the default and uses the punk::lib pdict/plist system
to return a formatted list for the terminal
"
-zipkit -default 0 -type none\
-help "whether to add mounting script
mutually exclusive with -runtime option
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs
"
-runtime -default ""\
-help "specify a prefix file
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip
will create a self-extracting zip archive from the subdir/ folder.
Expects runtime with no existing vfs attached (review)
"
-comment -default ""\
-help "An optional comment for the archive"
-directory -default ""\
-help "The new zip archive will scan for contents within this folder or current directory if not provided.
Note that this will
"
-base -default ""\
-help "The new zip archive will be rooted in this directory if provided
it must be a parent of -directory or the same path as -directory"
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"}
@values -min 1 -max -1
filename -type file -default ""\
-help "name of zipfile to create"
globs -default {*} -multiple 1\
-help "list of glob patterns to match.
Only directories with matching files will be included in the archive."
} $args]
set filename [dict get $argd values filename] set filename [dict get $argd values filename]
if {$filename eq ""} { if {$filename eq ""} {
error "mkzip filename cannot be empty string" error "mkzip filename cannot be empty string"

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

@ -140,16 +140,18 @@ tcl::namespace::eval textblock {
# hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\ # hash_algorithm -optional 1 -choices {${[::textblock::argdoc::hash_algorithm_choices]}} -help\
# "algorithm choice" # "algorithm choice"
namespace eval argdoc {
punk::args::define { set DYN_HASH_ALGORITHM_CHOICES_AND_HELP {$[::textblock::argdoc::hash_algorithm_choices_and_help]}
@dynamic punk::args::define {
@id -id ::textblock::use_hash @dynamic
@cmd -name "textblock::use_hash" -help\ @id -id ::textblock::use_hash
"Hashing algorithm to use for framecache lookup. @cmd -name "textblock::use_hash" -help\
'none' may be slightly faster but less compact "Hashing algorithm to use for framecache lookup.
when viewing textblock::framecache" 'none' may be slightly faster but less compact
@values -min 0 -max 1 when viewing textblock::framecache"
hash_algorithm -optional 1 ${[::textblock::argdoc::hash_algorithm_choices_and_help]} @values -min 0 -max 1
hash_algorithm -optional 1 ${$DYN_HASH_ALGORITHM_CHOICES_AND_HELP}
}
} }
proc use_hash {args} { proc use_hash {args} {
#set argd [punk::args::get_by_id ::textblock::use_hash $args] #set argd [punk::args::get_by_id ::textblock::use_hash $args]
@ -4667,17 +4669,19 @@ tcl::namespace::eval textblock {
-size -type integer\ -size -type integer\
-default 15\ -default 15\
-optional 1\ -optional 1\
-range {1 15} -range {1 ""}
-direction -default horizontal\ -direction -default horizontal\
-choices {horizontal vertical}\ -choices {horizontal vertical}\
-help\ -help\
"When rainbow is in the colour list, "Direction of character increments.
this also affects the direction of When rainbow is in the colour list,
colour changes" the colour stripes will be oriented
@values -min 0 -max 2 in this direction.
"
@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 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
@ -4725,7 +4729,16 @@ tcl::namespace::eval textblock {
set chars [list {*}[punk::lib::range 1 9] A B C D E F] set chars [list {*}[punk::lib::range 1 9] A B C D E F]
set charsubset [lrange $chars 0 $size-1] if {$size <= 15} {
set charsubset [lrange $chars 0 $size-1]
} else {
set numsets [expr {int(ceil($size / 15.0))}]
set longset [concat {*}[lrepeat $numsets $chars]]
set charsubset [lrange $longset 0 $size-1]
set longbows [concat {*}[lrepeat $numsets $rainbow_list]]
set rainbow_list [lrange $longbows 0 $size-1]
}
if {"noreset" in $colour} { if {"noreset" in $colour} {
set RST "" set RST ""
} else { } else {
@ -4760,21 +4773,32 @@ tcl::namespace::eval textblock {
append row $c append row $c
} }
append row $RST append row $RST
append block $row\n append block $row \n
} }
set block [tcl::string::trimright $block \n] set block [tcl::string::trimright $block \n]
return $block return $block
} else { } else {
#row first - if {$direction eq "vertical"} {
set rows [list] #row first -
foreach ch $charsubset { set rows [list]
lappend rows [tcl::string::repeat $ch $size] foreach ch $charsubset {
} lappend rows [tcl::string::repeat $ch $size]
set block [::join $rows \n] }
if {$colour ne ""} { set block [::join $rows \n]
set block [a+ {*}$colour]$block$RST if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
return $block
} else {
set block ""
for {set r 0} {$r < $size} {incr r} {
append block [::join $charsubset ""] \n
}
if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
return $block
} }
return $block
} }
} }
interp alias {} testblock {} textblock::testblock interp alias {} testblock {} textblock::testblock
@ -5500,10 +5524,11 @@ tcl::namespace::eval textblock {
proc ::textblock::join1 {args} { proc ::textblock::join1 {args} {
lassign [punk::args::get_dict { lassign [punk::args::parse $args withdef {
@id -id ::textblock::join1
-ansiresets -default 1 -type integer -ansiresets -default 1 -type integer
blocks -type string -multiple 1 blocks -type string -multiple 1
} $args] _l leaders _o opts _v values }] _l leaders _o opts _v values
set blocks [tcl::dict::get $values blocks] set blocks [tcl::dict::get $values blocks]
set idx 0 set idx 0
@ -5578,11 +5603,12 @@ tcl::namespace::eval textblock {
#@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width. #@cmd -name textblock::join_basic -help "Join blocks line by line but don't add padding on each line to enforce uniform width.
# Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
#" #"
set argd [punk::args::get_dict { set argd [punk::args::parse $args withdef {
@id -id ::textblock::join_basic2
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto -ansiresets -type any -default auto
blocks -type any -multiple 1 blocks -type any -multiple 1
} $args] }]
set ansiresets [tcl::dict::get $argd opts -ansiresets] set ansiresets [tcl::dict::get $argd opts -ansiresets]
set blocks [tcl::dict::get $argd values blocks] set blocks [tcl::dict::get $argd values blocks]
@ -5619,12 +5645,6 @@ tcl::namespace::eval textblock {
#for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed #for joining 'rendered' blocks of plain or ansi text. Being 'rendered' means they are without ansi movement sequences as these have been processed
#they may however still be 'ragged' ie differing line lengths #they may however still be 'ragged' ie differing line lengths
proc ::textblock::join {args} { proc ::textblock::join {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
#we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets #we will support -- at posn 0 and 2 only to allow an optional single option pair for -ansiresets
@ -5709,11 +5729,6 @@ tcl::namespace::eval textblock {
} }
proc ::textblock::join2 {args} { proc ::textblock::join2 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
@ -5801,11 +5816,6 @@ tcl::namespace::eval textblock {
} }
# This calls textblock::pad per cell :/ # This calls textblock::pad per cell :/
proc ::textblock::join3 {args} { proc ::textblock::join3 {args} {
#set argd [punk::args::get_dict {
# blocks -type string -multiple 1
#} $args]
#set opts [tcl::dict::get $argd opts]
#set blocks [tcl::dict::get $argd values blocks]
#-ansireplays is always on (if ansi detected) #-ansireplays is always on (if ansi detected)
@ -5984,7 +5994,7 @@ tcl::namespace::eval textblock {
NOTE: more options available - argument definition NOTE: more options available - argument definition
is incomplete" is incomplete"
@opts @opts
-return -choices {table tableobject} -return -default table -choices {table tableobject}
-rows -type list -default "" -help\ -rows -type list -default "" -help\
"A list of lists. "A list of lists.
Each toplevel element represents a row. Each toplevel element represents a row.
@ -6213,7 +6223,7 @@ tcl::namespace::eval textblock {
-help "restrict to keys matching memberglob." -help "restrict to keys matching memberglob."
}] }]
#append spec \n "frametype -help \"A predefined \"" #append spec \n "frametype -help \"A predefined \""
punk::args::get_dict $spec $args punk::args::parse $args withdef $spec
return return
} }

4
src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl

@ -2044,6 +2044,10 @@ if {[file exists $mapfile]} {
} }
# -- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- ---
puts "-- runtime_vfs_map --" puts "-- runtime_vfs_map --"
set ver [package require punk::args]
puts "punk::args ver: $ver"
set ifneeded [package ifneeded punk::args $ver]
puts "punk::args ifneeded: $ifneeded"
punk::lib::pdict runtime_vfs_map punk::lib::pdict runtime_vfs_map
puts "---------------------" puts "---------------------"
puts "-- vfs_runtime_map--" puts "-- vfs_runtime_map--"

Some files were not shown because too many files have changed in this diff Show More

Loading…
Cancel
Save