Browse Source

punk::args minor performance tweaks, vfs updates for windows

master
Julian Noble 2 months ago
parent
commit
634087e383
  1. 2
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  2. 378
      src/bootsupport/modules/punk/args-0.2.1.tm
  3. 24
      src/bootsupport/modules/punk/console-0.1.1.tm
  4. 5
      src/bootsupport/modules/textblock-0.1.3.tm
  5. 36
      src/modules/#modpod-gridplus-999999.0a1.0/LICENSE.GRIDPLUS
  6. 6873
      src/modules/#modpod-gridplus-999999.0a1.0/gridplus-999999.0a1.0.tm
  7. 22
      src/modules/argparsingtest-999999.0a1.0.tm
  8. 3
      src/modules/gridplus-buildversion.txt
  9. 2
      src/modules/punk/ansi-999999.0a1.0.tm
  10. 378
      src/modules/punk/args-999999.0a1.0.tm
  11. 24
      src/modules/punk/console-999999.0a1.0.tm
  12. 2
      src/modules/punk/imap4-999999.0a1.0.tm
  13. 2
      src/modules/punk/netbox-999999.0a1.0.tm
  14. 2
      src/modules/punk/sixel-999999.0a1.0.tm
  15. 5
      src/modules/textblock-999999.0a1.0.tm
  16. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  17. 384
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm
  18. 3
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
  19. 153
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  20. 30
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  21. 86
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  22. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  23. 384
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm
  24. 3
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/tclcore-0.1.0.tm
  25. 153
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  26. 30
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  27. 86
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  28. BIN
      src/vendormodules_tcl8/Thread-2.8.9.tm
  29. BIN
      src/vendormodules_tcl8/Thread/platform/win32_x86_64_tcl8-2.8.9.tm
  30. 7
      src/vendormodules_tcl8/include_modules.config
  31. 22
      src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm
  32. BIN
      src/vfs/_vfscommon.vfs/modules/gridplus-2.12b0.tm
  33. 2
      src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm
  34. 280
      src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm
  35. 14
      src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm
  36. 153
      src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm
  37. 2
      src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm
  38. 2
      src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm
  39. 30
      src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
  40. 2
      src/vfs/_vfscommon.vfs/modules/punk/sixel-0.1.0.tm
  41. 86
      src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm
  42. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/jpegtclstub.lib
  43. 76
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pkgIndex.tcl
  44. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pngtclstub.lib
  45. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9jpegtcl960.dll
  46. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9pngtcl1648.dll
  47. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tifftcl470.dll
  48. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimg210.dll
  49. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgbmp210.dll
  50. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgdted210.dll
  51. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgflir210.dll
  52. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimggif210.dll
  53. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgico210.dll
  54. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgjpeg210.dll
  55. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpcx210.dll
  56. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpixmap210.dll
  57. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpng210.dll
  58. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgppm210.dll
  59. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgps210.dll
  60. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgraw210.dll
  61. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsgi210.dll
  62. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsun210.dll
  63. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtga210.dll
  64. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtiff210.dll
  65. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgwindow210.dll
  66. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxbm210.dll
  67. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxpm210.dll
  68. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9zlibtcl131.dll
  69. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tifftclstub.lib
  70. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tkimgstub.lib
  71. BIN
      src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/zlibtclstub.lib
  72. 1
      src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/pkgIndex.tcl
  73. BIN
      src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tcl9TclCurl8150.dll
  74. 3151
      src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.html
  75. 143
      src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.tcl
  76. 320
      src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_multi.html
  77. 112
      src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_share.html
  78. 386
      src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/critcl-rt.tcl
  79. 1
      src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/license.terms
  80. 2
      src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/pkgIndex.tcl
  81. 47
      src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/tcl/policy_1.tcl
  82. 17
      src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/teapot.txt
  83. BIN
      src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/win32-x86_64/ankh.dll
  84. 0
      src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/LICENSE
  85. 64
      src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/pkgIndex.tcl
  86. BIN
      src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/win32-x86_64/tcl9cffi203.dll
  87. 67
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclConfig.sh
  88. BIN
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/libitclstub.a
  89. 14
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/pkgIndex.tcl
  90. BIN
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/tcl9itcl432.dll
  91. 0
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itcl.tcl
  92. 0
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclHullCmds.tcl
  93. 0
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclWidget.tcl
  94. BIN
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclstub.lib
  95. 14
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/pkgIndex.tcl
  96. BIN
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/tcl9itcl435.dll
  97. 26
      src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/test_Itcl_CreateObject.tcl
  98. 5
      src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/pkgIndex.tcl
  99. 15
      src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/sqlite3.n
  100. BIN
      src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/tcl9sqlite3510.dll
  101. Some files were not shown because too many files have changed in this diff Show More

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

@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
@values -min 0 -max 0
}]
proc sgr_cache {args} {
set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache]
set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache]
set action [dict get $argd opts -action]
set pretty [dict get $argd opts -pretty]

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

@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef
set defspace ""
if {[dict exists $rawdef_cache_about $args]} {
set cinfo [dict get $rawdef_cache_about $args]
set cinfo [dict get $rawdef_cache_about $args]
set id [dict get $cinfo -id]
set is_dynamic [dict get $cinfo -dynamic]
if {[dict exists $cinfo -defspace]} {
@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args {
#test the rawdef for @dynamic directive
proc rawdef_is_dynamic {rawdef} {
#temporary - old way
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ]
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}]
if {$flagged_dynamic} {
return true
}
@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args {
#puts "-->$cmdinfo"
#puts "-->[tcl::info::frame -3]"
set maxloop 10 ;#failsafe
while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} {
while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} {
#looks like a script - haven't gone up far enough?
#(e.g patternpunk oo system: >punk . poses -invalidoption)
incr call_level -1
@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args {
if {$use_table} {
append errmsg \n
} else {
if {($returntype in {table tableobject}) && !$has_textblock} {
if {!$has_textblock && ($returntype in {table tableobject})} {
append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n
} else {
append errmsg \n
@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args {
variable parse_cache [dict create]
proc parse {args} {
#puts "punk::args::parse --> '$args'"
set tailtype "" ;#withid|withdef
if {[llength $args] < 3} {
#error "punk::args::parse - invalid call. < 3 args"
punk::args::parse $args -cache 1 withid ::punk::args::parse
@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args {
}
}
#set values [lrange $opts_and_vals $i end]
set values $opts_and_vals
#set values $opts_and_vals
#puts "---values: $values"
set tailtype [lindex $values 0]
set tailargs [lrange $values 1 end]
#set split [lsearch -exact $tailargs withid]
#if {$split < 0} {
# set split [lsearch -exact $tailargs withdef]
# if {$split < 0} {
# #punk::args::usage arg_error?
# #error "punk::args::parse - invalid call. keyword withid|withdef required"
# punk::args::parse $args withid ::punk::args::parse
# } else {
# set tailtype withdef
#}
#} else {
# set tailtype withid
#}
#set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here.
#set tailtype [lindex $values 0] ;#withid|withdef
#set tailargs [lrange $values 1 end]
set tailtype [lpop opts_and_vals 0]
#if {[llength $opts] % 2} {
#error "punk::args::parse Even number of -flag val pairs required after arglist"
#}
#Default the -errorstyle to standard
# (slow on unhappy path - but probably clearest for playing with new APIs interactively)
@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args {
}
switch -- $tailtype {
withid {
if {[llength $tailargs] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
set id [lindex $tailargs 0]
#puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts"
#puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts"
set deflist [raw_def $id]
#JJJ
#set id [lindex $opts_and_vals 0]
set deflist [raw_def [lindex $opts_and_vals 0]]
if {[llength $deflist] == 0} {
if {[llength $opts_and_vals] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
error "punk::args::parse - no such id: $id"
}
}
withdef {
set deflist $tailargs
set deflist $opts_and_vals
if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
#puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts"
#puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts"
}
default {
error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'"
@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args {
proc get_dict {deflist rawargs args} {
#see arg_error regarding considerations around unhappy-path performance
if {![punk::args::lib::string_is_dict $args]} {
error "punk::args::get_dict args must be a dict of option value pairs"
}
set defaults [dict create\
-form *\
]
#if {![punk::args::lib::string_is_dict $args]} {
# error "punk::args::get_dict args must be a dict of option value pairs"
#}
set proc_opts [dict merge $defaults $args]
dict for {k v} $proc_opts {
switch -- $k {
@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args {
#define will either return a permanently cached argspecs (-dynamic 0) - or
# use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs.
set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
#argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info
# -----------------------------------------------
# Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc)
tcl::dict::with argspecs {} ;#turn keys into vars
#tcl::dict::with argspecs {} ;#turn keys into vars
#e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names
# -----------------------------------------------
#we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with
set FORMS [dict get $argspecs FORMS]
set form_names [dict get $argspecs form_names]
set opt_form [dict get $proc_opts -form]
if {$opt_form eq "*"} {
set selected_forms $form_names
@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args {
#todo - handle multiple fids?
set fid [lindex $selected_forms 0]
set formdict [dict get $FORMS $fid]
tcl::dict::with formdict {}
#populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
# formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED
# LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED
# LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES
# OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS
# VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS
# VAL_CHECKS_DEFAULTS FORMDISPLAY
#tcl::dict::with formdict {}
##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
#individual var extraction is faster than 'dict with' - even though we need nearly every key
set ARG_INFO [dict get $formdict ARG_INFO]
set ARG_CHECKS [dict get $formdict ARG_CHECKS]
set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS]
set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED]
set LEADER_NAMES [dict get $formdict LEADER_NAMES]
set LEADER_MIN [dict get $formdict LEADER_MIN]
set LEADER_MAX [dict get $formdict LEADER_MAX]
set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO]
set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED]
set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS]
set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS]
set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS]
set OPT_REQUIRED [dict get $formdict OPT_REQUIRED]
set OPT_NAMES [dict get $formdict OPT_NAMES]
set OPT_ANY [dict get $formdict OPT_ANY]
#set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS]
set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS]
set VAL_REQUIRED [dict get $formdict VAL_REQUIRED]
set VAL_NAMES [dict get $formdict VAL_NAMES]
set VAL_MIN [dict get $formdict VAL_MIN]
set VAL_MAX [dict get $formdict VAL_MAX]
set VAL_UNNAMED [dict get $formdict VAL_UNNAMED]
set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS]
set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS]
set FORMDISPLAY [dict get $formdict FORMDISPLAY]
if {$VAL_MIN eq ""} {
set valmin 0
#set VAL_MIN 0
@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args {
# todo variable clause lengths (items marked optional in types using leading&trailing questionmarks)
# e.g -types {a ?xxx?}
#this has one required and one optional
set typelist [dict get $ARG_INFO $v -type]
set clause_length 0
foreach t $typelist {
#for each t in typelist
foreach t [dict get $ARG_INFO $v -type] {
if {![string match {\?*\?} $t]} {
incr clause_length
}
@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args {
#REVIEW - what about optional members in leaders e.g -type {int ?double?}
set named_leader_args_max 0
foreach ln $LEADER_NAMES {
set typelist [dict get $ARG_INFO $ln -type]
incr named_leader_args_max [llength $typelist]
incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]]
}
#set id [dict get $argspecs id]
@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args {
#}
set can_have_leaders 1 ;#default assumption
if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} {
if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} {
set can_have_leaders 0
}
@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args {
if {$OPT_MAX ne "0"} {
foreach t $leader_type {
set raw [lindex $rawargs $tentative_idx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set flagname $raw
if {[string match --* $raw]} {
@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args {
# and only for the last defined leader. This should be done in the definition parsing - not here.
foreach t $leader_type {
set raw [lindex $rawargs $ridx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set matchopt [::tcl::prefix::match -error {} $all_opts $raw]
@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args {
set leadermin $LEADER_MIN
}
if {$LEADER_MAX eq ""} {
if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} {
if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} {
set leadermax 0
} else {
set leadermax -1
@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args {
}
if {$VAL_MAX eq ""} {
if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} {
if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} {
set valmax 0
} else {
set valmax -1
@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args {
#assert leadermax leadermin are numeric
#assert - remaining_rawargs has been reduced by leading positionals
set opts [dict create] ;#don't set to OPT_DEFAULTS here
#beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true)
#set opts [dict create] ;#don't set to OPT_DEFAULTS here
set opts [list]
set leaders [list]
set arglist {}
@ -7982,7 +8011,7 @@ tcl::namespace::eval punk::args {
#valmin, valmax
#puts stderr "remaining_rawargs: $remaining_rawargs"
#puts stderr "argstate: $argstate"
if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} {
if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] > -1} {
#contains at least one possible flag
set maxidx [expr {[llength $remaining_rawargs] -1}]
if {$valmax == -1} {
@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args {
break
}
set a [lindex $remaining_rawargs $i]
switch -glob -- $a {
-- {
if {$a in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
}
--* {
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
set a1 [string index $a 0]
set a2 [string index $a 1]
if {$a1 eq "-"} {
if {$a2 eq "-"} {
if {$a eq "--"} {
if {"--" in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
#--*
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
}
}
}
-* {
} else {
#-*
set flagsupplied $a
set flagval ""
set flagval_included false
}
default {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
} else {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#switch -glob -- $a {
# -- {
# }
# --* {
# }
# -* {
# }
# default {
# }
#}
#flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
@ -8212,7 +8254,7 @@ tcl::namespace::eval punk::args {
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
@ -8277,7 +8319,7 @@ tcl::namespace::eval punk::args {
#exlude argument with whitespace from being a possible option e.g dict
#todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value
set eposn [string first = $a]
if {[string match --* $a] && $eposn > 2} {
if {$eposn > 2 && [string match --* $a]} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#undefined_flagsupplied may still be a 'short form/prefix'
@ -8374,6 +8416,8 @@ tcl::namespace::eval punk::args {
#set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected
set arglist [list]
}
#set id [dict get $argspecs id]
#if {$id eq "::if"} {
#puts stderr "::if"
@ -8408,7 +8452,7 @@ tcl::namespace::eval punk::args {
# }
#}
#puts ">>>>==== $opts"
#puts ">>>>====opts: $opts"
set seen_pks [list]
#treating opts as list for this loop.
foreach optset $OPT_NAMES {
@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $leadername -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $leadername -optional]} {
puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)"
#return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?"
incr ldridx -1
set leadername_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$leadername ni $leadernames_received} {
#puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES"
set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)."
@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could use break?
continue
}
if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} {
if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset leaders_dict $leadername
@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $valname -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $valname -optional]} {
#error 333
puts stderr "get_dict cannot assign val:$val to valname:$valname (333)"
incr validx -1
set valname_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$valname ni $valnames_received} {
#puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES"
set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)."
@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could break?
continue
}
if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} {
if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset values_dict $vname
@ -8923,6 +8963,11 @@ tcl::namespace::eval punk::args {
#puts " >>>>>>> ---lookup_optset :$lookup_optset"
#puts "---argstate:$argstate"
#JJJ argname_or_ident; ident example: -increasing|-SORTOPTION
#review - ensure all possible keys present in thisarg_keys
set pkoverride [Dict_getdef $argstate -parsekey ""]
tcl::dict::for {argname_or_ident value_group} $opts_and_values {
#
#parsekey: key used in resulting leaders opts values dictionaries
@ -8944,7 +8989,7 @@ tcl::namespace::eval punk::args {
#get full option name such as -fg|-foreground from non-alias name such as -foreground
#if "@opts -any|-arbitrary true" - we may have an option that wasn't defined
set argname [dict get $lookup_optset $argname_or_ident]
set pkoverride [Dict_getdef $argstate -parsekey ""]
#set pkoverride [Dict_getdef $argstate -parsekey ""]
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
@ -8957,7 +9002,7 @@ tcl::namespace::eval punk::args {
}
} else {
set argname $argname_or_ident
set pkoverride [Dict_getdef $argstate -parsekey ""]
#set pkoverride [Dict_getdef $argstate -parsekey ""]
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
@ -8972,21 +9017,24 @@ tcl::namespace::eval punk::args {
#an example argname_or_compound for the above might be: -path|--filename
# where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey
set thisarg_checks [tcl::dict::get $arg_checks $argname]
set thisarg [tcl::dict::get $argstate $argname]
#set thisarg_keys [tcl::dict::keys $thisarg]
set thisarg_checks [tcl::dict::get $arg_checks $argname]
#using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict
set typelist [tcl::dict::get $thisarg -type]
set is_multiple [tcl::dict::get $thisarg -multiple]
set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi]
set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped]
set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi]
#set validationtransform [tcl::dict::get $thisarg -validationtransform]
set has_default [tcl::dict::exists $thisarg -default]
if {$has_default} {
set defaultval [tcl::dict::get $thisarg -default]
}
set typelist [tcl::dict::get $thisarg -type]
set clause_size [llength $typelist]
set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}]
set validationtransform [tcl::dict::get $thisarg -validationtransform]
#JJJJ
@ -9036,7 +9084,7 @@ tcl::namespace::eval punk::args {
set vlist_original $vlist ;#retain for possible final strip_ansi
#review - validationtransform
if {$is_validate_ansistripped} {
if {[llength $vlist] && $is_validate_ansistripped} {
#validate_ansistripped 1
package require punk::ansi
set vlist_check [list]
@ -9076,7 +9124,7 @@ tcl::namespace::eval punk::args {
set vlist_typelist_validate [list]
#reduce our validation requirements by removing values which match defaultval or match -choices
#(could be -multiple with -choicerestricted 0 where some selections match and others don't)
if {$parsekey in $receivednames && $has_choices} {
if {$has_choices && $parsekey in $receivednames} {
#-choices must also work with -multiple
#todo -choicelabels
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
@ -9333,13 +9381,13 @@ tcl::namespace::eval punk::args {
set vlist [list]
set vlist_check_validate [list]
} else {
if {[llength $vlist] && $has_default} {
if {$has_default && [llength $vlist]} {
#defaultval here is a value for the entire clause. (clause usually length 1)
#J2
#set vlist_validate [list]
#set vlist_check_validate [list]
set tp [dict get $thisarg -type]
set clause_size [llength $tp]
#set tp [dict get $thisarg -type]
set clause_size [llength $typelist]
foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist {
#JJJJ
#REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation?
@ -9386,34 +9434,34 @@ tcl::namespace::eval punk::args {
}
}
#is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups
#assert: our vlist & vlist_check lists have been reduced to remove those
if {[llength $vlist] && !$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach clause_value $vlist {
foreach e $clause_value {
if {[punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg
if {[llength $vlist]} {
#is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups
#assert: our vlist & vlist_check lists have been reduced to remove those
if {!$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach clause_value $vlist {
foreach e $clause_value {
if {[punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg
}
}
}
}
}
#puts "argname:$argname v:$v is_default:$is_default"
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
#arguments that are at their default are not subject to type and other checks
#puts "argname:$argname v:$v is_default:$is_default"
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
#arguments that are at their default are not subject to type and other checks
#don't validate defaults or choices that matched
#puts "---> opts_and_values: $opts_and_values"
#puts "===> argname: $argname is_default: $is_default is_choice: $is_choice"
#if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {}
#don't validate defaults or choices that matched
#puts "---> opts_and_values: $opts_and_values"
#puts "===> argname: $argname is_default: $is_default is_choice: $is_choice"
#if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {}
#our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups
#assert [llength $vlist] == [llength $vlist_check]
if {[llength $vlist]} {
#our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups
#assert [llength $vlist] == [llength $vlist_check]
#$t = clause column
#for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {}
@ -9447,37 +9495,37 @@ tcl::namespace::eval punk::args {
}
}
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {[tcl::dict::get $thisarg -multiple]} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list
}
option {
tcl::dict::set opts $argname_or_ident $stripped_list
}
value {
tcl::dict::set values_dict $argname_or_ident $stripped_list
}
}
} else {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0]
}
option {
tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0]
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {$is_multiple} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list
}
option {
tcl::dict::set opts $argname_or_ident $stripped_list
}
value {
tcl::dict::set values_dict $argname_or_ident $stripped_list
}
}
value {
tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0]
} else {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0]
}
option {
tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0]
}
value {
tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0]
}
}
}
}
}
}
set finalopts [dict create]

24
src/bootsupport/modules/punk/console-0.1.1.tm

@ -1329,7 +1329,7 @@ namespace eval punk::console {
"Omit or pass empty string to query current echo state."
}]
proc echo {args} {
set argd [punk::args::parse $args withid ::punk::console::local::echo]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo]
set onoff [dict get $argd values onoff]
set is_windows [string equal "windows" $::tcl_platform(platform)]
@ -1835,7 +1835,7 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc dec_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -1881,7 +1881,7 @@ namespace eval punk::console {
}
#todo - should accept multiple mode nums/names at once
proc dec_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1927,7 +1927,7 @@ namespace eval punk::console {
}]
}
proc dec_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1990,7 +1990,7 @@ namespace eval punk::console {
}]
}
proc dec_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -2061,7 +2061,7 @@ namespace eval punk::console {
"Match code or name"
}]
proc dec_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -2241,7 +2241,7 @@ namespace eval punk::console {
}]
}
proc ansi_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set num_or_name [dict get $values mode]
@ -2314,7 +2314,7 @@ namespace eval punk::console {
}]
}
proc ansi_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2361,7 +2361,7 @@ namespace eval punk::console {
}]
}
proc ansi_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2427,7 +2427,7 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc ansi_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -2469,7 +2469,7 @@ namespace eval punk::console {
"Match code or name"
}]
proc ansi_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -2716,7 +2716,7 @@ namespace eval punk::console {
name -type string
}]
proc dec_request_setting {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_request_setting]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting]
lassign [dict values $argd] leaders opts values
set console [dict get $opts -console]
set name [dict get $values name]

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

@ -4815,7 +4815,7 @@ tcl::namespace::eval textblock {
123456789ABCDEF
"
-size -type integer\
-default 15\
-default 16\
-optional 1\
-range {1 ""}
-direction -default horizontal\
@ -4946,6 +4946,7 @@ tcl::namespace::eval textblock {
for {set r 0} {$r < $size} {incr r} {
append block [::join $charsubset ""] \n
}
set block [tcl::string::trimright $block \n]
if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
@ -7843,7 +7844,7 @@ tcl::namespace::eval textblock {
}
}
proc frame_cache {args} {
set argd [punk::args::parse $args withid ::textblock::frame_cache]
set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache]
set action [dict get $argd values action]
variable frame_cache
set all_values_dict [dict get $argd values]

36
src/modules/#modpod-gridplus-999999.0a1.0/LICENSE.GRIDPLUS

@ -0,0 +1,36 @@
This software (GRIDPLUS) is Copyright (c) 2004-2015 by Adrian Davis (adrian@satisoft.com).
The author hereby grants permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that
this notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file
where they apply.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY
OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS,
OR MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense,
the software shall be classified as "Commercial Computer Software"
and the Government shall have only "Restricted Rights" as defined in
Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing,
the authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.

6873
src/modules/#modpod-gridplus-999999.0a1.0/gridplus-999999.0a1.0.tm

File diff suppressed because it is too large Load Diff

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

@ -296,6 +296,27 @@ namespace eval argparsingtest {
return [tcl::dict::get $argd opts]
}
proc test1_punkargs_any {args} {
set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs
@cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0
-return -default string -type any
-frametype -default \uFFEF -type any
-show_edge -default \uFFEF -type any
-show_seps -default \uFFEF -type any
-join -type none -multiple 1
-x -default "" -type any
-y -default b -type any
-z -default c -type any
-1 -default 1 -type boolean
-2 -default 2 -type integer
-3 -default 3 -type integer
@values
}]
return [tcl::dict::get $argd opts]
}
punk::args::define {
@id -id ::argparsingtest::test1_punkargs_by_id
@cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@ -318,7 +339,6 @@ namespace eval argparsingtest {
return [tcl::dict::get $argd opts]
}
}
proc test1_punkargs_parsecache {args} {
set argd [punk::args::parse $args -cache 1 withid ::argparsingtest::test1_punkargs_by_id]
return [tcl::dict::get $argd opts]

3
src/modules/gridplus-buildversion.txt

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

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

@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
@values -min 0 -max 0
}]
proc sgr_cache {args} {
set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache]
set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache]
set action [dict get $argd opts -action]
set pretty [dict get $argd opts -pretty]

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

@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef
set defspace ""
if {[dict exists $rawdef_cache_about $args]} {
set cinfo [dict get $rawdef_cache_about $args]
set cinfo [dict get $rawdef_cache_about $args]
set id [dict get $cinfo -id]
set is_dynamic [dict get $cinfo -dynamic]
if {[dict exists $cinfo -defspace]} {
@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args {
#test the rawdef for @dynamic directive
proc rawdef_is_dynamic {rawdef} {
#temporary - old way
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ]
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}]
if {$flagged_dynamic} {
return true
}
@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args {
#puts "-->$cmdinfo"
#puts "-->[tcl::info::frame -3]"
set maxloop 10 ;#failsafe
while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} {
while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} {
#looks like a script - haven't gone up far enough?
#(e.g patternpunk oo system: >punk . poses -invalidoption)
incr call_level -1
@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args {
if {$use_table} {
append errmsg \n
} else {
if {($returntype in {table tableobject}) && !$has_textblock} {
if {!$has_textblock && ($returntype in {table tableobject})} {
append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n
} else {
append errmsg \n
@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args {
variable parse_cache [dict create]
proc parse {args} {
#puts "punk::args::parse --> '$args'"
set tailtype "" ;#withid|withdef
if {[llength $args] < 3} {
#error "punk::args::parse - invalid call. < 3 args"
punk::args::parse $args -cache 1 withid ::punk::args::parse
@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args {
}
}
#set values [lrange $opts_and_vals $i end]
set values $opts_and_vals
#set values $opts_and_vals
#puts "---values: $values"
set tailtype [lindex $values 0]
set tailargs [lrange $values 1 end]
#set split [lsearch -exact $tailargs withid]
#if {$split < 0} {
# set split [lsearch -exact $tailargs withdef]
# if {$split < 0} {
# #punk::args::usage arg_error?
# #error "punk::args::parse - invalid call. keyword withid|withdef required"
# punk::args::parse $args withid ::punk::args::parse
# } else {
# set tailtype withdef
#}
#} else {
# set tailtype withid
#}
#set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here.
#set tailtype [lindex $values 0] ;#withid|withdef
#set tailargs [lrange $values 1 end]
set tailtype [lpop opts_and_vals 0]
#if {[llength $opts] % 2} {
#error "punk::args::parse Even number of -flag val pairs required after arglist"
#}
#Default the -errorstyle to standard
# (slow on unhappy path - but probably clearest for playing with new APIs interactively)
@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args {
}
switch -- $tailtype {
withid {
if {[llength $tailargs] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
set id [lindex $tailargs 0]
#puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts"
#puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts"
set deflist [raw_def $id]
#JJJ
#set id [lindex $opts_and_vals 0]
set deflist [raw_def [lindex $opts_and_vals 0]]
if {[llength $deflist] == 0} {
if {[llength $opts_and_vals] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
error "punk::args::parse - no such id: $id"
}
}
withdef {
set deflist $tailargs
set deflist $opts_and_vals
if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
#puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts"
#puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts"
}
default {
error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'"
@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args {
proc get_dict {deflist rawargs args} {
#see arg_error regarding considerations around unhappy-path performance
if {![punk::args::lib::string_is_dict $args]} {
error "punk::args::get_dict args must be a dict of option value pairs"
}
set defaults [dict create\
-form *\
]
#if {![punk::args::lib::string_is_dict $args]} {
# error "punk::args::get_dict args must be a dict of option value pairs"
#}
set proc_opts [dict merge $defaults $args]
dict for {k v} $proc_opts {
switch -- $k {
@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args {
#define will either return a permanently cached argspecs (-dynamic 0) - or
# use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs.
set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
#argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info
# -----------------------------------------------
# Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc)
tcl::dict::with argspecs {} ;#turn keys into vars
#tcl::dict::with argspecs {} ;#turn keys into vars
#e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names
# -----------------------------------------------
#we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with
set FORMS [dict get $argspecs FORMS]
set form_names [dict get $argspecs form_names]
set opt_form [dict get $proc_opts -form]
if {$opt_form eq "*"} {
set selected_forms $form_names
@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args {
#todo - handle multiple fids?
set fid [lindex $selected_forms 0]
set formdict [dict get $FORMS $fid]
tcl::dict::with formdict {}
#populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
# formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED
# LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED
# LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES
# OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS
# VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS
# VAL_CHECKS_DEFAULTS FORMDISPLAY
#tcl::dict::with formdict {}
##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
#individual var extraction is faster than 'dict with' - even though we need nearly every key
set ARG_INFO [dict get $formdict ARG_INFO]
set ARG_CHECKS [dict get $formdict ARG_CHECKS]
set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS]
set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED]
set LEADER_NAMES [dict get $formdict LEADER_NAMES]
set LEADER_MIN [dict get $formdict LEADER_MIN]
set LEADER_MAX [dict get $formdict LEADER_MAX]
set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO]
set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED]
set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS]
set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS]
set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS]
set OPT_REQUIRED [dict get $formdict OPT_REQUIRED]
set OPT_NAMES [dict get $formdict OPT_NAMES]
set OPT_ANY [dict get $formdict OPT_ANY]
#set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS]
set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS]
set VAL_REQUIRED [dict get $formdict VAL_REQUIRED]
set VAL_NAMES [dict get $formdict VAL_NAMES]
set VAL_MIN [dict get $formdict VAL_MIN]
set VAL_MAX [dict get $formdict VAL_MAX]
set VAL_UNNAMED [dict get $formdict VAL_UNNAMED]
set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS]
set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS]
set FORMDISPLAY [dict get $formdict FORMDISPLAY]
if {$VAL_MIN eq ""} {
set valmin 0
#set VAL_MIN 0
@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args {
# todo variable clause lengths (items marked optional in types using leading&trailing questionmarks)
# e.g -types {a ?xxx?}
#this has one required and one optional
set typelist [dict get $ARG_INFO $v -type]
set clause_length 0
foreach t $typelist {
#for each t in typelist
foreach t [dict get $ARG_INFO $v -type] {
if {![string match {\?*\?} $t]} {
incr clause_length
}
@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args {
#REVIEW - what about optional members in leaders e.g -type {int ?double?}
set named_leader_args_max 0
foreach ln $LEADER_NAMES {
set typelist [dict get $ARG_INFO $ln -type]
incr named_leader_args_max [llength $typelist]
incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]]
}
#set id [dict get $argspecs id]
@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args {
#}
set can_have_leaders 1 ;#default assumption
if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} {
if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} {
set can_have_leaders 0
}
@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args {
if {$OPT_MAX ne "0"} {
foreach t $leader_type {
set raw [lindex $rawargs $tentative_idx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set flagname $raw
if {[string match --* $raw]} {
@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args {
# and only for the last defined leader. This should be done in the definition parsing - not here.
foreach t $leader_type {
set raw [lindex $rawargs $ridx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set matchopt [::tcl::prefix::match -error {} $all_opts $raw]
@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args {
set leadermin $LEADER_MIN
}
if {$LEADER_MAX eq ""} {
if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} {
if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} {
set leadermax 0
} else {
set leadermax -1
@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args {
}
if {$VAL_MAX eq ""} {
if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} {
if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} {
set valmax 0
} else {
set valmax -1
@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args {
#assert leadermax leadermin are numeric
#assert - remaining_rawargs has been reduced by leading positionals
set opts [dict create] ;#don't set to OPT_DEFAULTS here
#beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true)
#set opts [dict create] ;#don't set to OPT_DEFAULTS here
set opts [list]
set leaders [list]
set arglist {}
@ -7982,7 +8011,7 @@ tcl::namespace::eval punk::args {
#valmin, valmax
#puts stderr "remaining_rawargs: $remaining_rawargs"
#puts stderr "argstate: $argstate"
if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} {
if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] > -1} {
#contains at least one possible flag
set maxidx [expr {[llength $remaining_rawargs] -1}]
if {$valmax == -1} {
@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args {
break
}
set a [lindex $remaining_rawargs $i]
switch -glob -- $a {
-- {
if {$a in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
}
--* {
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
set a1 [string index $a 0]
set a2 [string index $a 1]
if {$a1 eq "-"} {
if {$a2 eq "-"} {
if {$a eq "--"} {
if {"--" in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
#--*
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
}
}
}
-* {
} else {
#-*
set flagsupplied $a
set flagval ""
set flagval_included false
}
default {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
} else {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#switch -glob -- $a {
# -- {
# }
# --* {
# }
# -* {
# }
# default {
# }
#}
#flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
@ -8212,7 +8254,7 @@ tcl::namespace::eval punk::args {
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
@ -8277,7 +8319,7 @@ tcl::namespace::eval punk::args {
#exlude argument with whitespace from being a possible option e.g dict
#todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value
set eposn [string first = $a]
if {[string match --* $a] && $eposn > 2} {
if {$eposn > 2 && [string match --* $a]} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#undefined_flagsupplied may still be a 'short form/prefix'
@ -8374,6 +8416,8 @@ tcl::namespace::eval punk::args {
#set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected
set arglist [list]
}
#set id [dict get $argspecs id]
#if {$id eq "::if"} {
#puts stderr "::if"
@ -8408,7 +8452,7 @@ tcl::namespace::eval punk::args {
# }
#}
#puts ">>>>==== $opts"
#puts ">>>>====opts: $opts"
set seen_pks [list]
#treating opts as list for this loop.
foreach optset $OPT_NAMES {
@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $leadername -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $leadername -optional]} {
puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)"
#return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?"
incr ldridx -1
set leadername_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$leadername ni $leadernames_received} {
#puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES"
set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)."
@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could use break?
continue
}
if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} {
if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset leaders_dict $leadername
@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $valname -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $valname -optional]} {
#error 333
puts stderr "get_dict cannot assign val:$val to valname:$valname (333)"
incr validx -1
set valname_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$valname ni $valnames_received} {
#puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES"
set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)."
@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could break?
continue
}
if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} {
if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset values_dict $vname
@ -8923,6 +8963,11 @@ tcl::namespace::eval punk::args {
#puts " >>>>>>> ---lookup_optset :$lookup_optset"
#puts "---argstate:$argstate"
#JJJ argname_or_ident; ident example: -increasing|-SORTOPTION
#review - ensure all possible keys present in thisarg_keys
set pkoverride [Dict_getdef $argstate -parsekey ""]
tcl::dict::for {argname_or_ident value_group} $opts_and_values {
#
#parsekey: key used in resulting leaders opts values dictionaries
@ -8944,7 +8989,7 @@ tcl::namespace::eval punk::args {
#get full option name such as -fg|-foreground from non-alias name such as -foreground
#if "@opts -any|-arbitrary true" - we may have an option that wasn't defined
set argname [dict get $lookup_optset $argname_or_ident]
set pkoverride [Dict_getdef $argstate -parsekey ""]
#set pkoverride [Dict_getdef $argstate -parsekey ""]
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
@ -8957,7 +9002,7 @@ tcl::namespace::eval punk::args {
}
} else {
set argname $argname_or_ident
set pkoverride [Dict_getdef $argstate -parsekey ""]
#set pkoverride [Dict_getdef $argstate -parsekey ""]
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
@ -8972,21 +9017,24 @@ tcl::namespace::eval punk::args {
#an example argname_or_compound for the above might be: -path|--filename
# where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey
set thisarg_checks [tcl::dict::get $arg_checks $argname]
set thisarg [tcl::dict::get $argstate $argname]
#set thisarg_keys [tcl::dict::keys $thisarg]
set thisarg_checks [tcl::dict::get $arg_checks $argname]
#using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict
set typelist [tcl::dict::get $thisarg -type]
set is_multiple [tcl::dict::get $thisarg -multiple]
set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi]
set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped]
set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi]
#set validationtransform [tcl::dict::get $thisarg -validationtransform]
set has_default [tcl::dict::exists $thisarg -default]
if {$has_default} {
set defaultval [tcl::dict::get $thisarg -default]
}
set typelist [tcl::dict::get $thisarg -type]
set clause_size [llength $typelist]
set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}]
set validationtransform [tcl::dict::get $thisarg -validationtransform]
#JJJJ
@ -9036,7 +9084,7 @@ tcl::namespace::eval punk::args {
set vlist_original $vlist ;#retain for possible final strip_ansi
#review - validationtransform
if {$is_validate_ansistripped} {
if {[llength $vlist] && $is_validate_ansistripped} {
#validate_ansistripped 1
package require punk::ansi
set vlist_check [list]
@ -9076,7 +9124,7 @@ tcl::namespace::eval punk::args {
set vlist_typelist_validate [list]
#reduce our validation requirements by removing values which match defaultval or match -choices
#(could be -multiple with -choicerestricted 0 where some selections match and others don't)
if {$parsekey in $receivednames && $has_choices} {
if {$has_choices && $parsekey in $receivednames} {
#-choices must also work with -multiple
#todo -choicelabels
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
@ -9333,13 +9381,13 @@ tcl::namespace::eval punk::args {
set vlist [list]
set vlist_check_validate [list]
} else {
if {[llength $vlist] && $has_default} {
if {$has_default && [llength $vlist]} {
#defaultval here is a value for the entire clause. (clause usually length 1)
#J2
#set vlist_validate [list]
#set vlist_check_validate [list]
set tp [dict get $thisarg -type]
set clause_size [llength $tp]
#set tp [dict get $thisarg -type]
set clause_size [llength $typelist]
foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist {
#JJJJ
#REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation?
@ -9386,34 +9434,34 @@ tcl::namespace::eval punk::args {
}
}
#is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups
#assert: our vlist & vlist_check lists have been reduced to remove those
if {[llength $vlist] && !$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach clause_value $vlist {
foreach e $clause_value {
if {[punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg
if {[llength $vlist]} {
#is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups
#assert: our vlist & vlist_check lists have been reduced to remove those
if {!$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach clause_value $vlist {
foreach e $clause_value {
if {[punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg
}
}
}
}
}
#puts "argname:$argname v:$v is_default:$is_default"
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
#arguments that are at their default are not subject to type and other checks
#puts "argname:$argname v:$v is_default:$is_default"
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
#arguments that are at their default are not subject to type and other checks
#don't validate defaults or choices that matched
#puts "---> opts_and_values: $opts_and_values"
#puts "===> argname: $argname is_default: $is_default is_choice: $is_choice"
#if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {}
#don't validate defaults or choices that matched
#puts "---> opts_and_values: $opts_and_values"
#puts "===> argname: $argname is_default: $is_default is_choice: $is_choice"
#if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {}
#our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups
#assert [llength $vlist] == [llength $vlist_check]
if {[llength $vlist]} {
#our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups
#assert [llength $vlist] == [llength $vlist_check]
#$t = clause column
#for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {}
@ -9447,37 +9495,37 @@ tcl::namespace::eval punk::args {
}
}
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {[tcl::dict::get $thisarg -multiple]} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list
}
option {
tcl::dict::set opts $argname_or_ident $stripped_list
}
value {
tcl::dict::set values_dict $argname_or_ident $stripped_list
}
}
} else {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0]
}
option {
tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0]
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {$is_multiple} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list
}
option {
tcl::dict::set opts $argname_or_ident $stripped_list
}
value {
tcl::dict::set values_dict $argname_or_ident $stripped_list
}
}
value {
tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0]
} else {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0]
}
option {
tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0]
}
value {
tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0]
}
}
}
}
}
}
set finalopts [dict create]

24
src/modules/punk/console-999999.0a1.0.tm

@ -1329,7 +1329,7 @@ namespace eval punk::console {
"Omit or pass empty string to query current echo state."
}]
proc echo {args} {
set argd [punk::args::parse $args withid ::punk::console::local::echo]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo]
set onoff [dict get $argd values onoff]
set is_windows [string equal "windows" $::tcl_platform(platform)]
@ -1835,7 +1835,7 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc dec_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -1881,7 +1881,7 @@ namespace eval punk::console {
}
#todo - should accept multiple mode nums/names at once
proc dec_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1927,7 +1927,7 @@ namespace eval punk::console {
}]
}
proc dec_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1990,7 +1990,7 @@ namespace eval punk::console {
}]
}
proc dec_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -2061,7 +2061,7 @@ namespace eval punk::console {
"Match code or name"
}]
proc dec_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -2241,7 +2241,7 @@ namespace eval punk::console {
}]
}
proc ansi_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set num_or_name [dict get $values mode]
@ -2314,7 +2314,7 @@ namespace eval punk::console {
}]
}
proc ansi_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2361,7 +2361,7 @@ namespace eval punk::console {
}]
}
proc ansi_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2427,7 +2427,7 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc ansi_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -2469,7 +2469,7 @@ namespace eval punk::console {
"Match code or name"
}]
proc ansi_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
@ -2716,7 +2716,7 @@ namespace eval punk::console {
name -type string
}]
proc dec_request_setting {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_request_setting]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting]
lassign [dict values $argd] leaders opts values
set console [dict get $opts -console]
set name [dict get $values name]

2
src/modules/punk/imap4-999999.0a1.0.tm

@ -2750,7 +2750,7 @@ tcl::namespace::eval punk::imap4 {
@values -min 0 -max 0
}]
proc NOOP {args} {
set argd [punk::args::parse $args withid ::punk::imap4::NOOP]
set argd [punk::args::parse $args -cache 1 withid ::punk::imap4::NOOP]
set chan [dict get $argd leaders chan]
punk::imap4::proto::simplecmd $chan NOOP
}

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

@ -1363,7 +1363,7 @@ tcl::namespace::eval punk::netbox {
@values -min 0 -max 0
}]
proc _datafile {args} {
set argd [punk::args::parse $args withid ::punk::netbox::_datafile]
set argd [punk::args::parse $args -cache 1 withid ::punk::netbox::_datafile]
lassign [dict values $argd] leaders opts values received
set be_quiet [dict exists $received -quiet]

2
src/modules/punk/sixel-999999.0a1.0.tm

@ -240,7 +240,7 @@ tcl::namespace::eval punk::sixel {
variable device_attribute_cache
set device_attribute_cache [dict create]
proc can_sixel {args} {
set argd [punk::args::parse $args withid ::punk::sixel::can_sixel]
set argd [punk::args::parse $args -cache 1 withid ::punk::sixel::can_sixel]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $values terminal]

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

@ -4815,7 +4815,7 @@ tcl::namespace::eval textblock {
123456789ABCDEF
"
-size -type integer\
-default 15\
-default 16\
-optional 1\
-range {1 ""}
-direction -default horizontal\
@ -4946,6 +4946,7 @@ tcl::namespace::eval textblock {
for {set r 0} {$r < $size} {incr r} {
append block [::join $charsubset ""] \n
}
set block [tcl::string::trimright $block \n]
if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
@ -7843,7 +7844,7 @@ tcl::namespace::eval textblock {
}
}
proc frame_cache {args} {
set argd [punk::args::parse $args withid ::textblock::frame_cache]
set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache]
set action [dict get $argd values action]
variable frame_cache
set all_values_dict [dict get $argd values]

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

@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
@values -min 0 -max 0
}]
proc sgr_cache {args} {
set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache]
set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache]
set action [dict get $argd opts -action]
set pretty [dict get $argd opts -pretty]

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

@ -373,9 +373,9 @@ tcl::namespace::eval ::punk::args::helpers {
#Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between
# the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems.
set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {^\{|[^\\](\{+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {[^\\](\}+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-olive} {\[|\]} $str]
#puts stderr -------------------
#puts $str
#puts stderr -------------------
@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef
set defspace ""
if {[dict exists $rawdef_cache_about $args]} {
set cinfo [dict get $rawdef_cache_about $args]
set cinfo [dict get $rawdef_cache_about $args]
set id [dict get $cinfo -id]
set is_dynamic [dict get $cinfo -dynamic]
if {[dict exists $cinfo -defspace]} {
@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args {
#test the rawdef for @dynamic directive
proc rawdef_is_dynamic {rawdef} {
#temporary - old way
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ]
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}]
if {$flagged_dynamic} {
return true
}
@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args {
#puts "-->$cmdinfo"
#puts "-->[tcl::info::frame -3]"
set maxloop 10 ;#failsafe
while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} {
while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} {
#looks like a script - haven't gone up far enough?
#(e.g patternpunk oo system: >punk . poses -invalidoption)
incr call_level -1
@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args {
if {$use_table} {
append errmsg \n
} else {
if {($returntype in {table tableobject}) && !$has_textblock} {
if {!$has_textblock && ($returntype in {table tableobject})} {
append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n
} else {
append errmsg \n
@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args {
variable parse_cache [dict create]
proc parse {args} {
#puts "punk::args::parse --> '$args'"
set tailtype "" ;#withid|withdef
if {[llength $args] < 3} {
#error "punk::args::parse - invalid call. < 3 args"
punk::args::parse $args -cache 1 withid ::punk::args::parse
@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args {
}
}
#set values [lrange $opts_and_vals $i end]
set values $opts_and_vals
#set values $opts_and_vals
#puts "---values: $values"
set tailtype [lindex $values 0]
set tailargs [lrange $values 1 end]
#set split [lsearch -exact $tailargs withid]
#if {$split < 0} {
# set split [lsearch -exact $tailargs withdef]
# if {$split < 0} {
# #punk::args::usage arg_error?
# #error "punk::args::parse - invalid call. keyword withid|withdef required"
# punk::args::parse $args withid ::punk::args::parse
# } else {
# set tailtype withdef
#}
#} else {
# set tailtype withid
#}
#set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here.
#set tailtype [lindex $values 0] ;#withid|withdef
#set tailargs [lrange $values 1 end]
set tailtype [lpop opts_and_vals 0]
#if {[llength $opts] % 2} {
#error "punk::args::parse Even number of -flag val pairs required after arglist"
#}
#Default the -errorstyle to standard
# (slow on unhappy path - but probably clearest for playing with new APIs interactively)
@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args {
}
switch -- $tailtype {
withid {
if {[llength $tailargs] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
set id [lindex $tailargs 0]
#puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts"
#puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts"
set deflist [raw_def $id]
#JJJ
#set id [lindex $opts_and_vals 0]
set deflist [raw_def [lindex $opts_and_vals 0]]
if {[llength $deflist] == 0} {
if {[llength $opts_and_vals] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
error "punk::args::parse - no such id: $id"
}
}
withdef {
set deflist $tailargs
set deflist $opts_and_vals
if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
#puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts"
#puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts"
}
default {
error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'"
@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args {
proc get_dict {deflist rawargs args} {
#see arg_error regarding considerations around unhappy-path performance
if {![punk::args::lib::string_is_dict $args]} {
error "punk::args::get_dict args must be a dict of option value pairs"
}
set defaults [dict create\
-form *\
]
#if {![punk::args::lib::string_is_dict $args]} {
# error "punk::args::get_dict args must be a dict of option value pairs"
#}
set proc_opts [dict merge $defaults $args]
dict for {k v} $proc_opts {
switch -- $k {
@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args {
#define will either return a permanently cached argspecs (-dynamic 0) - or
# use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs.
set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
#argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info
# -----------------------------------------------
# Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc)
tcl::dict::with argspecs {} ;#turn keys into vars
#tcl::dict::with argspecs {} ;#turn keys into vars
#e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names
# -----------------------------------------------
#we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with
set FORMS [dict get $argspecs FORMS]
set form_names [dict get $argspecs form_names]
set opt_form [dict get $proc_opts -form]
if {$opt_form eq "*"} {
set selected_forms $form_names
@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args {
#todo - handle multiple fids?
set fid [lindex $selected_forms 0]
set formdict [dict get $FORMS $fid]
tcl::dict::with formdict {}
#populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
# formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED
# LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED
# LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES
# OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS
# VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS
# VAL_CHECKS_DEFAULTS FORMDISPLAY
#tcl::dict::with formdict {}
##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
#individual var extraction is faster than 'dict with' - even though we need nearly every key
set ARG_INFO [dict get $formdict ARG_INFO]
set ARG_CHECKS [dict get $formdict ARG_CHECKS]
set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS]
set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED]
set LEADER_NAMES [dict get $formdict LEADER_NAMES]
set LEADER_MIN [dict get $formdict LEADER_MIN]
set LEADER_MAX [dict get $formdict LEADER_MAX]
set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO]
set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED]
set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS]
set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS]
set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS]
set OPT_REQUIRED [dict get $formdict OPT_REQUIRED]
set OPT_NAMES [dict get $formdict OPT_NAMES]
set OPT_ANY [dict get $formdict OPT_ANY]
#set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS]
set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS]
set VAL_REQUIRED [dict get $formdict VAL_REQUIRED]
set VAL_NAMES [dict get $formdict VAL_NAMES]
set VAL_MIN [dict get $formdict VAL_MIN]
set VAL_MAX [dict get $formdict VAL_MAX]
set VAL_UNNAMED [dict get $formdict VAL_UNNAMED]
set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS]
set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS]
set FORMDISPLAY [dict get $formdict FORMDISPLAY]
if {$VAL_MIN eq ""} {
set valmin 0
#set VAL_MIN 0
@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args {
# todo variable clause lengths (items marked optional in types using leading&trailing questionmarks)
# e.g -types {a ?xxx?}
#this has one required and one optional
set typelist [dict get $ARG_INFO $v -type]
set clause_length 0
foreach t $typelist {
#for each t in typelist
foreach t [dict get $ARG_INFO $v -type] {
if {![string match {\?*\?} $t]} {
incr clause_length
}
@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args {
#REVIEW - what about optional members in leaders e.g -type {int ?double?}
set named_leader_args_max 0
foreach ln $LEADER_NAMES {
set typelist [dict get $ARG_INFO $ln -type]
incr named_leader_args_max [llength $typelist]
incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]]
}
#set id [dict get $argspecs id]
@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args {
#}
set can_have_leaders 1 ;#default assumption
if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} {
if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} {
set can_have_leaders 0
}
@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args {
if {$OPT_MAX ne "0"} {
foreach t $leader_type {
set raw [lindex $rawargs $tentative_idx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set flagname $raw
if {[string match --* $raw]} {
@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args {
# and only for the last defined leader. This should be done in the definition parsing - not here.
foreach t $leader_type {
set raw [lindex $rawargs $ridx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set matchopt [::tcl::prefix::match -error {} $all_opts $raw]
@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args {
set leadermin $LEADER_MIN
}
if {$LEADER_MAX eq ""} {
if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} {
if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} {
set leadermax 0
} else {
set leadermax -1
@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args {
}
if {$VAL_MAX eq ""} {
if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} {
if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} {
set valmax 0
} else {
set valmax -1
@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args {
#assert leadermax leadermin are numeric
#assert - remaining_rawargs has been reduced by leading positionals
set opts [dict create] ;#don't set to OPT_DEFAULTS here
#beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true)
#set opts [dict create] ;#don't set to OPT_DEFAULTS here
set opts [list]
set leaders [list]
set arglist {}
@ -7982,7 +8011,7 @@ tcl::namespace::eval punk::args {
#valmin, valmax
#puts stderr "remaining_rawargs: $remaining_rawargs"
#puts stderr "argstate: $argstate"
if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} {
if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] > -1} {
#contains at least one possible flag
set maxidx [expr {[llength $remaining_rawargs] -1}]
if {$valmax == -1} {
@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args {
break
}
set a [lindex $remaining_rawargs $i]
switch -glob -- $a {
-- {
if {$a in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
}
--* {
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
set a1 [string index $a 0]
set a2 [string index $a 1]
if {$a1 eq "-"} {
if {$a2 eq "-"} {
if {$a eq "--"} {
if {"--" in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
#--*
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
}
}
}
-* {
} else {
#-*
set flagsupplied $a
set flagval ""
set flagval_included false
}
default {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
} else {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#switch -glob -- $a {
# -- {
# }
# --* {
# }
# -* {
# }
# default {
# }
#}
#flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
@ -8212,7 +8254,7 @@ tcl::namespace::eval punk::args {
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
@ -8277,7 +8319,7 @@ tcl::namespace::eval punk::args {
#exlude argument with whitespace from being a possible option e.g dict
#todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value
set eposn [string first = $a]
if {[string match --* $a] && $eposn > 2} {
if {$eposn > 2 && [string match --* $a]} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#undefined_flagsupplied may still be a 'short form/prefix'
@ -8374,6 +8416,8 @@ tcl::namespace::eval punk::args {
#set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected
set arglist [list]
}
#set id [dict get $argspecs id]
#if {$id eq "::if"} {
#puts stderr "::if"
@ -8408,7 +8452,7 @@ tcl::namespace::eval punk::args {
# }
#}
#puts ">>>>==== $opts"
#puts ">>>>====opts: $opts"
set seen_pks [list]
#treating opts as list for this loop.
foreach optset $OPT_NAMES {
@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $leadername -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $leadername -optional]} {
puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)"
#return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?"
incr ldridx -1
set leadername_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$leadername ni $leadernames_received} {
#puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES"
set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)."
@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could use break?
continue
}
if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} {
if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset leaders_dict $leadername
@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $valname -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $valname -optional]} {
#error 333
puts stderr "get_dict cannot assign val:$val to valname:$valname (333)"
incr validx -1
set valname_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$valname ni $valnames_received} {
#puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES"
set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)."
@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could break?
continue
}
if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} {
if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset values_dict $vname
@ -8923,6 +8963,11 @@ tcl::namespace::eval punk::args {
#puts " >>>>>>> ---lookup_optset :$lookup_optset"
#puts "---argstate:$argstate"
#JJJ argname_or_ident; ident example: -increasing|-SORTOPTION
#review - ensure all possible keys present in thisarg_keys
set pkoverride [Dict_getdef $argstate -parsekey ""]
tcl::dict::for {argname_or_ident value_group} $opts_and_values {
#
#parsekey: key used in resulting leaders opts values dictionaries
@ -8944,7 +8989,7 @@ tcl::namespace::eval punk::args {
#get full option name such as -fg|-foreground from non-alias name such as -foreground
#if "@opts -any|-arbitrary true" - we may have an option that wasn't defined
set argname [dict get $lookup_optset $argname_or_ident]
set pkoverride [Dict_getdef $argstate -parsekey ""]
#set pkoverride [Dict_getdef $argstate -parsekey ""]
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
@ -8957,7 +9002,7 @@ tcl::namespace::eval punk::args {
}
} else {
set argname $argname_or_ident
set pkoverride [Dict_getdef $argstate -parsekey ""]
#set pkoverride [Dict_getdef $argstate -parsekey ""]
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
@ -8972,21 +9017,24 @@ tcl::namespace::eval punk::args {
#an example argname_or_compound for the above might be: -path|--filename
# where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey
set thisarg_checks [tcl::dict::get $arg_checks $argname]
set thisarg [tcl::dict::get $argstate $argname]
#set thisarg_keys [tcl::dict::keys $thisarg]
set thisarg_checks [tcl::dict::get $arg_checks $argname]
#using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict
set typelist [tcl::dict::get $thisarg -type]
set is_multiple [tcl::dict::get $thisarg -multiple]
set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi]
set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped]
set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi]
#set validationtransform [tcl::dict::get $thisarg -validationtransform]
set has_default [tcl::dict::exists $thisarg -default]
if {$has_default} {
set defaultval [tcl::dict::get $thisarg -default]
}
set typelist [tcl::dict::get $thisarg -type]
set clause_size [llength $typelist]
set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}]
set validationtransform [tcl::dict::get $thisarg -validationtransform]
#JJJJ
@ -9036,7 +9084,7 @@ tcl::namespace::eval punk::args {
set vlist_original $vlist ;#retain for possible final strip_ansi
#review - validationtransform
if {$is_validate_ansistripped} {
if {[llength $vlist] && $is_validate_ansistripped} {
#validate_ansistripped 1
package require punk::ansi
set vlist_check [list]
@ -9076,7 +9124,7 @@ tcl::namespace::eval punk::args {
set vlist_typelist_validate [list]
#reduce our validation requirements by removing values which match defaultval or match -choices
#(could be -multiple with -choicerestricted 0 where some selections match and others don't)
if {$parsekey in $receivednames && $has_choices} {
if {$has_choices && $parsekey in $receivednames} {
#-choices must also work with -multiple
#todo -choicelabels
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
@ -9333,13 +9381,13 @@ tcl::namespace::eval punk::args {
set vlist [list]
set vlist_check_validate [list]
} else {
if {[llength $vlist] && $has_default} {
if {$has_default && [llength $vlist]} {
#defaultval here is a value for the entire clause. (clause usually length 1)
#J2
#set vlist_validate [list]
#set vlist_check_validate [list]
set tp [dict get $thisarg -type]
set clause_size [llength $tp]
#set tp [dict get $thisarg -type]
set clause_size [llength $typelist]
foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist {
#JJJJ
#REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation?
@ -9386,34 +9434,34 @@ tcl::namespace::eval punk::args {
}
}
#is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups
#assert: our vlist & vlist_check lists have been reduced to remove those
if {[llength $vlist] && !$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach clause_value $vlist {
foreach e $clause_value {
if {[punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg
if {[llength $vlist]} {
#is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups
#assert: our vlist & vlist_check lists have been reduced to remove those
if {!$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach clause_value $vlist {
foreach e $clause_value {
if {[punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg
}
}
}
}
}
#puts "argname:$argname v:$v is_default:$is_default"
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
#arguments that are at their default are not subject to type and other checks
#puts "argname:$argname v:$v is_default:$is_default"
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
#arguments that are at their default are not subject to type and other checks
#don't validate defaults or choices that matched
#puts "---> opts_and_values: $opts_and_values"
#puts "===> argname: $argname is_default: $is_default is_choice: $is_choice"
#if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {}
#don't validate defaults or choices that matched
#puts "---> opts_and_values: $opts_and_values"
#puts "===> argname: $argname is_default: $is_default is_choice: $is_choice"
#if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {}
#our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups
#assert [llength $vlist] == [llength $vlist_check]
if {[llength $vlist]} {
#our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups
#assert [llength $vlist] == [llength $vlist_check]
#$t = clause column
#for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {}
@ -9447,37 +9495,37 @@ tcl::namespace::eval punk::args {
}
}
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {[tcl::dict::get $thisarg -multiple]} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list
}
option {
tcl::dict::set opts $argname_or_ident $stripped_list
}
value {
tcl::dict::set values_dict $argname_or_ident $stripped_list
}
}
} else {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0]
}
option {
tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0]
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {$is_multiple} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list
}
option {
tcl::dict::set opts $argname_or_ident $stripped_list
}
value {
tcl::dict::set values_dict $argname_or_ident $stripped_list
}
}
value {
tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0]
} else {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0]
}
option {
tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0]
}
value {
tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0]
}
}
}
}
}
}
set finalopts [dict create]

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

@ -126,7 +126,8 @@ tcl::namespace::eval punk::args::tclcore {
# -- --- --- --- ---
proc example {str} {
set str [string trimleft $str \n]
set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]]
#set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Term-grey bold term-white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]]
set block [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [a+ Term-grey bold term-white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]]
set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"]
#puts $result
return $result

153
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm

@ -702,6 +702,27 @@ namespace eval punk::console {
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
-passthrough -default "none" -choices {none tmux auto} -choicecolumns 1 -choicelabels {
none\
{ ANSI sent without any passthrough wrapping.
A terminal multiplexer such as tmux,screen,zellij may
not pass the request through to the underlying terminal(s)
This is the recommended/normal value for the option.}
tmux\
{ Wrap ANSI sequence with tmux passthrough sequence.
\x1bPtmux\;<originalsequence_with_escapes_doubled>\x1b\\
Note that a tmux session could be connected to multiple
terminals (perhaps of different types) - in which case multiple
responses may be received in a non-deterministic order.
Passthrough should generally be avoided except for debug/test
purposes.
}
auto\
{ Use existence of ::env(TMUX) to detect tmux and
send tmux passthrough sequence.
Not recommended except for debug/test purposes.
}
}
-expected_ms -default 300 -type integer -help\
"Expected number of ms for response from terminal.
100ms is usually plenty for a local terminal and a
@ -731,6 +752,7 @@ namespace eval punk::console {
set expected [dict get $opts -expected_ms]
set ignoreok [dict get $opts -ignoreok]
set returntype [dict get $opts -return]
set passthrough [dict get $opts -passthrough]
set query [dict get $values query]
set capturingendregex [dict get $values capturingendregex]
@ -784,7 +806,7 @@ namespace eval punk::console {
set runningid [lindex $queue 0]
if {$runningid ne $callid} {
set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid)
update ;#REVIEW - probably a bad idea
update ;#REVIEW - possibly a bad idea
after 10
set runningid [lindex $queue 0] ;#jn test
}
@ -836,6 +858,17 @@ namespace eval punk::console {
}
#write before console enableRaw vs after??
#There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it
switch -- $passthrough {
auto {
if {[info exists ::env(TMUX)]} {
set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\"
}
}
tmux {
set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\"
}
}
puts -nonewline $output $query;flush $output
chan configure $input -blocking 0
@ -847,8 +880,10 @@ namespace eval punk::console {
#we should care more about performance in raw mode - as ultimately that's the one we prefer for full features
#------------------
# 1) faster - races?
#first read will read 3 bytes JJJJ
$this_handler $input $callid $capturingendregex
$this_handler $input $callid $capturingendregex
#JJJJ
#$this_handler $input $callid $capturingendregex
if {$ignoreok || $waitvar($callid) ne "ok"} {
chan event $input readable [list $this_handler $input $callid $capturingendregex]
}
@ -1047,7 +1082,11 @@ namespace eval punk::console {
upvar ::punk::console::ansi_response_tsclock tsclock
#endregex should explicitly have a trailing $
set status [catch {read $chan 1} bytes]
if {[string length $chunks($callid)] == 0} {
set status [catch {read $chan 3} bytes]
} else {
set status [catch {read $chan 1} bytes]
}
if { $status != 0 } {
# Error on the channel
chan event $chan readable {}
@ -1290,7 +1329,7 @@ namespace eval punk::console {
"Omit or pass empty string to query current echo state."
}]
proc echo {args} {
set argd [punk::args::parse $args withid ::punk::console::local::echo]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo]
set onoff [dict get $argd values onoff]
set is_windows [string equal "windows" $::tcl_platform(platform)]
@ -1343,6 +1382,7 @@ namespace eval punk::console {
@opts
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-expected_ms -type integer -default 500 -help\
"Number of ms to wait for response"
@values -min 1 -max 1
@ -1356,11 +1396,12 @@ namespace eval punk::console {
lassign [dict values $argd] leaders opts values received
set request [dict get $values request]
set inoutchannels [dict get $opts -terminal]
set passthrough [dict get $opts -passthrough]
set expected [dict get $opts -expected_ms]
set capturingregex {(((.*)))$} ;#capture entire response same as response-payload
set ts_start [clock millis]
set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex]
set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels -passthrough $passthrough $request $capturingregex]
set ts_end [clock millis]
puts stderr $response
set out ""
@ -1781,6 +1822,7 @@ namespace eval punk::console {
}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
@values -min 1 -max 1
mode -type {int|string} -multiple 0 -help\
"integer for DEC mode, or name as in the dict:
@ -1793,10 +1835,11 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc dec_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set mode [dict get $values mode]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set mode [dict get $values mode]
if {[string is integer -strict $mode]} {
set m $mode
@ -1810,7 +1853,7 @@ namespace eval punk::console {
}
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[?$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex]
return $payload
}
@ -1838,7 +1881,7 @@ namespace eval punk::console {
}
#todo - should accept multiple mode nums/names at once
proc dec_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1884,7 +1927,7 @@ namespace eval punk::console {
}]
}
proc dec_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1931,6 +1974,7 @@ namespace eval punk::console {
}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-refresh -type none -help\
"Force a re-test of the mode."
-return -type string -choices {dict result} -default result -choicelabels {
@ -1946,9 +1990,10 @@ namespace eval punk::console {
}]
}
proc dec_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set console [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set num_or_name [dict get $values mode]
set do_refresh [dict exists $received -refresh]
set return [dict get $opts -return]
@ -1964,21 +2009,23 @@ namespace eval punk::console {
}
}
variable dec_has_mode_cache
#make sure we cache on both console and passthrough
set cachekey "$console $passthrough"
if {$do_refresh} {
if {[dict exists $dec_has_mode_cache $console $m]} {
dict unset dec_has_mode_cache $console $m
if {[dict exists $dec_has_mode_cache $cachekey $m]} {
dict unset dec_has_mode_cache $cachekey $m
}
}
if {![dict exists $dec_has_mode_cache $console $m]} {
if {![dict exists $dec_has_mode_cache $cachekey $m]} {
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[?$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex]
#set has_mode [expr {$payload != 0}]
#we can use the payload result as the response as non-zero responses evaluate to true
set has_mode $payload
if {$has_mode ne ""} {
dict set dec_has_mode_cache $console $m $has_mode
dict set dec_has_mode_cache $cachekey $m $has_mode
set source "query"
} else {
#don't cache an empty/failed response - review
@ -1986,7 +2033,7 @@ namespace eval punk::console {
set source "failedquery"
}
} else {
set has_mode [dict get $dec_has_mode_cache $console $m]
set has_mode [dict get $dec_has_mode_cache $cachekey $m]
set source "cache"
}
if {$return eq "dict"} {
@ -2004,6 +2051,7 @@ namespace eval punk::console {
{Show table of DEC modes with basic information.}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-test -type none -help\
"Test current value/support for each mode"
-supported -type none -help\
@ -2013,10 +2061,11 @@ namespace eval punk::console {
"Match code or name"
}]
proc dec_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set do_test [dict exists $received -test]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set do_test [dict exists $received -test]
set only_supported [dict exists $received -supported]
if {[dict exists $values match]} {
set matches [dict get $values match]
@ -2074,7 +2123,7 @@ namespace eval punk::console {
set RST ""
if {$do_test} {
#dec_has_mode can be cached - in which case only 0|3|4 can be relied upon without re-querying
set hasmode_dict [dec_has_mode -console $terminal -return dict $code]
set hasmode_dict [dec_has_mode -console $terminal -passthrough $passthrough -return dict $code]
switch -- [dict get $hasmode_dict result] {
0 {
if {$only_supported} {
@ -2089,7 +2138,7 @@ namespace eval punk::console {
1 - 2 {
if {[dict get $hasmode_dict source] eq "cache"} {
#a terminal query is required
set testresult [dec_get_mode -console $terminal $code]
set testresult [dec_get_mode -console $terminal -passthrough $passthrough $code]
} else {
set testresult [dict get $hasmode_dict result]
if {![string is integer -strict $testresult]} {
@ -2135,7 +2184,7 @@ namespace eval punk::console {
} else {
if {$only_supported} {
#dec_has_mode still queries terminal - but is cached if a response was received
if {[dec_has_mode -console $terminal $code] == 0} {
if {[dec_has_mode -console $terminal -passthrough $passthrough $code] == 0} {
continue
}
}
@ -2184,6 +2233,7 @@ namespace eval punk::console {
source indicates whether the result came
from query or cache."
}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
@values -min 1 -max 1
mode -type {int|string} -help\
"integer for ANSI mode, or name as in the dict:
@ -2191,12 +2241,13 @@ namespace eval punk::console {
}]
}
proc ansi_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set console [dict get $opts -console]
set num_or_name [dict get $values mode]
set return [dict get $opts -return]
set do_refresh [dict exists $received -refresh]
set return [dict get $opts -return]
set passthrough [dict get $opts -passthrough]
set do_refresh [dict exists $received -refresh]
if {[string is integer -strict $num_or_name]} {
set m $num_or_name
@ -2209,20 +2260,22 @@ namespace eval punk::console {
}
}
variable ansi_has_mode_cache
#make sure we cache on both console and passthrough
set cachekey "$console $passthrough"
if {$do_refresh} {
if {[dict exists $ansi_has_mode_cache $console $m]} {
dict unset ansi_has_mode_cache $console $m
if {[dict exists $ansi_has_mode_cache $cachekey $m]} {
dict unset ansi_has_mode_cache $cachekey $m
}
}
if {![dict exists $ansi_has_mode_cache $console $m]} {
if {![dict exists $ansi_has_mode_cache $cachekey $m]} {
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex]
#set has_mode [expr {$payload != 0}]
set has_mode $payload
if {$has_mode ne ""} {
dict set ansi_has_mode_cache $console $m $has_mode
dict set ansi_has_mode_cache $cachekey $m $has_mode
set source "query"
} else {
#don't cache an empty/failed response - review
@ -2230,7 +2283,7 @@ namespace eval punk::console {
set source "failedquery"
}
} else {
set has_mode [dict get $ansi_has_mode_cache $console $m]
set has_mode [dict get $ansi_has_mode_cache $cachekey $m]
set source "cache"
}
if {$return eq "dict"} {
@ -2261,7 +2314,7 @@ namespace eval punk::console {
}]
}
proc ansi_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2308,7 +2361,7 @@ namespace eval punk::console {
}]
}
proc ansi_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2361,6 +2414,7 @@ namespace eval punk::console {
}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
@values -min 1 -max 1
mode -type {int|string} -multiple 0 -help\
"integer for ANSI mode, or name as in the dict:
@ -2373,10 +2427,11 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc ansi_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set mode [dict get $values mode]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set mode [dict get $values mode]
if {[string is integer -strict $mode]} {
set m $mode
@ -2390,7 +2445,7 @@ namespace eval punk::console {
}
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex]
return $payload
}
#todo ansi_unset_mode
@ -2404,6 +2459,7 @@ namespace eval punk::console {
{Show table of ANSI modes with basic information.}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-test -type none -help\
"Test current value/support for each mode"
-supported -type none -help\
@ -2413,10 +2469,11 @@ namespace eval punk::console {
"Match code or name"
}]
proc ansi_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set do_test [dict exists $received -test]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set do_test [dict exists $received -test]
if {[dict exists $values match]} {
set matches [dict get $values match]
} else {
@ -2500,7 +2557,7 @@ namespace eval punk::console {
set reset_state_colour ""
set RST ""
if {$do_test} {
set hasmode_dict [ansi_has_mode -console $terminal -return dict $code]
set hasmode_dict [ansi_has_mode -console $terminal -passthrough $passthrough -return dict $code]
switch -- [dict get $hasmode_dict result] {
0 {
if {$only_supported} {
@ -2515,7 +2572,7 @@ namespace eval punk::console {
1 - 2 {
if {[dict get $hasmode_dict source] eq "cache"} {
#a terminal query is required
set testresult [ansi_get_mode -console $terminal $code]
set testresult [ansi_get_mode -console $terminal -passthrough $passthrough $code]
} else {
set testresult [dict get $hasmode_dict result]
if {![string is integer -strict $testresult]} {
@ -2561,7 +2618,7 @@ namespace eval punk::console {
} else {
if {$only_supported} {
#ansi_has_mode still queries terminal - but is cached if a response was received
if {[ansi_has_mode -console $terminal $code] == 0} {
if {[ansi_has_mode -console $terminal -passthrough $passthrough $code] == 0} {
continue
}
}
@ -2659,7 +2716,7 @@ namespace eval punk::console {
name -type string
}]
proc dec_request_setting {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_request_setting]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting]
lassign [dict values $argd] leaders opts values
set console [dict get $opts -console]
set name [dict get $values name]

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

@ -1355,14 +1355,18 @@ tcl::namespace::eval punk::ns {
set a [a+ bold purple]
set e [a+ bold yellow]
set p [a+ bold white]
set c_nat [a+ web-gray] ;#native
set c_int [a+ web-orange] ;#interps
set c_cor [a+ web-hotpink] ;#coroutines
#set c_nat [a+ web-gray] ;#native
set c_nat [a+ term-silver] ;#native
set c_int [a+ term-orange1] ;#interps
set c_cor [a+ term-hotpink] ;#coroutines
set c_ooo [a+ bold cyan] ;#object
set c_ooc [a+ web-aquamarine] ;#class
set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_zst [a+ web-yellow] ;#zlibstreams
#set c_ooc [a+ web-aquamarine] ;#class
set c_ooc [a+ term-aqua] ;#class
#set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooO [a+ term-purple-c] ;#privateObject
#set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_ooC [a+ term-cornflowerblue] ;#privateClass
set c_zst [a+ term-yellow] ;#zlibstreams
set a1 [a][a+ cyan]
foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 {
@ -6629,16 +6633,16 @@ y" {return quirkykeyscript}
switch -- $syntax {
basic {
#rudimentary colourising only
set argl [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl]
set argl [punk::ansi::grepstr -return all -highlight term-teal {\{|\}} $argl]
set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon
set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon
##set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $body]
set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body]
set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body]
set body [punk::ansi::grepstr -return all -highlight tk-orange {\[|\]} $body]
set body [punk::ansi::grepstr -return all -highlight term-teal {^(\{)|[^\\](\{+)} $body]
set body [punk::ansi::grepstr -return all -highlight term-teal {[^\\](\}+)} $body]
set body [punk::ansi::grepstr -return all -highlight term-orange {\[|\]} $body]
}
default {
set is_highlighted 0

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

@ -1497,7 +1497,7 @@ tcl::namespace::eval textblock {
} elseif {$span > 0} {
#ok to reset to higher val immediately or after an any and any number of following zeros
if {$span > ($numcols - $sidx)} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview"
}
set remaining $span
@ -1508,7 +1508,7 @@ tcl::namespace::eval textblock {
} else {
if {$span eq "0"} {
if {$remaining eq "0"} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview"
} else {
incr remaining -1
@ -1517,7 +1517,7 @@ tcl::namespace::eval textblock {
if {$remaining eq "0"} {
#ok for new span value of any or > 0
if {$span ne "any" && $span > ($numcols - $sidx)} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview"
}
set remaining $span
@ -1525,7 +1525,7 @@ tcl::namespace::eval textblock {
incr remaining -1
}
} else {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview"
}
}
@ -2926,7 +2926,7 @@ tcl::namespace::eval textblock {
$htable add_row [list "$hnum " $h "${width}x${height}" $s]
incr hnum
}
$htable configure_column 0 -ansibase [a+ web-dimgray]
$htable configure_column 0 -ansibase [a+ term-grey]
tcl::dict::set col_header_tables $col $htable
set colwidths [$htable column_widths]
set icol 0
@ -4294,7 +4294,8 @@ tcl::namespace::eval textblock {
set ecat [tcl::dict::create]
set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra]
set ansi [a+ {*}$fc web-black Web-gold]
#set ansi [a+ {*}$fc web-black Web-gold]
set ansi [a+ {*}$fc term-black Term-gold1]
set val [list ansi $ansi cat alkaline_earth]
foreach e $cat_alkaline_earth {
tcl::dict::set ecat $e $val
@ -4302,7 +4303,7 @@ tcl::namespace::eval textblock {
set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I]
#set ansi [a+ {*}$fc web-black Web-lightgreen]
set ansi [a+ {*}$fc black Term-113]
set ansi [a+ {*}$fc term-black Term-113]
set val [list ansi $ansi cat reactive_nonmetal]
foreach e $cat_reactive_nonmetal {
tcl::dict::set ecat $e $val
@ -4310,7 +4311,7 @@ tcl::namespace::eval textblock {
set cat [list Li Na K Rb Cs Fr]
#set ansi [a+ {*}$fc web-black Web-Khaki]
set ansi [a+ {*}$fc black Term-lightgoldenrod2]
set ansi [a+ {*}$fc term-black Term-lightgoldenrod2]
set val [list ansi $ansi cat alkali_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4318,14 +4319,16 @@ tcl::namespace::eval textblock {
set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs]
#set ansi [a+ {*}$fc web-black Web-lightsalmon]
set ansi [a+ {*}$fc black Term-orange1]
set ansi [a+ {*}$fc term-black Term-salmon1]
set val [list ansi $ansi cat transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list Al Ga In Sn Tl Pb Bi Po]
set ansi [a+ {*}$fc web-black Web-lightskyblue]
#set ansi [a+ {*}$fc web-black Web-lightskyblue]
set ansi [a+ {*}$fc term-black Term-lightsteelblue]
set val [list ansi $ansi cat post_transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4333,21 +4336,25 @@ tcl::namespace::eval textblock {
set cat [list B Si Ge As Sb Te At]
#set ansi [a+ {*}$fc web-black Web-turquoise]
set ansi [a+ {*}$fc black Brightcyan]
#set ansi [a+ {*}$fc black Brightcyan]
set ansi [a+ {*}$fc term-black Term-skyblue1]
set val [list ansi $ansi cat metalloids]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list He Ne Ar Kr Xe Rn]
set ansi [a+ {*}$fc web-black Web-orchid]
#set ansi [a+ {*}$fc web-black Web-orchid]
set ansi [a+ {*}$fc term-black Term-purple-c]
set val [list ansi $ansi cat noble_gases]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr]
set ansi [a+ {*}$fc web-black Web-plum]
#set ansi [a+ {*}$fc web-black Web-plum]
set ansi [a+ {*}$fc term-black Term-plum1]
set val [list ansi $ansi cat actinoids]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4361,7 +4368,8 @@ tcl::namespace::eval textblock {
tcl::dict::set ecat $e $val
}
set ansi [a+ {*}$fc web-black Web-whitesmoke]
#set ansi [a+ {*}$fc web-black Web-whitesmoke]
set ansi [a+ {*}$fc term-black Term-silver]
set val [list ansi $ansi cat other]
foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] {
tcl::dict::set ecat $e $val
@ -4807,7 +4815,7 @@ tcl::namespace::eval textblock {
123456789ABCDEF
"
-size -type integer\
-default 15\
-default 16\
-optional 1\
-range {1 ""}
-direction -default horizontal\
@ -4818,6 +4826,7 @@ tcl::namespace::eval textblock {
the colour stripes will be oriented
in this direction.
"
-noreset -type none
@values -min 0 -max 1
colour -type list -default {} -optional 1 -help\
"List of Ansi colour names
@ -4832,8 +4841,10 @@ tcl::namespace::eval textblock {
proc testblock {args} {
set argd [punk::args::parse $args withid ::textblock::testblock]
set colour [dict get $argd values colour]
set size [dict get $argd opts -size]
lassign [dict values $argd] leaders opts values received
set colour [dict get $values colour]
set size [dict get $opts -size]
set noreset [dict exists $received -noreset]
set rainbow_list [list]
lappend rainbow_list {30 47} ;#black White
@ -4879,7 +4890,7 @@ tcl::namespace::eval textblock {
set longbows [concat {*}[lrepeat $numsets $rainbow_list]]
set rainbow_list [lrange $longbows 0 $size-1]
}
if {"noreset" in $colour} {
if {$noreset} {
set RST ""
} else {
set RST [a]
@ -4896,7 +4907,7 @@ tcl::namespace::eval textblock {
set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi]
lappend clist ${ansicode}$c$RST
}
if {"noreset" in $colour} {
if {$noreset} {
return [textblock::join_basic -ansiresets 0 -- {*}$clist]
} else {
#return [textblock::join_basic -- {*}$clist]
@ -4935,6 +4946,7 @@ tcl::namespace::eval textblock {
for {set r 0} {$r < $size} {incr r} {
append block [::join $charsubset ""] \n
}
set block [tcl::string::trimright $block \n]
if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
@ -5642,22 +5654,22 @@ tcl::namespace::eval textblock {
set headers [list]
set blocks [list]
lappend blocks "[textblock::testblock 4 rainbow]"
lappend blocks "[textblock::testblock -size 4 rainbow]"
lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing"
lappend blocks "[textblock::testblock 4 rainbow][a]"
lappend blocks "[textblock::testblock -size 4 rainbow][a]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset"
lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 rainbow]\n[a+ Term-green]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]"
lappend headers "rainbow 4x4\nno line resets\nnothing trailing"
lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}][a]"
lappend headers "rainbow 4x4\nno line resets\ntrailing reset"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]\n[a+ Term-green]"
lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg"
set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers]
@ -5665,13 +5677,13 @@ tcl::namespace::eval textblock {
proc pad_example2 {} {
set headers [list]
set blocks [list]
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n"
lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl"
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]"
lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a]"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset"
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]"
lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a+ Term-green]"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg"
set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers]
@ -6113,14 +6125,15 @@ tcl::namespace::eval textblock {
proc welcome_test {} {
package require punk::ansi
package require patternpunk
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]]
set ansi [textblock::join -- " " [punk::ansi::ansicat -dimensions 80x8 src/testansi/publicdomain/roysac/ROY-WELC.ANS]]
# Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com
set table [[textblock::spantest] print]
set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
#set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ term-yellow][>punk . rhs][a]
set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks]
set testblock [textblock::testblock -size 15 rainbow]
set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ term-orange1] $contents]
}
@ -7831,7 +7844,7 @@ tcl::namespace::eval textblock {
}
}
proc frame_cache {args} {
set argd [punk::args::parse $args withid ::textblock::frame_cache]
set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache]
set action [dict get $argd values action]
variable frame_cache
set all_values_dict [dict get $argd values]
@ -8350,13 +8363,14 @@ tcl::namespace::eval textblock {
set usecache 0
#set buildcache 0 ;#comment out for debug/analysis so we can see
#puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'"
set cache_key [a+ Web-red web-white]$cache_key[a]
set cache_key [a+ Term-red term-white]$cache_key[a]
}
if {$buildcache && ($actual_contentwidth < $frame_inner_width)} {
#colourise cache_key to warn
if {$actual_contentwidth == 0} {
#we can still substitute with right length
set cache_key [a+ Web-steelblue web-black]$cache_key[a]
#set cache_key [a+ Web-steelblue term-black]$cache_key[a]
set cache_key [a+ Term-cornflowerblue term-black]$cache_key[a]
} else {
#actual_contentwidth is narrower than frame - check template's patternwidth
if {[tcl::dict::exists $frame_cache $cache_key]} {
@ -8366,13 +8380,13 @@ tcl::namespace::eval textblock {
}
if {$actual_contentwidth < $cache_patternwidth} {
set usecache 0
set cache_key [a+ Web-orange web-black]$cache_key[a]
set cache_key [a+ Term-orange1 term-black]$cache_key[a]
} elseif {$actual_contentwidth == $cache_patternwidth} {
#set usecache 1
} else {
#actual_contentwidth > pattern
set usecache 0
set cache_key [a+ Web-red web-black]$cache_key[a]
set cache_key [a+ Term-red term-black]$cache_key[a]
}
}
}

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

@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
@values -min 0 -max 0
}]
proc sgr_cache {args} {
set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache]
set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache]
set action [dict get $argd opts -action]
set pretty [dict get $argd opts -pretty]

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

@ -373,9 +373,9 @@ tcl::namespace::eval ::punk::args::helpers {
#Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between
# the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems.
set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {^\{|[^\\](\{+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {[^\\](\}+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-olive} {\[|\]} $str]
#puts stderr -------------------
#puts $str
#puts stderr -------------------
@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef
set defspace ""
if {[dict exists $rawdef_cache_about $args]} {
set cinfo [dict get $rawdef_cache_about $args]
set cinfo [dict get $rawdef_cache_about $args]
set id [dict get $cinfo -id]
set is_dynamic [dict get $cinfo -dynamic]
if {[dict exists $cinfo -defspace]} {
@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args {
#test the rawdef for @dynamic directive
proc rawdef_is_dynamic {rawdef} {
#temporary - old way
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ]
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}]
if {$flagged_dynamic} {
return true
}
@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args {
#puts "-->$cmdinfo"
#puts "-->[tcl::info::frame -3]"
set maxloop 10 ;#failsafe
while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} {
while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} {
#looks like a script - haven't gone up far enough?
#(e.g patternpunk oo system: >punk . poses -invalidoption)
incr call_level -1
@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args {
if {$use_table} {
append errmsg \n
} else {
if {($returntype in {table tableobject}) && !$has_textblock} {
if {!$has_textblock && ($returntype in {table tableobject})} {
append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n
} else {
append errmsg \n
@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args {
variable parse_cache [dict create]
proc parse {args} {
#puts "punk::args::parse --> '$args'"
set tailtype "" ;#withid|withdef
if {[llength $args] < 3} {
#error "punk::args::parse - invalid call. < 3 args"
punk::args::parse $args -cache 1 withid ::punk::args::parse
@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args {
}
}
#set values [lrange $opts_and_vals $i end]
set values $opts_and_vals
#set values $opts_and_vals
#puts "---values: $values"
set tailtype [lindex $values 0]
set tailargs [lrange $values 1 end]
#set split [lsearch -exact $tailargs withid]
#if {$split < 0} {
# set split [lsearch -exact $tailargs withdef]
# if {$split < 0} {
# #punk::args::usage arg_error?
# #error "punk::args::parse - invalid call. keyword withid|withdef required"
# punk::args::parse $args withid ::punk::args::parse
# } else {
# set tailtype withdef
#}
#} else {
# set tailtype withid
#}
#set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here.
#set tailtype [lindex $values 0] ;#withid|withdef
#set tailargs [lrange $values 1 end]
set tailtype [lpop opts_and_vals 0]
#if {[llength $opts] % 2} {
#error "punk::args::parse Even number of -flag val pairs required after arglist"
#}
#Default the -errorstyle to standard
# (slow on unhappy path - but probably clearest for playing with new APIs interactively)
@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args {
}
switch -- $tailtype {
withid {
if {[llength $tailargs] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
set id [lindex $tailargs 0]
#puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts"
#puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts"
set deflist [raw_def $id]
#JJJ
#set id [lindex $opts_and_vals 0]
set deflist [raw_def [lindex $opts_and_vals 0]]
if {[llength $deflist] == 0} {
if {[llength $opts_and_vals] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
error "punk::args::parse - no such id: $id"
}
}
withdef {
set deflist $tailargs
set deflist $opts_and_vals
if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
#puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts"
#puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts"
}
default {
error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'"
@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args {
proc get_dict {deflist rawargs args} {
#see arg_error regarding considerations around unhappy-path performance
if {![punk::args::lib::string_is_dict $args]} {
error "punk::args::get_dict args must be a dict of option value pairs"
}
set defaults [dict create\
-form *\
]
#if {![punk::args::lib::string_is_dict $args]} {
# error "punk::args::get_dict args must be a dict of option value pairs"
#}
set proc_opts [dict merge $defaults $args]
dict for {k v} $proc_opts {
switch -- $k {
@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args {
#define will either return a permanently cached argspecs (-dynamic 0) - or
# use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs.
set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
#argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info
# -----------------------------------------------
# Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc)
tcl::dict::with argspecs {} ;#turn keys into vars
#tcl::dict::with argspecs {} ;#turn keys into vars
#e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names
# -----------------------------------------------
#we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with
set FORMS [dict get $argspecs FORMS]
set form_names [dict get $argspecs form_names]
set opt_form [dict get $proc_opts -form]
if {$opt_form eq "*"} {
set selected_forms $form_names
@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args {
#todo - handle multiple fids?
set fid [lindex $selected_forms 0]
set formdict [dict get $FORMS $fid]
tcl::dict::with formdict {}
#populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
# formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED
# LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED
# LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES
# OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS
# VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS
# VAL_CHECKS_DEFAULTS FORMDISPLAY
#tcl::dict::with formdict {}
##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
#individual var extraction is faster than 'dict with' - even though we need nearly every key
set ARG_INFO [dict get $formdict ARG_INFO]
set ARG_CHECKS [dict get $formdict ARG_CHECKS]
set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS]
set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED]
set LEADER_NAMES [dict get $formdict LEADER_NAMES]
set LEADER_MIN [dict get $formdict LEADER_MIN]
set LEADER_MAX [dict get $formdict LEADER_MAX]
set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO]
set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED]
set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS]
set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS]
set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS]
set OPT_REQUIRED [dict get $formdict OPT_REQUIRED]
set OPT_NAMES [dict get $formdict OPT_NAMES]
set OPT_ANY [dict get $formdict OPT_ANY]
#set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS]
set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS]
set VAL_REQUIRED [dict get $formdict VAL_REQUIRED]
set VAL_NAMES [dict get $formdict VAL_NAMES]
set VAL_MIN [dict get $formdict VAL_MIN]
set VAL_MAX [dict get $formdict VAL_MAX]
set VAL_UNNAMED [dict get $formdict VAL_UNNAMED]
set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS]
set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS]
set FORMDISPLAY [dict get $formdict FORMDISPLAY]
if {$VAL_MIN eq ""} {
set valmin 0
#set VAL_MIN 0
@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args {
# todo variable clause lengths (items marked optional in types using leading&trailing questionmarks)
# e.g -types {a ?xxx?}
#this has one required and one optional
set typelist [dict get $ARG_INFO $v -type]
set clause_length 0
foreach t $typelist {
#for each t in typelist
foreach t [dict get $ARG_INFO $v -type] {
if {![string match {\?*\?} $t]} {
incr clause_length
}
@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args {
#REVIEW - what about optional members in leaders e.g -type {int ?double?}
set named_leader_args_max 0
foreach ln $LEADER_NAMES {
set typelist [dict get $ARG_INFO $ln -type]
incr named_leader_args_max [llength $typelist]
incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]]
}
#set id [dict get $argspecs id]
@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args {
#}
set can_have_leaders 1 ;#default assumption
if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} {
if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} {
set can_have_leaders 0
}
@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args {
if {$OPT_MAX ne "0"} {
foreach t $leader_type {
set raw [lindex $rawargs $tentative_idx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set flagname $raw
if {[string match --* $raw]} {
@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args {
# and only for the last defined leader. This should be done in the definition parsing - not here.
foreach t $leader_type {
set raw [lindex $rawargs $ridx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set matchopt [::tcl::prefix::match -error {} $all_opts $raw]
@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args {
set leadermin $LEADER_MIN
}
if {$LEADER_MAX eq ""} {
if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} {
if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} {
set leadermax 0
} else {
set leadermax -1
@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args {
}
if {$VAL_MAX eq ""} {
if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} {
if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} {
set valmax 0
} else {
set valmax -1
@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args {
#assert leadermax leadermin are numeric
#assert - remaining_rawargs has been reduced by leading positionals
set opts [dict create] ;#don't set to OPT_DEFAULTS here
#beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true)
#set opts [dict create] ;#don't set to OPT_DEFAULTS here
set opts [list]
set leaders [list]
set arglist {}
@ -7982,7 +8011,7 @@ tcl::namespace::eval punk::args {
#valmin, valmax
#puts stderr "remaining_rawargs: $remaining_rawargs"
#puts stderr "argstate: $argstate"
if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] >= 0} {
if {$OPT_MAX ne "0" && [lsearch $remaining_rawargs -*] > -1} {
#contains at least one possible flag
set maxidx [expr {[llength $remaining_rawargs] -1}]
if {$valmax == -1} {
@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args {
break
}
set a [lindex $remaining_rawargs $i]
switch -glob -- $a {
-- {
if {$a in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
}
--* {
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
set a1 [string index $a 0]
set a2 [string index $a 1]
if {$a1 eq "-"} {
if {$a2 eq "-"} {
if {$a eq "--"} {
if {"--" in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
#--*
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
}
}
}
-* {
} else {
#-*
set flagsupplied $a
set flagval ""
set flagval_included false
}
default {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
} else {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#switch -glob -- $a {
# -- {
# }
# --* {
# }
# -* {
# }
# default {
# }
#}
#flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
@ -8212,7 +8254,7 @@ tcl::namespace::eval punk::args {
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
@ -8277,7 +8319,7 @@ tcl::namespace::eval punk::args {
#exlude argument with whitespace from being a possible option e.g dict
#todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value
set eposn [string first = $a]
if {[string match --* $a] && $eposn > 2} {
if {$eposn > 2 && [string match --* $a]} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#undefined_flagsupplied may still be a 'short form/prefix'
@ -8374,6 +8416,8 @@ tcl::namespace::eval punk::args {
#set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected
set arglist [list]
}
#set id [dict get $argspecs id]
#if {$id eq "::if"} {
#puts stderr "::if"
@ -8408,7 +8452,7 @@ tcl::namespace::eval punk::args {
# }
#}
#puts ">>>>==== $opts"
#puts ">>>>====opts: $opts"
set seen_pks [list]
#treating opts as list for this loop.
foreach optset $OPT_NAMES {
@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $leadername -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $leadername -optional]} {
puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)"
#return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?"
incr ldridx -1
set leadername_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$leadername ni $leadernames_received} {
#puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES"
set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)."
@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could use break?
continue
}
if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} {
if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset leaders_dict $leadername
@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $valname -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $valname -optional]} {
#error 333
puts stderr "get_dict cannot assign val:$val to valname:$valname (333)"
incr validx -1
set valname_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$valname ni $valnames_received} {
#puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES"
set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)."
@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could break?
continue
}
if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} {
if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset values_dict $vname
@ -8923,6 +8963,11 @@ tcl::namespace::eval punk::args {
#puts " >>>>>>> ---lookup_optset :$lookup_optset"
#puts "---argstate:$argstate"
#JJJ argname_or_ident; ident example: -increasing|-SORTOPTION
#review - ensure all possible keys present in thisarg_keys
set pkoverride [Dict_getdef $argstate -parsekey ""]
tcl::dict::for {argname_or_ident value_group} $opts_and_values {
#
#parsekey: key used in resulting leaders opts values dictionaries
@ -8944,7 +8989,7 @@ tcl::namespace::eval punk::args {
#get full option name such as -fg|-foreground from non-alias name such as -foreground
#if "@opts -any|-arbitrary true" - we may have an option that wasn't defined
set argname [dict get $lookup_optset $argname_or_ident]
set pkoverride [Dict_getdef $argstate -parsekey ""]
#set pkoverride [Dict_getdef $argstate -parsekey ""]
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
@ -8957,7 +9002,7 @@ tcl::namespace::eval punk::args {
}
} else {
set argname $argname_or_ident
set pkoverride [Dict_getdef $argstate -parsekey ""]
#set pkoverride [Dict_getdef $argstate -parsekey ""]
if {$pkoverride ne ""} {
set parsekey $pkoverride
} else {
@ -8972,21 +9017,24 @@ tcl::namespace::eval punk::args {
#an example argname_or_compound for the above might be: -path|--filename
# where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey
set thisarg_checks [tcl::dict::get $arg_checks $argname]
set thisarg [tcl::dict::get $argstate $argname]
#set thisarg_keys [tcl::dict::keys $thisarg]
set thisarg_checks [tcl::dict::get $arg_checks $argname]
#using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict
set typelist [tcl::dict::get $thisarg -type]
set is_multiple [tcl::dict::get $thisarg -multiple]
set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi]
set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped]
set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi]
#set validationtransform [tcl::dict::get $thisarg -validationtransform]
set has_default [tcl::dict::exists $thisarg -default]
if {$has_default} {
set defaultval [tcl::dict::get $thisarg -default]
}
set typelist [tcl::dict::get $thisarg -type]
set clause_size [llength $typelist]
set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}]
set validationtransform [tcl::dict::get $thisarg -validationtransform]
#JJJJ
@ -9036,7 +9084,7 @@ tcl::namespace::eval punk::args {
set vlist_original $vlist ;#retain for possible final strip_ansi
#review - validationtransform
if {$is_validate_ansistripped} {
if {[llength $vlist] && $is_validate_ansistripped} {
#validate_ansistripped 1
package require punk::ansi
set vlist_check [list]
@ -9076,7 +9124,7 @@ tcl::namespace::eval punk::args {
set vlist_typelist_validate [list]
#reduce our validation requirements by removing values which match defaultval or match -choices
#(could be -multiple with -choicerestricted 0 where some selections match and others don't)
if {$parsekey in $receivednames && $has_choices} {
if {$has_choices && $parsekey in $receivednames} {
#-choices must also work with -multiple
#todo -choicelabels
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
@ -9333,13 +9381,13 @@ tcl::namespace::eval punk::args {
set vlist [list]
set vlist_check_validate [list]
} else {
if {[llength $vlist] && $has_default} {
if {$has_default && [llength $vlist]} {
#defaultval here is a value for the entire clause. (clause usually length 1)
#J2
#set vlist_validate [list]
#set vlist_check_validate [list]
set tp [dict get $thisarg -type]
set clause_size [llength $tp]
#set tp [dict get $thisarg -type]
set clause_size [llength $typelist]
foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist {
#JJJJ
#REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation?
@ -9386,34 +9434,34 @@ tcl::namespace::eval punk::args {
}
}
#is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups
#assert: our vlist & vlist_check lists have been reduced to remove those
if {[llength $vlist] && !$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach clause_value $vlist {
foreach e $clause_value {
if {[punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg
if {[llength $vlist]} {
#is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups
#assert: our vlist & vlist_check lists have been reduced to remove those
if {!$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach clause_value $vlist {
foreach e $clause_value {
if {[punk::ansi::ta::detect $e]} {
set msg "$argclass '$argname' for %caller% contains ansi - but -allow_ansi is false. character-view: '[punk::ansi::ansistring VIEW $e]'"
return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list contentviolation ansi] -badarg $argname -argspecs $argspecs]] $msg
}
}
}
}
}
#puts "argname:$argname v:$v is_default:$is_default"
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
#arguments that are at their default are not subject to type and other checks
#puts "argname:$argname v:$v is_default:$is_default"
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
#arguments that are at their default are not subject to type and other checks
#don't validate defaults or choices that matched
#puts "---> opts_and_values: $opts_and_values"
#puts "===> argname: $argname is_default: $is_default is_choice: $is_choice"
#if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {}
#don't validate defaults or choices that matched
#puts "---> opts_and_values: $opts_and_values"
#puts "===> argname: $argname is_default: $is_default is_choice: $is_choice"
#if {(!$has_choices && !$is_default) || ($has_choices && (!$is_default && !$choices_all_match))} {}
#our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups
#assert [llength $vlist] == [llength $vlist_check]
if {[llength $vlist]} {
#our validation-required list could have been reduced to none e.g if match -default or defined -choices/-choicegroups
#assert [llength $vlist] == [llength $vlist_check]
#$t = clause column
#for {set clausecolumn 0} {$clausecolumn < [llength $typelist]} {incr clausecolumn} {}
@ -9447,37 +9495,37 @@ tcl::namespace::eval punk::args {
}
}
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {[tcl::dict::get $thisarg -multiple]} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list
}
option {
tcl::dict::set opts $argname_or_ident $stripped_list
}
value {
tcl::dict::set values_dict $argname_or_ident $stripped_list
}
}
} else {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0]
}
option {
tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0]
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {$is_multiple} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list
}
option {
tcl::dict::set opts $argname_or_ident $stripped_list
}
value {
tcl::dict::set values_dict $argname_or_ident $stripped_list
}
}
value {
tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0]
} else {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident [lindex $stripped_list 0]
}
option {
tcl::dict::set opts $argname_or_ident [lindex $stripped_list 0]
}
value {
tcl::dict::set values_dict $argname_or_ident [lindex $stripped_list 0]
}
}
}
}
}
}
set finalopts [dict create]

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

@ -126,7 +126,8 @@ tcl::namespace::eval punk::args::tclcore {
# -- --- --- --- ---
proc example {str} {
set str [string trimleft $str \n]
set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Web-gray bold white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]]
#set block [punk::ansi::ansiwrap Web-gray [textblock::frame -ansibase [a+ Term-grey bold term-white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]]
set block [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [a+ Term-grey bold term-white] -ansiborder [a+ black White] -boxlimits {hl} -type block $str]]
set result [textblock::bookend_lines $block [a] "[a defaultbg] [a]"]
#puts $result
return $result

153
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm

@ -702,6 +702,27 @@ namespace eval punk::console {
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
-passthrough -default "none" -choices {none tmux auto} -choicecolumns 1 -choicelabels {
none\
{ ANSI sent without any passthrough wrapping.
A terminal multiplexer such as tmux,screen,zellij may
not pass the request through to the underlying terminal(s)
This is the recommended/normal value for the option.}
tmux\
{ Wrap ANSI sequence with tmux passthrough sequence.
\x1bPtmux\;<originalsequence_with_escapes_doubled>\x1b\\
Note that a tmux session could be connected to multiple
terminals (perhaps of different types) - in which case multiple
responses may be received in a non-deterministic order.
Passthrough should generally be avoided except for debug/test
purposes.
}
auto\
{ Use existence of ::env(TMUX) to detect tmux and
send tmux passthrough sequence.
Not recommended except for debug/test purposes.
}
}
-expected_ms -default 300 -type integer -help\
"Expected number of ms for response from terminal.
100ms is usually plenty for a local terminal and a
@ -731,6 +752,7 @@ namespace eval punk::console {
set expected [dict get $opts -expected_ms]
set ignoreok [dict get $opts -ignoreok]
set returntype [dict get $opts -return]
set passthrough [dict get $opts -passthrough]
set query [dict get $values query]
set capturingendregex [dict get $values capturingendregex]
@ -784,7 +806,7 @@ namespace eval punk::console {
set runningid [lindex $queue 0]
if {$runningid ne $callid} {
set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid)
update ;#REVIEW - probably a bad idea
update ;#REVIEW - possibly a bad idea
after 10
set runningid [lindex $queue 0] ;#jn test
}
@ -836,6 +858,17 @@ namespace eval punk::console {
}
#write before console enableRaw vs after??
#There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it
switch -- $passthrough {
auto {
if {[info exists ::env(TMUX)]} {
set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\"
}
}
tmux {
set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\"
}
}
puts -nonewline $output $query;flush $output
chan configure $input -blocking 0
@ -847,8 +880,10 @@ namespace eval punk::console {
#we should care more about performance in raw mode - as ultimately that's the one we prefer for full features
#------------------
# 1) faster - races?
#first read will read 3 bytes JJJJ
$this_handler $input $callid $capturingendregex
$this_handler $input $callid $capturingendregex
#JJJJ
#$this_handler $input $callid $capturingendregex
if {$ignoreok || $waitvar($callid) ne "ok"} {
chan event $input readable [list $this_handler $input $callid $capturingendregex]
}
@ -1047,7 +1082,11 @@ namespace eval punk::console {
upvar ::punk::console::ansi_response_tsclock tsclock
#endregex should explicitly have a trailing $
set status [catch {read $chan 1} bytes]
if {[string length $chunks($callid)] == 0} {
set status [catch {read $chan 3} bytes]
} else {
set status [catch {read $chan 1} bytes]
}
if { $status != 0 } {
# Error on the channel
chan event $chan readable {}
@ -1290,7 +1329,7 @@ namespace eval punk::console {
"Omit or pass empty string to query current echo state."
}]
proc echo {args} {
set argd [punk::args::parse $args withid ::punk::console::local::echo]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo]
set onoff [dict get $argd values onoff]
set is_windows [string equal "windows" $::tcl_platform(platform)]
@ -1343,6 +1382,7 @@ namespace eval punk::console {
@opts
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-expected_ms -type integer -default 500 -help\
"Number of ms to wait for response"
@values -min 1 -max 1
@ -1356,11 +1396,12 @@ namespace eval punk::console {
lassign [dict values $argd] leaders opts values received
set request [dict get $values request]
set inoutchannels [dict get $opts -terminal]
set passthrough [dict get $opts -passthrough]
set expected [dict get $opts -expected_ms]
set capturingregex {(((.*)))$} ;#capture entire response same as response-payload
set ts_start [clock millis]
set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex]
set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels -passthrough $passthrough $request $capturingregex]
set ts_end [clock millis]
puts stderr $response
set out ""
@ -1781,6 +1822,7 @@ namespace eval punk::console {
}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
@values -min 1 -max 1
mode -type {int|string} -multiple 0 -help\
"integer for DEC mode, or name as in the dict:
@ -1793,10 +1835,11 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc dec_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set mode [dict get $values mode]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set mode [dict get $values mode]
if {[string is integer -strict $mode]} {
set m $mode
@ -1810,7 +1853,7 @@ namespace eval punk::console {
}
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[?$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex]
return $payload
}
@ -1838,7 +1881,7 @@ namespace eval punk::console {
}
#todo - should accept multiple mode nums/names at once
proc dec_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1884,7 +1927,7 @@ namespace eval punk::console {
}]
}
proc dec_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1931,6 +1974,7 @@ namespace eval punk::console {
}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-refresh -type none -help\
"Force a re-test of the mode."
-return -type string -choices {dict result} -default result -choicelabels {
@ -1946,9 +1990,10 @@ namespace eval punk::console {
}]
}
proc dec_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set console [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set num_or_name [dict get $values mode]
set do_refresh [dict exists $received -refresh]
set return [dict get $opts -return]
@ -1964,21 +2009,23 @@ namespace eval punk::console {
}
}
variable dec_has_mode_cache
#make sure we cache on both console and passthrough
set cachekey "$console $passthrough"
if {$do_refresh} {
if {[dict exists $dec_has_mode_cache $console $m]} {
dict unset dec_has_mode_cache $console $m
if {[dict exists $dec_has_mode_cache $cachekey $m]} {
dict unset dec_has_mode_cache $cachekey $m
}
}
if {![dict exists $dec_has_mode_cache $console $m]} {
if {![dict exists $dec_has_mode_cache $cachekey $m]} {
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[?$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex]
#set has_mode [expr {$payload != 0}]
#we can use the payload result as the response as non-zero responses evaluate to true
set has_mode $payload
if {$has_mode ne ""} {
dict set dec_has_mode_cache $console $m $has_mode
dict set dec_has_mode_cache $cachekey $m $has_mode
set source "query"
} else {
#don't cache an empty/failed response - review
@ -1986,7 +2033,7 @@ namespace eval punk::console {
set source "failedquery"
}
} else {
set has_mode [dict get $dec_has_mode_cache $console $m]
set has_mode [dict get $dec_has_mode_cache $cachekey $m]
set source "cache"
}
if {$return eq "dict"} {
@ -2004,6 +2051,7 @@ namespace eval punk::console {
{Show table of DEC modes with basic information.}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-test -type none -help\
"Test current value/support for each mode"
-supported -type none -help\
@ -2013,10 +2061,11 @@ namespace eval punk::console {
"Match code or name"
}]
proc dec_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set do_test [dict exists $received -test]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set do_test [dict exists $received -test]
set only_supported [dict exists $received -supported]
if {[dict exists $values match]} {
set matches [dict get $values match]
@ -2074,7 +2123,7 @@ namespace eval punk::console {
set RST ""
if {$do_test} {
#dec_has_mode can be cached - in which case only 0|3|4 can be relied upon without re-querying
set hasmode_dict [dec_has_mode -console $terminal -return dict $code]
set hasmode_dict [dec_has_mode -console $terminal -passthrough $passthrough -return dict $code]
switch -- [dict get $hasmode_dict result] {
0 {
if {$only_supported} {
@ -2089,7 +2138,7 @@ namespace eval punk::console {
1 - 2 {
if {[dict get $hasmode_dict source] eq "cache"} {
#a terminal query is required
set testresult [dec_get_mode -console $terminal $code]
set testresult [dec_get_mode -console $terminal -passthrough $passthrough $code]
} else {
set testresult [dict get $hasmode_dict result]
if {![string is integer -strict $testresult]} {
@ -2135,7 +2184,7 @@ namespace eval punk::console {
} else {
if {$only_supported} {
#dec_has_mode still queries terminal - but is cached if a response was received
if {[dec_has_mode -console $terminal $code] == 0} {
if {[dec_has_mode -console $terminal -passthrough $passthrough $code] == 0} {
continue
}
}
@ -2184,6 +2233,7 @@ namespace eval punk::console {
source indicates whether the result came
from query or cache."
}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
@values -min 1 -max 1
mode -type {int|string} -help\
"integer for ANSI mode, or name as in the dict:
@ -2191,12 +2241,13 @@ namespace eval punk::console {
}]
}
proc ansi_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set console [dict get $opts -console]
set num_or_name [dict get $values mode]
set return [dict get $opts -return]
set do_refresh [dict exists $received -refresh]
set return [dict get $opts -return]
set passthrough [dict get $opts -passthrough]
set do_refresh [dict exists $received -refresh]
if {[string is integer -strict $num_or_name]} {
set m $num_or_name
@ -2209,20 +2260,22 @@ namespace eval punk::console {
}
}
variable ansi_has_mode_cache
#make sure we cache on both console and passthrough
set cachekey "$console $passthrough"
if {$do_refresh} {
if {[dict exists $ansi_has_mode_cache $console $m]} {
dict unset ansi_has_mode_cache $console $m
if {[dict exists $ansi_has_mode_cache $cachekey $m]} {
dict unset ansi_has_mode_cache $cachekey $m
}
}
if {![dict exists $ansi_has_mode_cache $console $m]} {
if {![dict exists $ansi_has_mode_cache $cachekey $m]} {
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex]
#set has_mode [expr {$payload != 0}]
set has_mode $payload
if {$has_mode ne ""} {
dict set ansi_has_mode_cache $console $m $has_mode
dict set ansi_has_mode_cache $cachekey $m $has_mode
set source "query"
} else {
#don't cache an empty/failed response - review
@ -2230,7 +2283,7 @@ namespace eval punk::console {
set source "failedquery"
}
} else {
set has_mode [dict get $ansi_has_mode_cache $console $m]
set has_mode [dict get $ansi_has_mode_cache $cachekey $m]
set source "cache"
}
if {$return eq "dict"} {
@ -2261,7 +2314,7 @@ namespace eval punk::console {
}]
}
proc ansi_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2308,7 +2361,7 @@ namespace eval punk::console {
}]
}
proc ansi_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2361,6 +2414,7 @@ namespace eval punk::console {
}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
@values -min 1 -max 1
mode -type {int|string} -multiple 0 -help\
"integer for ANSI mode, or name as in the dict:
@ -2373,10 +2427,11 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc ansi_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set mode [dict get $values mode]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set mode [dict get $values mode]
if {[string is integer -strict $mode]} {
set m $mode
@ -2390,7 +2445,7 @@ namespace eval punk::console {
}
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex]
return $payload
}
#todo ansi_unset_mode
@ -2404,6 +2459,7 @@ namespace eval punk::console {
{Show table of ANSI modes with basic information.}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-test -type none -help\
"Test current value/support for each mode"
-supported -type none -help\
@ -2413,10 +2469,11 @@ namespace eval punk::console {
"Match code or name"
}]
proc ansi_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set do_test [dict exists $received -test]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set do_test [dict exists $received -test]
if {[dict exists $values match]} {
set matches [dict get $values match]
} else {
@ -2500,7 +2557,7 @@ namespace eval punk::console {
set reset_state_colour ""
set RST ""
if {$do_test} {
set hasmode_dict [ansi_has_mode -console $terminal -return dict $code]
set hasmode_dict [ansi_has_mode -console $terminal -passthrough $passthrough -return dict $code]
switch -- [dict get $hasmode_dict result] {
0 {
if {$only_supported} {
@ -2515,7 +2572,7 @@ namespace eval punk::console {
1 - 2 {
if {[dict get $hasmode_dict source] eq "cache"} {
#a terminal query is required
set testresult [ansi_get_mode -console $terminal $code]
set testresult [ansi_get_mode -console $terminal -passthrough $passthrough $code]
} else {
set testresult [dict get $hasmode_dict result]
if {![string is integer -strict $testresult]} {
@ -2561,7 +2618,7 @@ namespace eval punk::console {
} else {
if {$only_supported} {
#ansi_has_mode still queries terminal - but is cached if a response was received
if {[ansi_has_mode -console $terminal $code] == 0} {
if {[ansi_has_mode -console $terminal -passthrough $passthrough $code] == 0} {
continue
}
}
@ -2659,7 +2716,7 @@ namespace eval punk::console {
name -type string
}]
proc dec_request_setting {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_request_setting]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting]
lassign [dict values $argd] leaders opts values
set console [dict get $opts -console]
set name [dict get $values name]

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

@ -1355,14 +1355,18 @@ tcl::namespace::eval punk::ns {
set a [a+ bold purple]
set e [a+ bold yellow]
set p [a+ bold white]
set c_nat [a+ web-gray] ;#native
set c_int [a+ web-orange] ;#interps
set c_cor [a+ web-hotpink] ;#coroutines
#set c_nat [a+ web-gray] ;#native
set c_nat [a+ term-silver] ;#native
set c_int [a+ term-orange1] ;#interps
set c_cor [a+ term-hotpink] ;#coroutines
set c_ooo [a+ bold cyan] ;#object
set c_ooc [a+ web-aquamarine] ;#class
set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_zst [a+ web-yellow] ;#zlibstreams
#set c_ooc [a+ web-aquamarine] ;#class
set c_ooc [a+ term-aqua] ;#class
#set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooO [a+ term-purple-c] ;#privateObject
#set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_ooC [a+ term-cornflowerblue] ;#privateClass
set c_zst [a+ term-yellow] ;#zlibstreams
set a1 [a][a+ cyan]
foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 {
@ -6629,16 +6633,16 @@ y" {return quirkykeyscript}
switch -- $syntax {
basic {
#rudimentary colourising only
set argl [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl]
set argl [punk::ansi::grepstr -return all -highlight term-teal {\{|\}} $argl]
set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon
set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon
##set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $body]
set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body]
set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body]
set body [punk::ansi::grepstr -return all -highlight tk-orange {\[|\]} $body]
set body [punk::ansi::grepstr -return all -highlight term-teal {^(\{)|[^\\](\{+)} $body]
set body [punk::ansi::grepstr -return all -highlight term-teal {[^\\](\}+)} $body]
set body [punk::ansi::grepstr -return all -highlight term-orange {\[|\]} $body]
}
default {
set is_highlighted 0

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

@ -1497,7 +1497,7 @@ tcl::namespace::eval textblock {
} elseif {$span > 0} {
#ok to reset to higher val immediately or after an any and any number of following zeros
if {$span > ($numcols - $sidx)} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview"
}
set remaining $span
@ -1508,7 +1508,7 @@ tcl::namespace::eval textblock {
} else {
if {$span eq "0"} {
if {$remaining eq "0"} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview"
} else {
incr remaining -1
@ -1517,7 +1517,7 @@ tcl::namespace::eval textblock {
if {$remaining eq "0"} {
#ok for new span value of any or > 0
if {$span ne "any" && $span > ($numcols - $sidx)} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview"
}
set remaining $span
@ -1525,7 +1525,7 @@ tcl::namespace::eval textblock {
incr remaining -1
}
} else {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview"
}
}
@ -2926,7 +2926,7 @@ tcl::namespace::eval textblock {
$htable add_row [list "$hnum " $h "${width}x${height}" $s]
incr hnum
}
$htable configure_column 0 -ansibase [a+ web-dimgray]
$htable configure_column 0 -ansibase [a+ term-grey]
tcl::dict::set col_header_tables $col $htable
set colwidths [$htable column_widths]
set icol 0
@ -4294,7 +4294,8 @@ tcl::namespace::eval textblock {
set ecat [tcl::dict::create]
set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra]
set ansi [a+ {*}$fc web-black Web-gold]
#set ansi [a+ {*}$fc web-black Web-gold]
set ansi [a+ {*}$fc term-black Term-gold1]
set val [list ansi $ansi cat alkaline_earth]
foreach e $cat_alkaline_earth {
tcl::dict::set ecat $e $val
@ -4302,7 +4303,7 @@ tcl::namespace::eval textblock {
set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I]
#set ansi [a+ {*}$fc web-black Web-lightgreen]
set ansi [a+ {*}$fc black Term-113]
set ansi [a+ {*}$fc term-black Term-113]
set val [list ansi $ansi cat reactive_nonmetal]
foreach e $cat_reactive_nonmetal {
tcl::dict::set ecat $e $val
@ -4310,7 +4311,7 @@ tcl::namespace::eval textblock {
set cat [list Li Na K Rb Cs Fr]
#set ansi [a+ {*}$fc web-black Web-Khaki]
set ansi [a+ {*}$fc black Term-lightgoldenrod2]
set ansi [a+ {*}$fc term-black Term-lightgoldenrod2]
set val [list ansi $ansi cat alkali_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4318,14 +4319,16 @@ tcl::namespace::eval textblock {
set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs]
#set ansi [a+ {*}$fc web-black Web-lightsalmon]
set ansi [a+ {*}$fc black Term-orange1]
set ansi [a+ {*}$fc term-black Term-salmon1]
set val [list ansi $ansi cat transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list Al Ga In Sn Tl Pb Bi Po]
set ansi [a+ {*}$fc web-black Web-lightskyblue]
#set ansi [a+ {*}$fc web-black Web-lightskyblue]
set ansi [a+ {*}$fc term-black Term-lightsteelblue]
set val [list ansi $ansi cat post_transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4333,21 +4336,25 @@ tcl::namespace::eval textblock {
set cat [list B Si Ge As Sb Te At]
#set ansi [a+ {*}$fc web-black Web-turquoise]
set ansi [a+ {*}$fc black Brightcyan]
#set ansi [a+ {*}$fc black Brightcyan]
set ansi [a+ {*}$fc term-black Term-skyblue1]
set val [list ansi $ansi cat metalloids]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list He Ne Ar Kr Xe Rn]
set ansi [a+ {*}$fc web-black Web-orchid]
#set ansi [a+ {*}$fc web-black Web-orchid]
set ansi [a+ {*}$fc term-black Term-purple-c]
set val [list ansi $ansi cat noble_gases]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr]
set ansi [a+ {*}$fc web-black Web-plum]
#set ansi [a+ {*}$fc web-black Web-plum]
set ansi [a+ {*}$fc term-black Term-plum1]
set val [list ansi $ansi cat actinoids]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4361,7 +4368,8 @@ tcl::namespace::eval textblock {
tcl::dict::set ecat $e $val
}
set ansi [a+ {*}$fc web-black Web-whitesmoke]
#set ansi [a+ {*}$fc web-black Web-whitesmoke]
set ansi [a+ {*}$fc term-black Term-silver]
set val [list ansi $ansi cat other]
foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] {
tcl::dict::set ecat $e $val
@ -4807,7 +4815,7 @@ tcl::namespace::eval textblock {
123456789ABCDEF
"
-size -type integer\
-default 15\
-default 16\
-optional 1\
-range {1 ""}
-direction -default horizontal\
@ -4818,6 +4826,7 @@ tcl::namespace::eval textblock {
the colour stripes will be oriented
in this direction.
"
-noreset -type none
@values -min 0 -max 1
colour -type list -default {} -optional 1 -help\
"List of Ansi colour names
@ -4832,8 +4841,10 @@ tcl::namespace::eval textblock {
proc testblock {args} {
set argd [punk::args::parse $args withid ::textblock::testblock]
set colour [dict get $argd values colour]
set size [dict get $argd opts -size]
lassign [dict values $argd] leaders opts values received
set colour [dict get $values colour]
set size [dict get $opts -size]
set noreset [dict exists $received -noreset]
set rainbow_list [list]
lappend rainbow_list {30 47} ;#black White
@ -4879,7 +4890,7 @@ tcl::namespace::eval textblock {
set longbows [concat {*}[lrepeat $numsets $rainbow_list]]
set rainbow_list [lrange $longbows 0 $size-1]
}
if {"noreset" in $colour} {
if {$noreset} {
set RST ""
} else {
set RST [a]
@ -4896,7 +4907,7 @@ tcl::namespace::eval textblock {
set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi]
lappend clist ${ansicode}$c$RST
}
if {"noreset" in $colour} {
if {$noreset} {
return [textblock::join_basic -ansiresets 0 -- {*}$clist]
} else {
#return [textblock::join_basic -- {*}$clist]
@ -4935,6 +4946,7 @@ tcl::namespace::eval textblock {
for {set r 0} {$r < $size} {incr r} {
append block [::join $charsubset ""] \n
}
set block [tcl::string::trimright $block \n]
if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
@ -5642,22 +5654,22 @@ tcl::namespace::eval textblock {
set headers [list]
set blocks [list]
lappend blocks "[textblock::testblock 4 rainbow]"
lappend blocks "[textblock::testblock -size 4 rainbow]"
lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing"
lappend blocks "[textblock::testblock 4 rainbow][a]"
lappend blocks "[textblock::testblock -size 4 rainbow][a]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset"
lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 rainbow]\n[a+ Term-green]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]"
lappend headers "rainbow 4x4\nno line resets\nnothing trailing"
lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}][a]"
lappend headers "rainbow 4x4\nno line resets\ntrailing reset"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]\n[a+ Term-green]"
lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg"
set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers]
@ -5665,13 +5677,13 @@ tcl::namespace::eval textblock {
proc pad_example2 {} {
set headers [list]
set blocks [list]
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n"
lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl"
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]"
lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a]"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset"
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]"
lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a+ Term-green]"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg"
set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers]
@ -6113,14 +6125,15 @@ tcl::namespace::eval textblock {
proc welcome_test {} {
package require punk::ansi
package require patternpunk
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]]
set ansi [textblock::join -- " " [punk::ansi::ansicat -dimensions 80x8 src/testansi/publicdomain/roysac/ROY-WELC.ANS]]
# Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com
set table [[textblock::spantest] print]
set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
#set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ term-yellow][>punk . rhs][a]
set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks]
set testblock [textblock::testblock -size 15 rainbow]
set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ term-orange1] $contents]
}
@ -7831,7 +7844,7 @@ tcl::namespace::eval textblock {
}
}
proc frame_cache {args} {
set argd [punk::args::parse $args withid ::textblock::frame_cache]
set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache]
set action [dict get $argd values action]
variable frame_cache
set all_values_dict [dict get $argd values]
@ -8350,13 +8363,14 @@ tcl::namespace::eval textblock {
set usecache 0
#set buildcache 0 ;#comment out for debug/analysis so we can see
#puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'"
set cache_key [a+ Web-red web-white]$cache_key[a]
set cache_key [a+ Term-red term-white]$cache_key[a]
}
if {$buildcache && ($actual_contentwidth < $frame_inner_width)} {
#colourise cache_key to warn
if {$actual_contentwidth == 0} {
#we can still substitute with right length
set cache_key [a+ Web-steelblue web-black]$cache_key[a]
#set cache_key [a+ Web-steelblue term-black]$cache_key[a]
set cache_key [a+ Term-cornflowerblue term-black]$cache_key[a]
} else {
#actual_contentwidth is narrower than frame - check template's patternwidth
if {[tcl::dict::exists $frame_cache $cache_key]} {
@ -8366,13 +8380,13 @@ tcl::namespace::eval textblock {
}
if {$actual_contentwidth < $cache_patternwidth} {
set usecache 0
set cache_key [a+ Web-orange web-black]$cache_key[a]
set cache_key [a+ Term-orange1 term-black]$cache_key[a]
} elseif {$actual_contentwidth == $cache_patternwidth} {
#set usecache 1
} else {
#actual_contentwidth > pattern
set usecache 0
set cache_key [a+ Web-red web-black]$cache_key[a]
set cache_key [a+ Term-red term-black]$cache_key[a]
}
}
}

BIN
src/vendormodules_tcl8/Thread-2.8.9.tm

Binary file not shown.

BIN
src/vendormodules_tcl8/Thread/platform/win32_x86_64_tcl8-2.8.9.tm

Binary file not shown.

7
src/vendormodules_tcl8/include_modules.config

@ -1,7 +1,10 @@
# c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread\
# c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread::platform::win32_x86_64_tcl8
set local_modules [list\
c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread\
c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread::platform::win32_x86_64_tcl8\
]

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

@ -296,6 +296,27 @@ namespace eval argparsingtest {
return [tcl::dict::get $argd opts]
}
proc test1_punkargs_any {args} {
set argd [punk::args::parse $args withdef {
@id -id ::argparsingtest::test1_punkargs
@cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@opts -anyopts 0
-return -default string -type any
-frametype -default \uFFEF -type any
-show_edge -default \uFFEF -type any
-show_seps -default \uFFEF -type any
-join -type none -multiple 1
-x -default "" -type any
-y -default b -type any
-z -default c -type any
-1 -default 1 -type boolean
-2 -default 2 -type integer
-3 -default 3 -type integer
@values
}]
return [tcl::dict::get $argd opts]
}
punk::args::define {
@id -id ::argparsingtest::test1_punkargs_by_id
@cmd -name argtest4 -help "test of punk::args::parse comparative performance"
@ -318,7 +339,6 @@ namespace eval argparsingtest {
return [tcl::dict::get $argd opts]
}
}
proc test1_punkargs_parsecache {args} {
set argd [punk::args::parse $args -cache 1 withid ::argparsingtest::test1_punkargs_by_id]
return [tcl::dict::get $argd opts]

BIN
src/vfs/_vfscommon.vfs/modules/gridplus-2.12b0.tm

Binary file not shown.

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

@ -3367,7 +3367,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
@values -min 0 -max 0
}]
proc sgr_cache {args} {
set argd [punk::args::parse $args withid ::punk::ansi::sgr_cache]
set argd [punk::args::parse $args -cache 1 withid ::punk::ansi::sgr_cache]
set action [dict get $argd opts -action]
set pretty [dict get $argd opts -pretty]

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

@ -373,9 +373,9 @@ tcl::namespace::eval ::punk::args::helpers {
#Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between
# the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems.
set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {^\{|[^\\](\{+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-navy} {[^\\](\}+)} $str]
set str [punk::ansi::grepstr -return all -highlight {Term-grey term-olive} {\[|\]} $str]
#puts stderr -------------------
#puts $str
#puts stderr -------------------
@ -1074,7 +1074,7 @@ tcl::namespace::eval punk::args {
variable id_cache_rawdef
set defspace ""
if {[dict exists $rawdef_cache_about $args]} {
set cinfo [dict get $rawdef_cache_about $args]
set cinfo [dict get $rawdef_cache_about $args]
set id [dict get $cinfo -id]
set is_dynamic [dict get $cinfo -dynamic]
if {[dict exists $cinfo -defspace]} {
@ -3165,7 +3165,7 @@ tcl::namespace::eval punk::args {
#test the rawdef for @dynamic directive
proc rawdef_is_dynamic {rawdef} {
#temporary - old way
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]} ]
set flagged_dynamic [expr {[lindex $rawdef 0] eq "-dynamic" && [lindex $rawdef 1]}]
if {$flagged_dynamic} {
return true
}
@ -3534,7 +3534,7 @@ tcl::namespace::eval punk::args {
#puts "-->$cmdinfo"
#puts "-->[tcl::info::frame -3]"
set maxloop 10 ;#failsafe
while {[string last \n $cmdinfo] >= 1 && $maxloop > -1} {
while {$maxloop > -1 && [string last \n $cmdinfo] >= 1} {
#looks like a script - haven't gone up far enough?
#(e.g patternpunk oo system: >punk . poses -invalidoption)
incr call_level -1
@ -3920,7 +3920,7 @@ tcl::namespace::eval punk::args {
if {$use_table} {
append errmsg \n
} else {
if {($returntype in {table tableobject}) && !$has_textblock} {
if {!$has_textblock && ($returntype in {table tableobject})} {
append errmsg \n "$CLR(errormsg)(layout package textblock is missing)$RST" \n
} else {
append errmsg \n
@ -5063,7 +5063,6 @@ tcl::namespace::eval punk::args {
variable parse_cache [dict create]
proc parse {args} {
#puts "punk::args::parse --> '$args'"
set tailtype "" ;#withid|withdef
if {[llength $args] < 3} {
#error "punk::args::parse - invalid call. < 3 args"
punk::args::parse $args -cache 1 withid ::punk::args::parse
@ -5092,31 +5091,13 @@ tcl::namespace::eval punk::args {
}
}
#set values [lrange $opts_and_vals $i end]
set values $opts_and_vals
#set values $opts_and_vals
#puts "---values: $values"
set tailtype [lindex $values 0]
set tailargs [lrange $values 1 end]
#set split [lsearch -exact $tailargs withid]
#if {$split < 0} {
# set split [lsearch -exact $tailargs withdef]
# if {$split < 0} {
# #punk::args::usage arg_error?
# #error "punk::args::parse - invalid call. keyword withid|withdef required"
# punk::args::parse $args withid ::punk::args::parse
# } else {
# set tailtype withdef
#}
#} else {
# set tailtype withid
#}
#set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here.
#set tailtype [lindex $values 0] ;#withid|withdef
#set tailargs [lrange $values 1 end]
set tailtype [lpop opts_and_vals 0]
#if {[llength $opts] % 2} {
#error "punk::args::parse Even number of -flag val pairs required after arglist"
#}
#Default the -errorstyle to standard
# (slow on unhappy path - but probably clearest for playing with new APIs interactively)
@ -5145,25 +5126,22 @@ tcl::namespace::eval punk::args {
}
switch -- $tailtype {
withid {
if {[llength $tailargs] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
set id [lindex $tailargs 0]
#puts stdout "punk::args::parse [llength $parseargs] args withid $id, options: $opts"
#puts stdout "punk::args::parse '$parseargs' withid $id, options: $opts"
set deflist [raw_def $id]
#JJJ
#set id [lindex $opts_and_vals 0]
set deflist [raw_def [lindex $opts_and_vals 0]]
if {[llength $deflist] == 0} {
if {[llength $opts_and_vals] != 1} {
#error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'"
punk::args::parse $args withid ::punk::args::parse
}
error "punk::args::parse - no such id: $id"
}
}
withdef {
set deflist $tailargs
set deflist $opts_and_vals
if {[llength $deflist] < 1} {
error "punk::args::parse - invalid call. Expected at least one argument after 'withdef'"
}
#puts stdout "punk::args::parse [llength $parseargs] args with [llength $deflist] definition blocks, options: $opts"
#puts stdout "punk::args::parse '$parseargs' with [llength $deflist] definition blocks, options: $opts"
}
default {
error "punk::args::parse - invalid call. Argument following arglist was '$tailtype'. Must be 'withid' or 'withdef'"
@ -7505,12 +7483,12 @@ tcl::namespace::eval punk::args {
proc get_dict {deflist rawargs args} {
#see arg_error regarding considerations around unhappy-path performance
if {![punk::args::lib::string_is_dict $args]} {
error "punk::args::get_dict args must be a dict of option value pairs"
}
set defaults [dict create\
-form *\
]
#if {![punk::args::lib::string_is_dict $args]} {
# error "punk::args::get_dict args must be a dict of option value pairs"
#}
set proc_opts [dict merge $defaults $args]
dict for {k v} $proc_opts {
switch -- $k {
@ -7566,12 +7544,18 @@ tcl::namespace::eval punk::args {
#define will either return a permanently cached argspecs (-dynamic 0) - or
# use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs.
set argspecs [uplevel 1 [list ::punk::args::resolve {*}$deflist]]
#argspecs keys: id cmd_info doc_info package_info seealso_info instance_info keywords_info examples_info id_info FORMS form_names form_info
# -----------------------------------------------
# Warning - be aware of all vars thrown into this space (from tail end of 'definition' proc)
tcl::dict::with argspecs {} ;#turn keys into vars
#tcl::dict::with argspecs {} ;#turn keys into vars
#e.g id,FORMS,cmd_info,doc_info,package_info,seealso_info, instance_info,id_info,form_names
# -----------------------------------------------
#we don't need all keys from argspecs - even if retrieving multiple as vars, generally faster than dict with
set FORMS [dict get $argspecs FORMS]
set form_names [dict get $argspecs form_names]
set opt_form [dict get $proc_opts -form]
if {$opt_form eq "*"} {
set selected_forms $form_names
@ -7606,8 +7590,51 @@ tcl::namespace::eval punk::args {
#todo - handle multiple fids?
set fid [lindex $selected_forms 0]
set formdict [dict get $FORMS $fid]
tcl::dict::with formdict {}
#populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
# formdict keys: argspace ARG_INFO ARG_CHECKS LEADER_DEFAULTS LEADER_REQUIRED
# LEADER_NAMES LEADER_MIN LEADER_MAX LEADER_TAKEWHENARGSMODULO LEADER_UNNAMED
# LEADERSPEC_DEFAULTS LEADER_CHECKS_DEFAULTS OPT_DEFAULTS OPT_REQUIRED OPT_NAMES
# OPT_ANY OPT_MIN OPT_MAX OPT_SOLOS OPTSPEC_DEFAULTS OPT_CHECKS_DEFAULTS OPT_GROUPS
# VAL_DEFAULTS VAL_REQUIRED VAL_NAMES VAL_MIN VAL_MAX VAL_UNNAMED VALSPEC_DEFAULTS
# VAL_CHECKS_DEFAULTS FORMDISPLAY
#tcl::dict::with formdict {}
##populate vars ARG_INFO,LEADER_MAX,LEADER_NAMES etc
#individual var extraction is faster than 'dict with' - even though we need nearly every key
set ARG_INFO [dict get $formdict ARG_INFO]
set ARG_CHECKS [dict get $formdict ARG_CHECKS]
set LEADER_DEFAULTS [dict get $formdict LEADER_DEFAULTS]
set LEADER_REQUIRED [dict get $formdict LEADER_REQUIRED]
set LEADER_NAMES [dict get $formdict LEADER_NAMES]
set LEADER_MIN [dict get $formdict LEADER_MIN]
set LEADER_MAX [dict get $formdict LEADER_MAX]
set LEADER_TAKEWHENARGSMODULO [dict get $formdict LEADER_TAKEWHENARGSMODULO]
set LEADER_UNNAMED [dict get $formdict LEADER_UNNAMED]
set LEADERSPEC_DEFAULTS [dict get $formdict LEADERSPEC_DEFAULTS]
set LEADER_CHECKS_DEFAULTS [dict get $formdict LEADER_CHECKS_DEFAULTS]
set OPT_DEFAULTS [dict get $formdict OPT_DEFAULTS]
set OPT_REQUIRED [dict get $formdict OPT_REQUIRED]
set OPT_NAMES [dict get $formdict OPT_NAMES]
set OPT_ANY [dict get $formdict OPT_ANY]
#set OPT_MIN [dict get $formdict OPT_MIN]
set OPT_MAX [dict get $formdict OPT_MAX]
#set OPT_SOLOS [dict get $formdict OPT_SOLOS]
set OPTSPEC_DEFAULTS [dict get $formdict OPTSPEC_DEFAULTS]
set OPT_CHECKS_DEFAULTS [dict get $formdict OPT_CHECKS_DEFAULTS]
#set OPT_GROUPS [dict get $formdict OPT_GROUPS]
set VAL_DEFAULTS [dict get $formdict VAL_DEFAULTS]
set VAL_REQUIRED [dict get $formdict VAL_REQUIRED]
set VAL_NAMES [dict get $formdict VAL_NAMES]
set VAL_MIN [dict get $formdict VAL_MIN]
set VAL_MAX [dict get $formdict VAL_MAX]
set VAL_UNNAMED [dict get $formdict VAL_UNNAMED]
set VALSPEC_DEFAULTS [dict get $formdict VALSPEC_DEFAULTS]
set VAL_CHECKS_DEFAULTS [dict get $formdict VAL_CHECKS_DEFAULTS]
set FORMDISPLAY [dict get $formdict FORMDISPLAY]
if {$VAL_MIN eq ""} {
set valmin 0
#set VAL_MIN 0
@ -7615,9 +7642,9 @@ tcl::namespace::eval punk::args {
# todo variable clause lengths (items marked optional in types using leading&trailing questionmarks)
# e.g -types {a ?xxx?}
#this has one required and one optional
set typelist [dict get $ARG_INFO $v -type]
set clause_length 0
foreach t $typelist {
#for each t in typelist
foreach t [dict get $ARG_INFO $v -type] {
if {![string match {\?*\?} $t]} {
incr clause_length
}
@ -7659,8 +7686,7 @@ tcl::namespace::eval punk::args {
#REVIEW - what about optional members in leaders e.g -type {int ?double?}
set named_leader_args_max 0
foreach ln $LEADER_NAMES {
set typelist [dict get $ARG_INFO $ln -type]
incr named_leader_args_max [llength $typelist]
incr named_leader_args_max [llength [dict get $ARG_INFO $ln -type]]
}
#set id [dict get $argspecs id]
@ -7670,7 +7696,7 @@ tcl::namespace::eval punk::args {
#}
set can_have_leaders 1 ;#default assumption
if {$LEADER_MAX == 0 || ([llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED)} {
if {$LEADER_MAX == 0 || (!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0)} {
set can_have_leaders 0
}
@ -7769,7 +7795,7 @@ tcl::namespace::eval punk::args {
if {$OPT_MAX ne "0"} {
foreach t $leader_type {
set raw [lindex $rawargs $tentative_idx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set flagname $raw
if {[string match --* $raw]} {
@ -7861,7 +7887,7 @@ tcl::namespace::eval punk::args {
# and only for the last defined leader. This should be done in the definition parsing - not here.
foreach t $leader_type {
set raw [lindex $rawargs $ridx]
if {[string match {\?*\?} $t] && [string match -* $raw]} {
if {[string match -* $raw] && [string match {\?*\?} $t]} {
#review - limitation of optional leaders is they can't be same value as any defined flags/opts
set matchopt [::tcl::prefix::match -error {} $all_opts $raw]
@ -7952,7 +7978,7 @@ tcl::namespace::eval punk::args {
set leadermin $LEADER_MIN
}
if {$LEADER_MAX eq ""} {
if {[llength $LEADER_NAMES] == 0 && !$LEADER_UNNAMED} {
if {!$LEADER_UNNAMED && [llength $LEADER_NAMES] == 0} {
set leadermax 0
} else {
set leadermax -1
@ -7962,7 +7988,7 @@ tcl::namespace::eval punk::args {
}
if {$VAL_MAX eq ""} {
if {[llength $VAL_NAMES] == 0 && !$VAL_UNNAMED} {
if {!$VAL_UNNAMED && [llength $VAL_NAMES] == 0} {
set valmax 0
} else {
set valmax -1
@ -7974,7 +8000,10 @@ tcl::namespace::eval punk::args {
#assert leadermax leadermin are numeric
#assert - remaining_rawargs has been reduced by leading positionals
set opts [dict create] ;#don't set to OPT_DEFAULTS here
#beware - opts not a true dict - may need repeated values to maintain ordering - last one wins (when not -multiple true)
#set opts [dict create] ;#don't set to OPT_DEFAULTS here
set opts [list]
set leaders [list]
set arglist {}
@ -8002,47 +8031,60 @@ tcl::namespace::eval punk::args {
break
}
set a [lindex $remaining_rawargs $i]
switch -glob -- $a {
-- {
if {$a in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
}
--* {
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
set a1 [string index $a 0]
set a2 [string index $a 1]
if {$a1 eq "-"} {
if {$a2 eq "-"} {
if {$a eq "--"} {
if {"--" in $OPT_NAMES} {
#treat this as eopts - we don't care if remainder look like options or not
lappend flagsreceived --
set arglist [lrange $remaining_rawargs 0 $i]
set post_values [lrange $remaining_rawargs $i+1 end]
} else {
#assume it's a value.
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
}
break
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
#--*
set eposn [string first = $a]
if {$eposn > 2} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#flagsupplied may still be a 'short form/prefix'
set flagsupplied [string range $a 0 $eposn-1]
set flagval [string range $a $eposn+1 end]
set flagval_included true
} else {
set flagsupplied $a
set flagval ""
set flagval_included false
}
}
}
-* {
} else {
#-*
set flagsupplied $a
set flagval ""
set flagval_included false
}
default {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
} else {
#not a flag/option
set arglist [lrange $remaining_rawargs 0 $i-1]
set post_values [lrange $remaining_rawargs $i end]
break
}
#switch -glob -- $a {
# -- {
# }
# --* {
# }
# -* {
# }
# default {
# }
#}
#flagsupplied when --longopt=x is --longopt (may still be a prefix)
#get full flagname from possible prefix $flagsupplied
set flagname [tcl::prefix match -error "" [list {*}$all_opts --] $flagsupplied]
@ -8212,7 +8254,7 @@ tcl::namespace::eval punk::args {
} else {
#tcl::dict::set opts $flag_ident $flagval
if {$flag_ident_is_parsekey} {
#necessary shimmer
#necessary shimmer ?
lappend opts $flag_ident $flagval
} else {
tcl::dict::set opts $flag_ident $flagval
@ -8277,7 +8319,7 @@ tcl::namespace::eval punk::args {
#exlude argument with whitespace from being a possible option e.g dict
#todo - passthrough of unrecognised --longopt=xxx without looking for following flag-value
set eposn [string first = $a]
if {[string match --* $a] && $eposn > 2} {
if {$eposn > 2 && [string match --* $a]} {
#only allow longopt-style = for double leading dash longopts
#--*=<val
#undefined_flagsupplied may still be a 'short form/prefix'
@ -8374,6 +8416,8 @@ tcl::namespace::eval punk::args {
#set values [list {*}$pre_values {*}$remaining_rawargs] ;#no -flags detected
set arglist [list]
}
#set id [dict get $argspecs id]
#if {$id eq "::if"} {
#puts stderr "::if"
@ -8408,7 +8452,7 @@ tcl::namespace::eval punk::args {
# }
#}
#puts ">>>>==== $opts"
#puts ">>>>====opts: $opts"
set seen_pks [list]
#treating opts as list for this loop.
foreach optset $OPT_NAMES {
@ -8526,18 +8570,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $leadername -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $leadername -optional]} {
puts stderr "get_dict cannot assign val:$ldr to leadername:$leadername leaders:$leaders (111)"
#return -options [list -code error -errorcode [list PUNKARGS UNCONSUMED -argspecs $argspecs]] "_get_dict_can_assign_value consumed 0 unexpected 1?"
incr ldridx -1
set leadername_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$leadername ni $leadernames_received} {
#puts stderr "_get_dict_can_assign_value $ldridx $values $nameidx $VAL_NAMES"
set msg "Bad number of leaders for %caller%. Not enough remaining values to assign to required arguments (fail on $leadername)."
@ -8643,7 +8685,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could use break?
continue
}
if {$leadername ni $leadernames_received && ![dict exists $LEADER_DEFAULTS $leadername]} {
if {![dict exists $LEADER_DEFAULTS $leadername] && $leadername ni $leadernames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'leaders' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset leaders_dict $leadername
@ -8683,18 +8725,16 @@ tcl::namespace::eval punk::args {
set consumed [dict get $assign_d consumed]
set resultlist [dict get $assign_d resultlist]
set newtypelist [dict get $assign_d typelist]
if {[tcl::dict::get $argstate $valname -optional]} {
if {$consumed == 0} {
if {$consumed == 0} {
if {[tcl::dict::get $argstate $valname -optional]} {
#error 333
puts stderr "get_dict cannot assign val:$val to valname:$valname (333)"
incr validx -1
set valname_multiple ""
incr nameidx
continue
}
} else {
#required named arg
if {$consumed == 0} {
} else {
#required named arg
if {$valname ni $valnames_received} {
#puts stderr "_get_dict_can_assign_value $validx $values $nameidx $VAL_NAMES"
set msg "Bad number of values for %caller%. Not enough remaining values to assign to required arguments (fail on $valname)."
@ -8796,7 +8836,7 @@ tcl::namespace::eval punk::args {
#review - always trailing - could break?
continue
}
if {$vname ni $valnames_received && ![dict exists $VAL_DEFAULTS $vname]} {
if {![dict exists $VAL_DEFAULTS $vname] && $vname ni $valnames_received} {
#remove the name with empty-string default we used to establish fixed order of names
#The 'values' key in the final result shouldn't contain an entry for an argument that wasn't received and had no default.
dict unset values_dict $vname
@ -8923,6 +8963,9 @@ tcl::namespace::eval punk::args {
#puts " >>>>>>> ---lookup_optset :$lookup_optset"
#puts "---argstate:$argstate"
#JJJ argname_or_ident; ident example: -increasing|-SORTOPTION
#review - ensure all possible keys present in thisarg_keys
tcl::dict::for {argname_or_ident value_group} $opts_and_values {
#
#parsekey: key used in resulting leaders opts values dictionaries
@ -8972,21 +9015,24 @@ tcl::namespace::eval punk::args {
#an example argname_or_compound for the above might be: -path|--filename
# where -path is the expanded form of the actual flag used (could have been for example just -p) and --filename is the parsekey
set thisarg_checks [tcl::dict::get $arg_checks $argname]
set thisarg [tcl::dict::get $argstate $argname]
#set thisarg_keys [tcl::dict::keys $thisarg]
set thisarg_checks [tcl::dict::get $arg_checks $argname]
#using unset -nocomplain, and dict with to dump thisarg vars is *much* slower than just pulling out each var from dict
set typelist [tcl::dict::get $thisarg -type]
set is_multiple [tcl::dict::get $thisarg -multiple]
set is_allow_ansi [tcl::dict::get $thisarg -allow_ansi]
set is_validate_ansistripped [tcl::dict::get $thisarg -validate_ansistripped]
set is_strip_ansi [tcl::dict::get $thisarg -strip_ansi]
#set validationtransform [tcl::dict::get $thisarg -validationtransform]
set has_default [tcl::dict::exists $thisarg -default]
if {$has_default} {
set defaultval [tcl::dict::get $thisarg -default]
}
set typelist [tcl::dict::get $thisarg -type]
set clause_size [llength $typelist]
set has_choices [expr {[tcl::dict::exists $thisarg -choices] || [tcl::dict::exists $thisarg -choicegroups]}]
set validationtransform [tcl::dict::get $thisarg -validationtransform]
#JJJJ
@ -9076,7 +9122,7 @@ tcl::namespace::eval punk::args {
set vlist_typelist_validate [list]
#reduce our validation requirements by removing values which match defaultval or match -choices
#(could be -multiple with -choicerestricted 0 where some selections match and others don't)
if {$parsekey in $receivednames && $has_choices} {
if {$has_choices && $parsekey in $receivednames} {
#-choices must also work with -multiple
#todo -choicelabels
set choiceprefix [tcl::dict::get $thisarg -choiceprefix]
@ -9333,13 +9379,13 @@ tcl::namespace::eval punk::args {
set vlist [list]
set vlist_check_validate [list]
} else {
if {[llength $vlist] && $has_default} {
if {$has_default && [llength $vlist]} {
#defaultval here is a value for the entire clause. (clause usually length 1)
#J2
#set vlist_validate [list]
#set vlist_check_validate [list]
set tp [dict get $thisarg -type]
set clause_size [llength $tp]
#set tp [dict get $thisarg -type]
set clause_size [llength $typelist]
foreach clause_value $vlist clause_check $vlist_check clause_typelist $vlist_typelist {
#JJJJ
#REVIEW!!! we're inadvertently adding back in things that may have already been decided in choicelist loop as not requiring validation?
@ -9388,7 +9434,7 @@ tcl::namespace::eval punk::args {
#is_allow_ansi doesn't apply to a value matching a supplied -default, or values matching those in -choices/-choicegroups
#assert: our vlist & vlist_check lists have been reduced to remove those
if {[llength $vlist] && !$is_allow_ansi} {
if {!$is_allow_ansi && [llength $vlist]} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
@ -9452,7 +9498,7 @@ tcl::namespace::eval punk::args {
if {$is_strip_ansi} {
set stripped_list [lmap e $vlist_original {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach
if {[tcl::dict::get $thisarg -multiple]} {
if {$is_multiple} {
switch -- [tcl::dict::get $thisarg -ARGTYPE] {
leader {
tcl::dict::set leaders_dict $argname_or_ident $stripped_list

14
src/vfs/_vfscommon.vfs/modules/punk/blockletter-0.1.0.tm

@ -116,13 +116,13 @@ tcl::namespace::eval punk::blockletter {
set default_frametype {vl \u00a0 hl \u00a0 tlc \u00a0 trc \u00a0 blc \u00a0 brc \u00a0}
# colours in order for T c l T k
set logo_letter_colours [list Web-red Web-green Web-royalblue Web-purple Web-orange]
#set logo_letter_colours [list Web-red Web-green Web-royalblue Web-purple Web-orange]
set logo_letter_colours [list Red Green Blue Purple Yellow]
punk::args::define [tstr -return string {
@id -id ::punk::blockletter::logo
-frametype -default {${$default_frametype}}
-outlinecolour -default "web-white"
-outlinecolour -default "term-white"
-backgroundcolour -default {} -help "e.g Web-white
This argument is the name as accepted by punk::ansi::a+"
@values -min 0 -max 0
@ -220,8 +220,8 @@ tcl::namespace::eval punk::blockletter {
punk::args::define [tstr -return string {
@id -id ::punk::blockletter::text
-bgcolour -default "Web-red"
-bordercolour -default "web-white"
-bgcolour -default "Term-red"
-bordercolour -default "term-white"
-frametype -default {${$default_frametype}}
@values -min 1 -max 1
str -help "Text to convert to blockletters
@ -286,9 +286,9 @@ tcl::namespace::eval punk::blockletter::lib {
@id -id ::punk::blockletter::lib::block
-height -default 2
-width -default 4
-frametype -default {${$::punk::blockletter::default_frametype}}
-bgcolour -default "Web-red"
-bordercolour -default "web-white"
-frametype -default {${$::punk::blockletter::default_frametype}}
-bgcolour -default "Term-red"
-bordercolour -default "term-white"
@values -min 0 -max 0
}]
proc block {args} {

153
src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm

@ -702,6 +702,27 @@ namespace eval punk::console {
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
-passthrough -default "none" -choices {none tmux auto} -choicecolumns 1 -choicelabels {
none\
{ ANSI sent without any passthrough wrapping.
A terminal multiplexer such as tmux,screen,zellij may
not pass the request through to the underlying terminal(s)
This is the recommended/normal value for the option.}
tmux\
{ Wrap ANSI sequence with tmux passthrough sequence.
\x1bPtmux\;<originalsequence_with_escapes_doubled>\x1b\\
Note that a tmux session could be connected to multiple
terminals (perhaps of different types) - in which case multiple
responses may be received in a non-deterministic order.
Passthrough should generally be avoided except for debug/test
purposes.
}
auto\
{ Use existence of ::env(TMUX) to detect tmux and
send tmux passthrough sequence.
Not recommended except for debug/test purposes.
}
}
-expected_ms -default 300 -type integer -help\
"Expected number of ms for response from terminal.
100ms is usually plenty for a local terminal and a
@ -731,6 +752,7 @@ namespace eval punk::console {
set expected [dict get $opts -expected_ms]
set ignoreok [dict get $opts -ignoreok]
set returntype [dict get $opts -return]
set passthrough [dict get $opts -passthrough]
set query [dict get $values query]
set capturingendregex [dict get $values capturingendregex]
@ -784,7 +806,7 @@ namespace eval punk::console {
set runningid [lindex $queue 0]
if {$runningid ne $callid} {
set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid)
update ;#REVIEW - probably a bad idea
update ;#REVIEW - possibly a bad idea
after 10
set runningid [lindex $queue 0] ;#jn test
}
@ -836,6 +858,17 @@ namespace eval punk::console {
}
#write before console enableRaw vs after??
#There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it
switch -- $passthrough {
auto {
if {[info exists ::env(TMUX)]} {
set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\"
}
}
tmux {
set query "\x1bPtmux\;[string map [list \x1b \x1b\x1b] $query]\x1b\\"
}
}
puts -nonewline $output $query;flush $output
chan configure $input -blocking 0
@ -847,8 +880,10 @@ namespace eval punk::console {
#we should care more about performance in raw mode - as ultimately that's the one we prefer for full features
#------------------
# 1) faster - races?
#first read will read 3 bytes JJJJ
$this_handler $input $callid $capturingendregex
$this_handler $input $callid $capturingendregex
#JJJJ
#$this_handler $input $callid $capturingendregex
if {$ignoreok || $waitvar($callid) ne "ok"} {
chan event $input readable [list $this_handler $input $callid $capturingendregex]
}
@ -1047,7 +1082,11 @@ namespace eval punk::console {
upvar ::punk::console::ansi_response_tsclock tsclock
#endregex should explicitly have a trailing $
set status [catch {read $chan 1} bytes]
if {[string length $chunks($callid)] == 0} {
set status [catch {read $chan 3} bytes]
} else {
set status [catch {read $chan 1} bytes]
}
if { $status != 0 } {
# Error on the channel
chan event $chan readable {}
@ -1290,7 +1329,7 @@ namespace eval punk::console {
"Omit or pass empty string to query current echo state."
}]
proc echo {args} {
set argd [punk::args::parse $args withid ::punk::console::local::echo]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::local::echo]
set onoff [dict get $argd values onoff]
set is_windows [string equal "windows" $::tcl_platform(platform)]
@ -1343,6 +1382,7 @@ namespace eval punk::console {
@opts
-terminal -default {stdin stdout} -type list -help\
"terminal (currently list of in/out channels) (todo - object?)"
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-expected_ms -type integer -default 500 -help\
"Number of ms to wait for response"
@values -min 1 -max 1
@ -1356,11 +1396,12 @@ namespace eval punk::console {
lassign [dict values $argd] leaders opts values received
set request [dict get $values request]
set inoutchannels [dict get $opts -terminal]
set passthrough [dict get $opts -passthrough]
set expected [dict get $opts -expected_ms]
set capturingregex {(((.*)))$} ;#capture entire response same as response-payload
set ts_start [clock millis]
set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex]
set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels -passthrough $passthrough $request $capturingregex]
set ts_end [clock millis]
puts stderr $response
set out ""
@ -1781,6 +1822,7 @@ namespace eval punk::console {
}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
@values -min 1 -max 1
mode -type {int|string} -multiple 0 -help\
"integer for DEC mode, or name as in the dict:
@ -1793,10 +1835,11 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc dec_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set mode [dict get $values mode]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set mode [dict get $values mode]
if {[string is integer -strict $mode]} {
set m $mode
@ -1810,7 +1853,7 @@ namespace eval punk::console {
}
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[?$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex]
return $payload
}
@ -1838,7 +1881,7 @@ namespace eval punk::console {
}
#todo - should accept multiple mode nums/names at once
proc dec_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1884,7 +1927,7 @@ namespace eval punk::console {
}]
}
proc dec_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -1931,6 +1974,7 @@ namespace eval punk::console {
}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-refresh -type none -help\
"Force a re-test of the mode."
-return -type string -choices {dict result} -default result -choicelabels {
@ -1946,9 +1990,10 @@ namespace eval punk::console {
}]
}
proc dec_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set console [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set num_or_name [dict get $values mode]
set do_refresh [dict exists $received -refresh]
set return [dict get $opts -return]
@ -1964,21 +2009,23 @@ namespace eval punk::console {
}
}
variable dec_has_mode_cache
#make sure we cache on both console and passthrough
set cachekey "$console $passthrough"
if {$do_refresh} {
if {[dict exists $dec_has_mode_cache $console $m]} {
dict unset dec_has_mode_cache $console $m
if {[dict exists $dec_has_mode_cache $cachekey $m]} {
dict unset dec_has_mode_cache $cachekey $m
}
}
if {![dict exists $dec_has_mode_cache $console $m]} {
if {![dict exists $dec_has_mode_cache $cachekey $m]} {
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[?$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex]
#set has_mode [expr {$payload != 0}]
#we can use the payload result as the response as non-zero responses evaluate to true
set has_mode $payload
if {$has_mode ne ""} {
dict set dec_has_mode_cache $console $m $has_mode
dict set dec_has_mode_cache $cachekey $m $has_mode
set source "query"
} else {
#don't cache an empty/failed response - review
@ -1986,7 +2033,7 @@ namespace eval punk::console {
set source "failedquery"
}
} else {
set has_mode [dict get $dec_has_mode_cache $console $m]
set has_mode [dict get $dec_has_mode_cache $cachekey $m]
set source "cache"
}
if {$return eq "dict"} {
@ -2004,6 +2051,7 @@ namespace eval punk::console {
{Show table of DEC modes with basic information.}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-test -type none -help\
"Test current value/support for each mode"
-supported -type none -help\
@ -2013,10 +2061,11 @@ namespace eval punk::console {
"Match code or name"
}]
proc dec_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set do_test [dict exists $received -test]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set do_test [dict exists $received -test]
set only_supported [dict exists $received -supported]
if {[dict exists $values match]} {
set matches [dict get $values match]
@ -2074,7 +2123,7 @@ namespace eval punk::console {
set RST ""
if {$do_test} {
#dec_has_mode can be cached - in which case only 0|3|4 can be relied upon without re-querying
set hasmode_dict [dec_has_mode -console $terminal -return dict $code]
set hasmode_dict [dec_has_mode -console $terminal -passthrough $passthrough -return dict $code]
switch -- [dict get $hasmode_dict result] {
0 {
if {$only_supported} {
@ -2089,7 +2138,7 @@ namespace eval punk::console {
1 - 2 {
if {[dict get $hasmode_dict source] eq "cache"} {
#a terminal query is required
set testresult [dec_get_mode -console $terminal $code]
set testresult [dec_get_mode -console $terminal -passthrough $passthrough $code]
} else {
set testresult [dict get $hasmode_dict result]
if {![string is integer -strict $testresult]} {
@ -2135,7 +2184,7 @@ namespace eval punk::console {
} else {
if {$only_supported} {
#dec_has_mode still queries terminal - but is cached if a response was received
if {[dec_has_mode -console $terminal $code] == 0} {
if {[dec_has_mode -console $terminal -passthrough $passthrough $code] == 0} {
continue
}
}
@ -2184,6 +2233,7 @@ namespace eval punk::console {
source indicates whether the result came
from query or cache."
}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
@values -min 1 -max 1
mode -type {int|string} -help\
"integer for ANSI mode, or name as in the dict:
@ -2191,12 +2241,13 @@ namespace eval punk::console {
}]
}
proc ansi_has_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_has_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_has_mode]
lassign [dict values $argd] leaders opts values received
set console [dict get $opts -console]
set console [dict get $opts -console]
set num_or_name [dict get $values mode]
set return [dict get $opts -return]
set do_refresh [dict exists $received -refresh]
set return [dict get $opts -return]
set passthrough [dict get $opts -passthrough]
set do_refresh [dict exists $received -refresh]
if {[string is integer -strict $num_or_name]} {
set m $num_or_name
@ -2209,20 +2260,22 @@ namespace eval punk::console {
}
}
variable ansi_has_mode_cache
#make sure we cache on both console and passthrough
set cachekey "$console $passthrough"
if {$do_refresh} {
if {[dict exists $ansi_has_mode_cache $console $m]} {
dict unset ansi_has_mode_cache $console $m
if {[dict exists $ansi_has_mode_cache $cachekey $m]} {
dict unset ansi_has_mode_cache $cachekey $m
}
}
if {![dict exists $ansi_has_mode_cache $console $m]} {
if {![dict exists $ansi_has_mode_cache $cachekey $m]} {
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $console $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $console -passthrough $passthrough $request $capturingregex]
#set has_mode [expr {$payload != 0}]
set has_mode $payload
if {$has_mode ne ""} {
dict set ansi_has_mode_cache $console $m $has_mode
dict set ansi_has_mode_cache $cachekey $m $has_mode
set source "query"
} else {
#don't cache an empty/failed response - review
@ -2230,7 +2283,7 @@ namespace eval punk::console {
set source "failedquery"
}
} else {
set has_mode [dict get $ansi_has_mode_cache $console $m]
set has_mode [dict get $ansi_has_mode_cache $cachekey $m]
set source "cache"
}
if {$return eq "dict"} {
@ -2261,7 +2314,7 @@ namespace eval punk::console {
}]
}
proc ansi_set_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_set_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_set_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2308,7 +2361,7 @@ namespace eval punk::console {
}]
}
proc ansi_unset_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_unset_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_unset_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set modes [dict get $values mode] ;#multiple
@ -2361,6 +2414,7 @@ namespace eval punk::console {
}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
@values -min 1 -max 1
mode -type {int|string} -multiple 0 -help\
"integer for ANSI mode, or name as in the dict:
@ -2373,10 +2427,11 @@ namespace eval punk::console {
# \x1b\[?7\;2\$y
#where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset)
proc ansi_get_mode {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_get_mode]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_get_mode]
lassign [dict values $argd] leaders opts values
set terminal [dict get $opts -console]
set mode [dict get $values mode]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set mode [dict get $values mode]
if {[string is integer -strict $mode]} {
set m $mode
@ -2390,7 +2445,7 @@ namespace eval punk::console {
}
set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload
set request "\x1b\[$m\$p"
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal $request $capturingregex]
set payload [punk::console::internal::get_ansi_response_payload -terminal $terminal -passthrough $passthrough $request $capturingregex]
return $payload
}
#todo ansi_unset_mode
@ -2404,6 +2459,7 @@ namespace eval punk::console {
{Show table of ANSI modes with basic information.}
@opts
-console -type list -minsize 2 -default {stdin stdout}
${[punk::args::resolved_def -types opts ::punk::console::internal::get_ansi_response_payload -passthrough]}
-test -type none -help\
"Test current value/support for each mode"
-supported -type none -help\
@ -2413,10 +2469,11 @@ namespace eval punk::console {
"Match code or name"
}]
proc ansi_modes {args} {
set argd [punk::args::parse $args withid ::punk::console::ansi_modes]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::ansi_modes]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $opts -console]
set do_test [dict exists $received -test]
set terminal [dict get $opts -console]
set passthrough [dict get $opts -passthrough]
set do_test [dict exists $received -test]
if {[dict exists $values match]} {
set matches [dict get $values match]
} else {
@ -2500,7 +2557,7 @@ namespace eval punk::console {
set reset_state_colour ""
set RST ""
if {$do_test} {
set hasmode_dict [ansi_has_mode -console $terminal -return dict $code]
set hasmode_dict [ansi_has_mode -console $terminal -passthrough $passthrough -return dict $code]
switch -- [dict get $hasmode_dict result] {
0 {
if {$only_supported} {
@ -2515,7 +2572,7 @@ namespace eval punk::console {
1 - 2 {
if {[dict get $hasmode_dict source] eq "cache"} {
#a terminal query is required
set testresult [ansi_get_mode -console $terminal $code]
set testresult [ansi_get_mode -console $terminal -passthrough $passthrough $code]
} else {
set testresult [dict get $hasmode_dict result]
if {![string is integer -strict $testresult]} {
@ -2561,7 +2618,7 @@ namespace eval punk::console {
} else {
if {$only_supported} {
#ansi_has_mode still queries terminal - but is cached if a response was received
if {[ansi_has_mode -console $terminal $code] == 0} {
if {[ansi_has_mode -console $terminal -passthrough $passthrough $code] == 0} {
continue
}
}
@ -2659,7 +2716,7 @@ namespace eval punk::console {
name -type string
}]
proc dec_request_setting {args} {
set argd [punk::args::parse $args withid ::punk::console::dec_request_setting]
set argd [punk::args::parse $args -cache 1 withid ::punk::console::dec_request_setting]
lassign [dict values $argd] leaders opts values
set console [dict get $opts -console]
set name [dict get $values name]

2
src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.1.tm

@ -2750,7 +2750,7 @@ tcl::namespace::eval punk::imap4 {
@values -min 0 -max 0
}]
proc NOOP {args} {
set argd [punk::args::parse $args withid ::punk::imap4::NOOP]
set argd [punk::args::parse $args -cache 1 withid ::punk::imap4::NOOP]
set chan [dict get $argd leaders chan]
punk::imap4::proto::simplecmd $chan NOOP
}

2
src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.1.tm

@ -1363,7 +1363,7 @@ tcl::namespace::eval punk::netbox {
@values -min 0 -max 0
}]
proc _datafile {args} {
set argd [punk::args::parse $args withid ::punk::netbox::_datafile]
set argd [punk::args::parse $args -cache 1 withid ::punk::netbox::_datafile]
lassign [dict values $argd] leaders opts values received
set be_quiet [dict exists $received -quiet]

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

@ -1355,14 +1355,18 @@ tcl::namespace::eval punk::ns {
set a [a+ bold purple]
set e [a+ bold yellow]
set p [a+ bold white]
set c_nat [a+ web-gray] ;#native
set c_int [a+ web-orange] ;#interps
set c_cor [a+ web-hotpink] ;#coroutines
#set c_nat [a+ web-gray] ;#native
set c_nat [a+ term-silver] ;#native
set c_int [a+ term-orange1] ;#interps
set c_cor [a+ term-hotpink] ;#coroutines
set c_ooo [a+ bold cyan] ;#object
set c_ooc [a+ web-aquamarine] ;#class
set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_zst [a+ web-yellow] ;#zlibstreams
#set c_ooc [a+ web-aquamarine] ;#class
set c_ooc [a+ term-aqua] ;#class
#set c_ooO [a+ web-dodgerblue] ;#privateObject
set c_ooO [a+ term-purple-c] ;#privateObject
#set c_ooC [a+ web-lightskyblue] ;#privateClass
set c_ooC [a+ term-cornflowerblue] ;#privateClass
set c_zst [a+ term-yellow] ;#zlibstreams
set a1 [a][a+ cyan]
foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 {
@ -6629,16 +6633,16 @@ y" {return quirkykeyscript}
switch -- $syntax {
basic {
#rudimentary colourising only
set argl [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl]
set argl [punk::ansi::grepstr -return all -highlight term-teal {\{|\}} $argl]
set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon
set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one.
set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon
##set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $body]
set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body]
set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body]
set body [punk::ansi::grepstr -return all -highlight tk-orange {\[|\]} $body]
set body [punk::ansi::grepstr -return all -highlight term-teal {^(\{)|[^\\](\{+)} $body]
set body [punk::ansi::grepstr -return all -highlight term-teal {[^\\](\}+)} $body]
set body [punk::ansi::grepstr -return all -highlight term-orange {\[|\]} $body]
}
default {
set is_highlighted 0

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

@ -240,7 +240,7 @@ tcl::namespace::eval punk::sixel {
variable device_attribute_cache
set device_attribute_cache [dict create]
proc can_sixel {args} {
set argd [punk::args::parse $args withid ::punk::sixel::can_sixel]
set argd [punk::args::parse $args -cache 1 withid ::punk::sixel::can_sixel]
lassign [dict values $argd] leaders opts values received
set terminal [dict get $values terminal]

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

@ -1497,7 +1497,7 @@ tcl::namespace::eval textblock {
} elseif {$span > 0} {
#ok to reset to higher val immediately or after an any and any number of following zeros
if {$span > ($numcols - $sidx)} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview"
}
set remaining $span
@ -1508,7 +1508,7 @@ tcl::namespace::eval textblock {
} else {
if {$span eq "0"} {
if {$remaining eq "0"} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview"
} else {
incr remaining -1
@ -1517,7 +1517,7 @@ tcl::namespace::eval textblock {
if {$remaining eq "0"} {
#ok for new span value of any or > 0
if {$span ne "any" && $span > ($numcols - $sidx)} {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview"
}
set remaining $span
@ -1525,7 +1525,7 @@ tcl::namespace::eval textblock {
incr remaining -1
}
} else {
lset spanview $sidx [a+ web-red]$span[a]
lset spanview $sidx [a+ term-red]$span[a]
error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview"
}
}
@ -2926,7 +2926,7 @@ tcl::namespace::eval textblock {
$htable add_row [list "$hnum " $h "${width}x${height}" $s]
incr hnum
}
$htable configure_column 0 -ansibase [a+ web-dimgray]
$htable configure_column 0 -ansibase [a+ term-grey]
tcl::dict::set col_header_tables $col $htable
set colwidths [$htable column_widths]
set icol 0
@ -4294,7 +4294,8 @@ tcl::namespace::eval textblock {
set ecat [tcl::dict::create]
set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra]
set ansi [a+ {*}$fc web-black Web-gold]
#set ansi [a+ {*}$fc web-black Web-gold]
set ansi [a+ {*}$fc term-black Term-gold1]
set val [list ansi $ansi cat alkaline_earth]
foreach e $cat_alkaline_earth {
tcl::dict::set ecat $e $val
@ -4302,7 +4303,7 @@ tcl::namespace::eval textblock {
set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I]
#set ansi [a+ {*}$fc web-black Web-lightgreen]
set ansi [a+ {*}$fc black Term-113]
set ansi [a+ {*}$fc term-black Term-113]
set val [list ansi $ansi cat reactive_nonmetal]
foreach e $cat_reactive_nonmetal {
tcl::dict::set ecat $e $val
@ -4310,7 +4311,7 @@ tcl::namespace::eval textblock {
set cat [list Li Na K Rb Cs Fr]
#set ansi [a+ {*}$fc web-black Web-Khaki]
set ansi [a+ {*}$fc black Term-lightgoldenrod2]
set ansi [a+ {*}$fc term-black Term-lightgoldenrod2]
set val [list ansi $ansi cat alkali_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4318,14 +4319,16 @@ tcl::namespace::eval textblock {
set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs]
#set ansi [a+ {*}$fc web-black Web-lightsalmon]
set ansi [a+ {*}$fc black Term-orange1]
set ansi [a+ {*}$fc term-black Term-salmon1]
set val [list ansi $ansi cat transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list Al Ga In Sn Tl Pb Bi Po]
set ansi [a+ {*}$fc web-black Web-lightskyblue]
#set ansi [a+ {*}$fc web-black Web-lightskyblue]
set ansi [a+ {*}$fc term-black Term-lightsteelblue]
set val [list ansi $ansi cat post_transition_metals]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4333,21 +4336,25 @@ tcl::namespace::eval textblock {
set cat [list B Si Ge As Sb Te At]
#set ansi [a+ {*}$fc web-black Web-turquoise]
set ansi [a+ {*}$fc black Brightcyan]
#set ansi [a+ {*}$fc black Brightcyan]
set ansi [a+ {*}$fc term-black Term-skyblue1]
set val [list ansi $ansi cat metalloids]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list He Ne Ar Kr Xe Rn]
set ansi [a+ {*}$fc web-black Web-orchid]
#set ansi [a+ {*}$fc web-black Web-orchid]
set ansi [a+ {*}$fc term-black Term-purple-c]
set val [list ansi $ansi cat noble_gases]
foreach e $cat {
tcl::dict::set ecat $e $val
}
set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr]
set ansi [a+ {*}$fc web-black Web-plum]
#set ansi [a+ {*}$fc web-black Web-plum]
set ansi [a+ {*}$fc term-black Term-plum1]
set val [list ansi $ansi cat actinoids]
foreach e $cat {
tcl::dict::set ecat $e $val
@ -4361,7 +4368,8 @@ tcl::namespace::eval textblock {
tcl::dict::set ecat $e $val
}
set ansi [a+ {*}$fc web-black Web-whitesmoke]
#set ansi [a+ {*}$fc web-black Web-whitesmoke]
set ansi [a+ {*}$fc term-black Term-silver]
set val [list ansi $ansi cat other]
foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] {
tcl::dict::set ecat $e $val
@ -4807,7 +4815,7 @@ tcl::namespace::eval textblock {
123456789ABCDEF
"
-size -type integer\
-default 15\
-default 16\
-optional 1\
-range {1 ""}
-direction -default horizontal\
@ -4818,6 +4826,7 @@ tcl::namespace::eval textblock {
the colour stripes will be oriented
in this direction.
"
-noreset -type none
@values -min 0 -max 1
colour -type list -default {} -optional 1 -help\
"List of Ansi colour names
@ -4832,8 +4841,10 @@ tcl::namespace::eval textblock {
proc testblock {args} {
set argd [punk::args::parse $args withid ::textblock::testblock]
set colour [dict get $argd values colour]
set size [dict get $argd opts -size]
lassign [dict values $argd] leaders opts values received
set colour [dict get $values colour]
set size [dict get $opts -size]
set noreset [dict exists $received -noreset]
set rainbow_list [list]
lappend rainbow_list {30 47} ;#black White
@ -4879,7 +4890,7 @@ tcl::namespace::eval textblock {
set longbows [concat {*}[lrepeat $numsets $rainbow_list]]
set rainbow_list [lrange $longbows 0 $size-1]
}
if {"noreset" in $colour} {
if {$noreset} {
set RST ""
} else {
set RST [a]
@ -4896,7 +4907,7 @@ tcl::namespace::eval textblock {
set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi]
lappend clist ${ansicode}$c$RST
}
if {"noreset" in $colour} {
if {$noreset} {
return [textblock::join_basic -ansiresets 0 -- {*}$clist]
} else {
#return [textblock::join_basic -- {*}$clist]
@ -4935,6 +4946,7 @@ tcl::namespace::eval textblock {
for {set r 0} {$r < $size} {incr r} {
append block [::join $charsubset ""] \n
}
set block [tcl::string::trimright $block \n]
if {[llength $colour]} {
set block [a+ {*}$colour]$block$RST
}
@ -5642,22 +5654,22 @@ tcl::namespace::eval textblock {
set headers [list]
set blocks [list]
lappend blocks "[textblock::testblock 4 rainbow]"
lappend blocks "[textblock::testblock -size 4 rainbow]"
lappend headers "rainbow 4x4\nresets at line extremes\nnothing trailing"
lappend blocks "[textblock::testblock 4 rainbow][a]"
lappend blocks "[textblock::testblock -size 4 rainbow][a]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing reset"
lappend blocks "[textblock::testblock 4 rainbow]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 rainbow]\n[a+ Term-green]"
lappend headers "rainbow 4x4\nresets at line extremes\ntrailing nl&green bg"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]"
lappend headers "rainbow 4x4\nno line resets\nnothing trailing"
lappend blocks "[textblock::testblock 4 {rainbow noreset}][a]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}][a]"
lappend headers "rainbow 4x4\nno line resets\ntrailing reset"
lappend blocks "[textblock::testblock 4 {rainbow noreset}]\n[a+ Web-Green]"
lappend blocks "[textblock::testblock -size 4 -noreset {rainbow}]\n[a+ Term-green]"
lappend headers "rainbow 4x4\nno line resets\ntrailing nl&green bg"
set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers]
@ -5665,13 +5677,13 @@ tcl::namespace::eval textblock {
proc pad_example2 {} {
set headers [list]
set blocks [list]
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n"
lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl"
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a]"
lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a]"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&reset"
lappend blocks "[a+ web-red Web-steelblue][textblock::block 4 4 x]\n[a+ Web-Green]"
lappend blocks "[a+ term-red Term-cornflowerblue][textblock::block 4 4 x]\n[a+ Term-green]"
lappend headers "red on blue 4x4\nno inner resets\ntrailing nl&green bg"
set t [textblock::pad_test_blocklist $blocks -description "trailing\nbg/reset\ntests" -blockheaders $headers]
@ -6113,14 +6125,15 @@ tcl::namespace::eval textblock {
proc welcome_test {} {
package require punk::ansi
package require patternpunk
set ansi [textblock::join -- " " [punk::ansi::ansicat src/testansi/publicdomain/roysac/ROY-WELC.ANS 80x8]]
set ansi [textblock::join -- " " [punk::ansi::ansicat -dimensions 80x8 src/testansi/publicdomain/roysac/ROY-WELC.ANS]]
# Ansi art courtesy of Carsten Cumbrowski aka Roy/SAC - roysac.com
set table [[textblock::spantest] print]
set punks [a+ web-lawngreen][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
#set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a]
set punks [a+ term-lime][>punk . lhs][a]\n\n[a+ term-yellow][>punk . rhs][a]
set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks]
set testblock [textblock::testblock -size 15 rainbow]
set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents]
set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ term-orange1] $contents]
}
@ -7831,7 +7844,7 @@ tcl::namespace::eval textblock {
}
}
proc frame_cache {args} {
set argd [punk::args::parse $args withid ::textblock::frame_cache]
set argd [punk::args::parse $args -cache 1 withid ::textblock::frame_cache]
set action [dict get $argd values action]
variable frame_cache
set all_values_dict [dict get $argd values]
@ -8350,13 +8363,14 @@ tcl::namespace::eval textblock {
set usecache 0
#set buildcache 0 ;#comment out for debug/analysis so we can see
#puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'"
set cache_key [a+ Web-red web-white]$cache_key[a]
set cache_key [a+ Term-red term-white]$cache_key[a]
}
if {$buildcache && ($actual_contentwidth < $frame_inner_width)} {
#colourise cache_key to warn
if {$actual_contentwidth == 0} {
#we can still substitute with right length
set cache_key [a+ Web-steelblue web-black]$cache_key[a]
#set cache_key [a+ Web-steelblue term-black]$cache_key[a]
set cache_key [a+ Term-cornflowerblue term-black]$cache_key[a]
} else {
#actual_contentwidth is narrower than frame - check template's patternwidth
if {[tcl::dict::exists $frame_cache $cache_key]} {
@ -8366,13 +8380,13 @@ tcl::namespace::eval textblock {
}
if {$actual_contentwidth < $cache_patternwidth} {
set usecache 0
set cache_key [a+ Web-orange web-black]$cache_key[a]
set cache_key [a+ Term-orange1 term-black]$cache_key[a]
} elseif {$actual_contentwidth == $cache_patternwidth} {
#set usecache 1
} else {
#actual_contentwidth > pattern
set usecache 0
set cache_key [a+ Web-red web-black]$cache_key[a]
set cache_key [a+ Term-red term-black]$cache_key[a]
}
}
}

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/jpegtclstub.lib

Binary file not shown.

76
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pkgIndex.tcl

@ -0,0 +1,76 @@
# -*- tcl -*- Tcl package index file
# --- --- --- Handcrafted, final generation by configure.
if {[package vsatisfies [package provide Tcl] 9.0-]} {
package ifneeded tkimg 2.1.0 [list load [file join $dir tcl9tkimg210.dll]]
} else {
package ifneeded tkimg 2.1.0 [list load [file join $dir tkimg210t.dll]]
}
# Compatibility hack. When asking for the old name of the package
# then load all format handlers and base libraries provided by tkImg.
# Actually we ask only for the format handlers, the required base
# packages will be loaded automatically through the usual package
# mechanism.
# When reading images without specifying it's format (option -format),
# the available formats are tried in reversed order as listed here.
# Therefore file formats with some "magic" identifier, which can be
# recognized safely, should be added at the end of this list.
package ifneeded Img 2.1.0 {
package require img::window
package require img::tga
package require img::ico
package require img::pcx
package require img::sgi
package require img::sun
package require img::xbm
package require img::xpm
package require img::jpeg
package require img::png
package require img::tiff
package require img::bmp
package require img::ppm
package require img::pixmap
package provide Img 2.1.0
}
package ifneeded img::bmp 2.1.0 [list load [file join $dir tcl9tkimgbmp210.dll]]
package ifneeded img::dted 2.1.0 [list load [file join $dir tcl9tkimgdted210.dll]]
package ifneeded img::flir 2.1.0 [list load [file join $dir tcl9tkimgflir210.dll]]
package ifneeded img::gif 2.1.0 [list load [file join $dir tcl9tkimggif210.dll]]
package ifneeded img::ico 2.1.0 [list load [file join $dir tcl9tkimgico210.dll]]
if {[package vsatisfies [package provide Tcl] 9.0]} {
package ifneeded jpegtcl 9.6.0 [list load [file join $dir tcl9jpegtcl960.dll]]
} else {
package ifneeded jpegtcl 9.6.0 [list load [file join $dir jpegtcl960t.dll]]
}
package ifneeded img::jpeg 2.1.0 [list load [file join $dir tcl9tkimgjpeg210.dll]]
if {[package vsatisfies [package provide Tcl] 9.0]} {
package ifneeded zlibtcl 1.3.1 [list load [file join $dir tcl9zlibtcl131.dll]]
} else {
package ifneeded zlibtcl 1.3.1 [list load [file join $dir zlibtcl131t.dll]]
}
if {[package vsatisfies [package provide Tcl] 9.0]} {
package ifneeded pngtcl 1.6.48 [list load [file join $dir tcl9pngtcl1648.dll]]
} else {
package ifneeded pngtcl 1.6.48 [list load [file join $dir pngtcl1648t.dll]]
}
if {[package vsatisfies [package provide Tcl] 9.0]} {
package ifneeded tifftcl 4.7.0 [list load [file join $dir tcl9tifftcl470.dll]]
} else {
package ifneeded tifftcl 4.7.0 [list load [file join $dir tifftcl470t.dll]]
}
package ifneeded img::pcx 2.1.0 [list load [file join $dir tcl9tkimgpcx210.dll]]
package ifneeded img::pixmap 2.1.0 [list load [file join $dir tcl9tkimgpixmap210.dll]]
package ifneeded img::png 2.1.0 [list load [file join $dir tcl9tkimgpng210.dll]]
package ifneeded img::ppm 2.1.0 [list load [file join $dir tcl9tkimgppm210.dll]]
package ifneeded img::ps 2.1.0 [list load [file join $dir tcl9tkimgps210.dll]]
package ifneeded img::raw 2.1.0 [list load [file join $dir tcl9tkimgraw210.dll]]
package ifneeded img::sgi 2.1.0 [list load [file join $dir tcl9tkimgsgi210.dll]]
package ifneeded img::sun 2.1.0 [list load [file join $dir tcl9tkimgsun210.dll]]
package ifneeded img::tga 2.1.0 [list load [file join $dir tcl9tkimgtga210.dll]]
package ifneeded img::tiff 2.1.0 [list load [file join $dir tcl9tkimgtiff210.dll]]
package ifneeded img::window 2.1.0 [list load [file join $dir tcl9tkimgwindow210.dll]]
package ifneeded img::xbm 2.1.0 [list load [file join $dir tcl9tkimgxbm210.dll]]
package ifneeded img::xpm 2.1.0 [list load [file join $dir tcl9tkimgxpm210.dll]]

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/pngtclstub.lib

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9jpegtcl960.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9pngtcl1648.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tifftcl470.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimg210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgbmp210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgdted210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgflir210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimggif210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgico210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgjpeg210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpcx210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpixmap210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgpng210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgppm210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgps210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgraw210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsgi210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgsun210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtga210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgtiff210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgwindow210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxbm210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9tkimgxpm210.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tcl9zlibtcl131.dll

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tifftclstub.lib

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/tkimgstub.lib

Binary file not shown.

BIN
src/vfs/punk9win.vfs/lib_tcl9/Img2.1.0/zlibtclstub.lib

Binary file not shown.

1
src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/pkgIndex.tcl

@ -0,0 +1 @@
package ifneeded TclCurl 8.15.0 "[list load [file join $dir tcl9TclCurl8150.dll] Tclcurl]; [list source [file join $dir tclcurl.tcl]]"

BIN
src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tcl9TclCurl8150.dll

Binary file not shown.

3151
src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.html

File diff suppressed because it is too large Load Diff

143
src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl.tcl

@ -0,0 +1,143 @@
################################################################################
################################################################################
#### tclcurl.tcl
################################################################################
################################################################################
## Includes the tcl part of TclCurl
################################################################################
################################################################################
## (c) 2001-2011 Andres Garcia Garcia. fandom@telefonica.net
## See the file "license.terms" for information on usage and redistribution
## of this file and for a DISCLAIMER OF ALL WARRANTIES.
################################################################################
################################################################################
namespace eval curl {
################################################################################
# configure
# Invokes the 'curl-config' script to be able to know what features have
# been compiled in the installed version of libcurl.
# Possible options are '-prefix', '-feature' and 'vernum'
################################################################################
proc ::curl::curlConfig {option} {
if {$::tcl_platform(platform)=="windows"} {
error "This command is not available in Windows"
}
switch -exact -- $option {
-prefix {
return [exec curl-config --prefix]
}
-feature {
set featureList [exec curl-config --feature]
regsub -all {\\n} $featureList { } featureList
return $featureList
}
-vernum {
return [exec curl-config --vernum]
}
-ca {
return [exec curl-config --ca]
}
default {
error "bad option '$option': must be '-prefix', '-feature', '-vernum' or '-ca'"
}
}
return
}
################################################################################
# transfer
# The transfer command is used for simple transfers in which you don't
# want to request more than one file.
#
# Parameters:
# Use the same parameters you would use in the 'configure' command to
# configure the download and the same as in 'getinfo' with a 'info'
# prefix to get info about the transfer.
################################################################################
proc ::curl::transfer {args} {
variable getInfo
variable curlBodyVar
set i 0
set newArgs ""
catch {unset getInfo}
if {[llength $args]==0} {
puts "No transfer configured"
return
}
foreach {option value} $args {
set noPassOption 0
set block 1
switch -regexp -- $option {
-info.* {
set noPassOption 1
regsub -- {-info} $option {} option
set getInfo($option) $value
}
-block {
set noPassOption 1
set block $value
}
-bodyvar {
upvar $value curlBodyVar
set value curlBodyVar
}
-headervar {
upvar $value curlHeaderVar
set value curlHeaderVar
}
-errorbuffer {
upvar $value curlErrorVar
set value curlErrorVar
}
}
if {$noPassOption==0} {
lappend newArgs $option $value
}
}
if {[catch {::curl::init} curlHandle]} {
error "Could not init a curl session: $curlHandle"
}
if {[catch {eval $curlHandle configure $newArgs} result]} {
$curlHandle cleanup
error $result
}
if {$block==1} {
if {[catch {$curlHandle perform} result]} {
$curlHandle cleanup
error $result
}
if {[info exists getInfo]} {
foreach {option var} [array get getInfo] {
upvar $var info
set info [eval $curlHandle getinfo $option]
}
}
if {[catch {$curlHandle cleanup} result]} {
error $result
}
} else {
# We create a multiHandle
set multiHandle [curl::multiinit]
# We add the easy handle to the multi handle.
$multiHandle addhandle $curlHandle
# So now we create the event source passing the multiHandle as a parameter.
curl::createEventSource $multiHandle
# And we return, it is non blocking after all.
}
return 0
}
}

320
src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_multi.html

@ -0,0 +1,320 @@
<HTML><HEAD><TITLE>Manpage of TclCurl</TITLE>
</HEAD><BODY>
<H1>TclCurl</H1>
Section: TclCurl Multi Interface (3)<BR>Updated: 03 September 2011<BR><HR>
<A NAME="lbAB">&nbsp;</A>
<H2>NAME</H2>
TclCurl: - get a URL with FTP, FTPS, HTTP, HTTPS, SCP, SFTP, TFTP, TELNET, DICT, FILE, LDAP,
LDAPS, IMAP, IMAPS, POP, POP3, SMTP, SMTPS and gopher syntax.
<A NAME="lbAC">&nbsp;</A>
<H2>SYNOPSIS</H2>
<B>curl::multiinit</B>
<P>
<I>multiHandle</I><B> addhandle</B>
<P>
<I>multiHandle</I><B> removehandle</B>
<P>
<I>multiHandle</I><B> configure</B>
<P>
<I>multiHandle</I><B> perform</B>
<P>
<I>multiHandle</I><B> active</B>
<P>
<I>multiHandle</I><B> getinfo </B>
<P>
<I>multihandle</I><B> cleanup</B>
<P>
<I>multihandle</I><B> auto</B>
<P>
<B>curl::multistrerror </B><I>errorCode</I>
<P>
<A NAME="lbAD">&nbsp;</A>
<H2>DESCRIPTION</H2>
TclCurl's multi interface introduces several new abilities that the easy
interface refuses to offer. They are mainly:
<ul>
<li>Enable a &quot;pull&quot; interface. The application that uses TclCurl decides where
and when to get/send data.<br><br>
<li>Enable multiple simultaneous transfers in the same thread without making it
complicated for the application.<br><br>
<li>Keep Tk GUIs 'alive' while transfers are taking place.<br><br>
</ul>
<P>
</DL>
<A NAME="lbAE">&nbsp;</A>
<H2>Blocking</H2>
A few areas in the code are still using blocking code, even when used from the
multi interface. While we certainly want and intend for these to get fixed in
the future, you should be aware of the following current restrictions:
<ul>
<li>Name resolves on non-windows unless c-ares is used.</B>
<li>GnuTLS SSL connections.</B>
<li>Active FTP connections.</B>
<li>HTTP proxy CONNECT operations.</B>
<li>SCP and SFTP connections.</B>
<li>SFTP transfers.</B>
<li>TFTP transfers</B>
<li>file:// transfers.</B>
</ul>
<P>
<A NAME="lbAF">&nbsp;</A>
<H2>curl::multiinit</H2>
This procedure must be the first one to call, it returns a <I>multiHandle</I>
that you need to use to invoke TclCurl procedures. The init MUST have a
corresponding call to <I>cleanup</I> when the operation is completed.
<P>
<B>RETURN VALUE</B>
<P>
<I>multiHandle</I>
to use.
<P>
<A NAME="lbAG">&nbsp;</A>
<H2>multiHandle addhandle ?easyHandle?</H2>
<P>
Each single transfer is built up with an 'easy' handle, the kind we have been
using so far with TclCurl, you must create them and setup the appropriate
options for each of them. Then we add them to the 'multi stack' using the
<I>addhandle</I> command.
<P>
If the easy handle is not set to use a shared or global DNS cache, it will be made
to use the DNS cache that is shared between all easy handles within the multi handle.
<P>
When an easy handle has been added to a multi stack, you can not and you must not use
<I>perform</I> on that handle!
<P>
<P>
<I>multiHandle</I>
is the return code from the <I>curl::multiinit</I> call.
<P>
<B>RETURN VALUE</B>
The possible return values are:
<DL COMPACT>
<DT>-1<DD>
Handle added to the multi stack, please call
<I>perform</I>
soon
<DT>0<DD>
Handle added ok.
<DT>1<DD>
Invalid multi handle.
<DT>2<DD>
Invalid 'easy' handle. It could mean that it isn't an easy handle at all, or possibly that
the handle already is in used by this or another multi handle.
<DT>3<DD>
Out of memory, you should never get this.
<DT>4<DD>
You found a bug in TclCurl.
<P>
</DL>
<A NAME="lbAH">&nbsp;</A>
<H2>multiHandle removehandle ?easyHandle?</H2>
<P>
When a transfer is done or if we want to stop a transfer before it is completed,
we can use the <I>removehandle</I> command. Once removed from the multi handle,
we can again use other easy interface functions on it.
<P>
Please note that when a single transfer is completed, the easy handle is still
left added to the multi stack. You need to remove it and then close or, possibly,
set new options to it and add it again to the multi handle to start another transfer.
<P>
<P>
<B>RETURN VALUE</B>
The possible return values are:
<DL COMPACT>
<DT>0<DD>
Handle removed ok.
<DT>1<DD>
Invalid multi handle.
<DT>2<DD>
Invalid 'easy' handle.
<DT>3<DD>
Out of memory, you should never get this.
<DT>4<DD>
You found a bug in TclCurl.
<P>
</DL>
<A NAME="lbAI">&nbsp;</A>
<H2>multiHandle configure</H2>
So far the only option is:
<DL COMPACT>
<DT><B>-pipelining</B>
<DD>
Pass a 1 to enable or 0 to disable. Enabling pipelining on a multi handle will
make it attempt to perform HTTP Pipelining as far as possible for transfers using
this handle. This means that if you add a second request that can use an already
existing connection, the second request will be &quot;piped&quot; on the same connection
rather than being executed in parallel.
<DT><B>-maxconnects</B>
<DD>
Pass a number which will be used as the maximum amount of simultaneously open
connections that TclCurl may cache. Default is 10, and TclCurl will enlarge
the size for each added easy handle to make it fit 4 times the number of added
easy handles.
<P>
By setting this option, you can prevent the cache size to grow beyond the limit
set by you. When the cache is full, curl closes the oldest one in the cache to
prevent the number of open connections to increase.
<P>
This option is for the multi handle's use only, when using the easy interface you should instead use it's own <B>maxconnects</B> option.
<P>
</DL>
<A NAME="lbAJ">&nbsp;</A>
<H2>multiHandle perform</H2>
Adding the easy handles to the multi stack does not start any transfer.
Remember that one of the main ideas with this interface is to let your
application drive. You drive the transfers by invoking
<I>perform.</I>
TclCurl will then transfer data if there is anything available to transfer.
It'll use the callbacks and everything else we have setup in the individual
easy handles. It'll transfer data on all current transfers in the multi stack
that are ready to transfer anything. It may be all, it may be none.
<P>
When you call <B>perform</B> and the amount of Irunning handles is
changed from the previous call (or is less than the amount of easy handles
you added to the multi handle), you know that there is one or more
transfers less &quot;running&quot;. You can then call <I>getinfo</I> to
get information about each individual completed transfer.
<P>
<B>RETURN VALUE</B>
If everything goes well, it returns the number of running handles, '0' if all
are done. In case of error, it will return the error code.
<P>
<A NAME="lbAK">&nbsp;</A>
<H2>multiHandle active</H2>
In order to know if any of the easy handles are ready to transfer data before
invoking
<I>perform</I>
you can use the
<I>active</I>
command, it will return the number of transfers currently active.
<P>
<B>RETURN VALUE</B>
The number of active transfers or '-1' in case of error.
<P>
<A NAME="lbAL">&nbsp;</A>
<H2>multiHandle getinfo</H2>
This procedure returns very simple information about the transfers, you
can get more detail information using the <I>getinfo</I>
command on each of the easy handles.
<P>
<P>
<B>RETURN VALUE</B>
A list with the following elements:
<DL COMPACT>
<DT>easyHandle about which the info is about.<DD>
<DT>state of the transfer, '1' if it is done.<DD>
<DT>exit code of the transfer, '0' if there was no error,...<DD>
<DT>Number of messages still in the info queue.<DD>
<DT>In case there are no messages in the queue it will return {&quot;&quot; 0 0 0}.<DD>
<P>
</DL>
<A NAME="lbAM">&nbsp;</A>
<H2>multiHandle cleanup</H2>
This procedure must be the last one to call for a multi stack, it is the opposite of the
<I>curl::multiinit</I>
procedure and must be called with the same
<I>multiHandle</I>
as input as the
<B>curl::multiinit</B>
call returned.
<P>
<A NAME="lbAN">&nbsp;</A>
<H2>multiHandle auto ?-command <I>command</I>?</H2>
Using this command Tcl's event loop will take care of periodically invoking <B>perform</B>
for you, before using it, you must have already added at least one easy handle to
the multi handle.
<P>
The <B>command</B> option allows you to specify a command to invoke after all the easy
handles have finished their transfers, even though I say it is an option, the truth is
you must use this command to cleanup all the handles, otherwise the transfered files
may not be complete.
<P>
This support is still in a very experimental state, it may still change without warning.
Any and all comments are welcome.
<P>
You can find a couple of examples at <B>tests/multi</B>.
<P>
<A NAME="lbAO">&nbsp;</A>
<H2>curl::multistrerror errorCode</H2>
This procedure returns a string describing the error code passed in the argument.
<P>
<A NAME="lbAP">&nbsp;</A>
<H2>SEE ALSO</H2>
<I>tclcurl, curl.</I>
<P>
<HR>
<A NAME="index">&nbsp;</A><H2>Index</H2>
<DL>
<DT><A HREF="#lbAB">NAME</A><DD>
<DT><A HREF="#lbAC">SYNOPSIS</A><DD>
<DT><A HREF="#lbAD">DESCRIPTION</A><DD>
<DT><A HREF="#lbAE">Blocking</A><DD>
<DT><A HREF="#lbAF">curl::multiinit</A><DD>
<DT><A HREF="#lbAG">multiHandle addhandle ?easyHandle?</A><DD>
<DT><A HREF="#lbAH">multiHandle removehandle ?easyHandle?</A><DD>
<DT><A HREF="#lbAI">multiHandle configure</A><DD>
<DT><A HREF="#lbAJ">multiHandle perform</A><DD>
<DT><A HREF="#lbAK">multiHandle active</A><DD>
<DT><A HREF="#lbAL">multiHandle getinfo</A><DD>
<DT><A HREF="#lbAM">multiHandle cleanup</A><DD>
<DT><A HREF="#lbAN">multiHandle auto ?-command <I>command</I>?</A><DD>
<DT><A HREF="#lbAO">curl::multistrerror errorCode</A><DD>
<DT><A HREF="#lbAP">SEE ALSO</A><DD>
</DL>
<HR>
This document was created by man2html, using the manual pages.<BR>
</BODY>
</HTML>

112
src/vfs/punk9win.vfs/lib_tcl9/TclCurl8.15.0/tclcurl_share.html

@ -0,0 +1,112 @@
<HTML><HEAD><TITLE>Manpage of TclCurl</TITLE>
</HEAD><BODY>
<H1>TclCurl</H1>
Section: TclCurl share data api (3)<BR>Updated: 03 October 2011<BR><HR>
<A NAME="lbAB">&nbsp;</A>
<H2>NAME</H2>
TclCurl: - get a URL with FTP, FTPS, HTTP, HTTPS, SCP, SFTP, TFTP, TELNET, DICT, FILE, LDAP,
LDAPS, IMAP, IMAPS, POP, POP3, SMTP, SMTPS and gopher syntax.
<A NAME="lbAC">&nbsp;</A>
<H2>SYNOPSIS</H2>
<B>curl::shareinit</B>
<P>
<I>shareHandle</I><B> share </B><I>?data?</I>
<P>
<I>shareHandle</I><B> unshare </B><I>?data?</I>
<P>
<I>shareHandle</I><B> cleanup</B>
<P>
<B>curl::sharestrerror </B><I>errorCode</I>
<P>
<P>
<A NAME="lbAD">&nbsp;</A>
<H2>DESCRIPTION</H2>
<P>
With the share API, you can have two or more 'easy' handles sharing data
among them, so far they can only share cookies and DNS data.
<P>
<A NAME="lbAE">&nbsp;</A>
<H2>curl::shareinit</H2>
This procedure must be the first one to call, it returns a <B>shareHandle</B>
that you need to use to share data among handles using the <B>-share</B> option
to the <B>configure</B> command. The init MUST have a corresponding call to
<B>cleanup</B> when the operation is completed.
<P>
<B>RETURN VALUE</B>
<P>
<B>shareHandle</B> to use.
<P>
<A NAME="lbAF">&nbsp;</A>
<H2>shareHandle share ?data?</H2>
<P>
The parameter specifies a type of data that should be shared. This may be set
to one of the values described below:
<P>
<DL COMPACT><DT><DD>
<DL COMPACT>
<DT><B>cookies</B>
<DD>
Cookie data will be shared across the easy handles using this shared object.
<P>
<DT><B>dns</B>
<DD>
Cached DNS hosts will be shared across the easy handles using this shared object.
</DL>
</DL>
<P>
<A NAME="lbAG">&nbsp;</A>
<H2>shareHandle unshare ?data?</H2>
This command does the opposite of <B>share</B>. The specified parameter will no
longer be shared. Valid values are the same as those for <B>share</B>.
<P>
<A NAME="lbAH">&nbsp;</A>
<H2>sharehandle cleanup</H2>
<P>
Deletes a shared object. The share handle cannot be used anymore after this
function has been called.
<P>
<A NAME="lbAI">&nbsp;</A>
<H2>curl::sharestrerror errorCode</H2>
Returns a string describing the error code passed in the argument.
<P>
<A NAME="lbAJ">&nbsp;</A>
<H2>SEE ALSO</H2>
<I>curl, TclCurl</I>
<P>
<HR>
<A NAME="index">&nbsp;</A><H2>Index</H2>
<DL>
<DT><A HREF="#lbAB">NAME</A><DD>
<DT><A HREF="#lbAC">SYNOPSIS</A><DD>
<DT><A HREF="#lbAD">DESCRIPTION</A><DD>
<DT><A HREF="#lbAE">curl::shareinit</A><DD>
<DT><A HREF="#lbAF">shareHandle share ?data?</A><DD>
<DT><A HREF="#lbAG">shareHandle unshare ?data?</A><DD>
<DT><A HREF="#lbAH">sharehandle cleanup</A><DD>
<DT><A HREF="#lbAI">curl::sharestrerror errorCode</A><DD>
<DT><A HREF="#lbAJ">SEE ALSO</A><DD>
</DL>
<HR>
This document was created by man2html, using the manual pages.<BR>
</BODY>
</HTML>

386
src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/critcl-rt.tcl

@ -0,0 +1,386 @@
#
# Critcl - build C extensions on-the-fly
#
# Copyright (c) 2001-2007 Jean-Claude Wippler
# Copyright (c) 2002-2007 Steve Landers
#
# See http://wiki.tcl.tk/critcl
#
# This is the Critcl runtime that loads the appropriate
# shared library when a package is requested
#
namespace eval ::critcl::runtime {}
proc ::critcl::runtime::loadlib {dir package version libname initfun tsrc mapping args} {
# XXX At least parts of this can be done by the package generator,
# XXX like listing the Tcl files to source. The glob here allows
# XXX code-injection after-the-fact, by simply adding a .tcl in
# XXX the proper place.
set path [file join $dir [MapPlatform $mapping]]
set ext [info sharedlibextension]
set lib [file join $path $libname$ext]
set provide [list]
# Now the runtime equivalent of a series of 'preFetch' commands.
if {[llength $args]} {
set preload [file join $path preload$ext]
foreach p $args {
set prelib [file join $path $p$ext]
if {[file readable $preload] && [file readable $prelib]} {
lappend provide [list load $preload];# XXX Move this out of the loop, do only once.
lappend provide [list ::critcl::runtime::preload $prelib]
}
}
}
lappend provide [list load $lib $initfun]
foreach t $tsrc {
lappend loadcmd "::critcl::runtime::Fetch \$dir [list $t]"
}
lappend provide "package provide $package $version"
package ifneeded $package $version [join $provide "\n"]
return
}
proc ::critcl::runtime::preFetch {path ext dll} {
set preload [file join $path preload$ext]
if {![file readable $preload]} return
set prelib [file join $path $dll$ext]
if {![file readable $prelib]} return
load $preload ; # Defines next command.
::critcl::runtime::preload $prelib
return
}
proc ::critcl::runtime::Fetch {dir t} {
# The 'Ignore' disables compile & run functionality.
# Background: If the regular critcl package is already loaded, and
# this prebuilt package uses its defining .tcl file also as a
# 'tsources' then critcl might try to collect data and build it
# because of the calls to its API, despite the necessary binaries
# already being present, just not in the critcl cache. That is
# redundant in the best case, and fails in the worst case (no
# compiler), preventing the use o a perfectly fine package. The
# 'ignore' call now tells critcl that it should ignore any calls
# made to it by the sourced files, and thus avoids that trouble.
# The other case, the regular critcl package getting loaded after
# this prebuilt package is irrelevant. At that point the tsources
# were already run, and used the dummy procedures defined in the
# critcl-rt.tcl, which ignore the calls by definition.
set t [file join $dir tcl $t]
::critcl::Ignore $t
uplevel #0 [list source $t]
return
}
proc ::critcl::runtime::precopy {dll} {
# This command is only used on Windows when preloading out of a
# VFS that doesn't support direct loading (usually, a Starkit)
# - we preserve the dll name so that dependencies are satisfied
# - The critcl::runtime::preload command is defined in the supporting
# "preload" package, implemented in "critcl/lib/critcl/critcl_c/preload.c"
global env
if {[info exists env(TEMP)]} {
set dir $env(TEMP)
} elseif {[info exists env(TMP)]} {
set dir $env(TMP)
} elseif {[file exists $env(HOME)]} {
set dir $env(HOME)
} else {
set dir .
}
set dir [file join $dir TCL[pid]]
set i 0
while {[file exists $dir]} {
append dir [incr i]
}
set new [file join $dir [file tail $dll]]
file mkdir $dir
file copy $dll $new
return $new
}
proc ::critcl::runtime::MapPlatform {{mapping {}}} {
# A sibling of critcl::platform that applies the platform mapping
set platform [::platform::generic]
set version $::tcl_platform(osVersion)
if {[string match "macosx-*" $platform]} {
# "normalize" the osVersion to match OSX release numbers
set v [split $version .]
set v1 [lindex $v 0]
set v2 [lindex $v 1]
incr v1 -4
set version 10.$v1.$v2
} else {
# Strip trailing non-version info
regsub -- {-.*$} $version {} version
}
foreach {config map} $mapping {
if {![string match $config $platform]} continue
set minver [lindex $map 1]
if {[package vcompare $version $minver] < 0} continue
set platform [lindex $map 0]
break
}
return $platform
}
# Dummy implementation of the critcl package, if not present
if {![llength [info commands ::critcl::Ignore]]} {
namespace eval ::critcl {}
proc ::critcl::Ignore {args} {
namespace eval ::critcl::v {}
set ::critcl::v::ignore([file normalize [lindex $args 0]]) .
}
}
if {![llength [info commands ::critcl::api]]} {
namespace eval ::critcl {}
proc ::critcl::api {args} {}
}
if {![llength [info commands ::critcl::at]]} {
namespace eval ::critcl {}
proc ::critcl::at {args} {}
}
if {![llength [info commands ::critcl::cache]]} {
namespace eval ::critcl {}
proc ::critcl::cache {args} {}
}
if {![llength [info commands ::critcl::ccode]]} {
namespace eval ::critcl {}
proc ::critcl::ccode {args} {}
}
if {![llength [info commands ::critcl::ccommand]]} {
namespace eval ::critcl {}
proc ::critcl::ccommand {args} {}
}
if {![llength [info commands ::critcl::cdata]]} {
namespace eval ::critcl {}
proc ::critcl::cdata {args} {}
}
if {![llength [info commands ::critcl::cdefines]]} {
namespace eval ::critcl {}
proc ::critcl::cdefines {args} {}
}
if {![llength [info commands ::critcl::cflags]]} {
namespace eval ::critcl {}
proc ::critcl::cflags {args} {}
}
if {![llength [info commands ::critcl::cheaders]]} {
namespace eval ::critcl {}
proc ::critcl::cheaders {args} {}
}
if {![llength [info commands ::critcl::check]]} {
namespace eval ::critcl {}
proc ::critcl::check {args} {return 0}
}
if {![llength [info commands ::critcl::cinit]]} {
namespace eval ::critcl {}
proc ::critcl::cinit {args} {}
}
if {![llength [info commands ::critcl::clibraries]]} {
namespace eval ::critcl {}
proc ::critcl::clibraries {args} {}
}
if {![llength [info commands ::critcl::compiled]]} {
namespace eval ::critcl {}
proc ::critcl::compiled {args} {return 1}
}
if {![llength [info commands ::critcl::compiling]]} {
namespace eval ::critcl {}
proc ::critcl::compiling {args} {return 0}
}
if {![llength [info commands ::critcl::config]]} {
namespace eval ::critcl {}
proc ::critcl::config {args} {}
}
if {![llength [info commands ::critcl::cproc]]} {
namespace eval ::critcl {}
proc ::critcl::cproc {args} {}
}
if {![llength [info commands ::critcl::csources]]} {
namespace eval ::critcl {}
proc ::critcl::csources {args} {}
}
if {![llength [info commands ::critcl::debug]]} {
namespace eval ::critcl {}
proc ::critcl::debug {args} {}
}
if {![llength [info commands ::critcl::done]]} {
namespace eval ::critcl {}
proc ::critcl::done {args} {return 1}
}
if {![llength [info commands ::critcl::failed]]} {
namespace eval ::critcl {}
proc ::critcl::failed {args} {return 0}
}
if {![llength [info commands ::critcl::framework]]} {
namespace eval ::critcl {}
proc ::critcl::framework {args} {}
}
if {![llength [info commands ::critcl::include]]} {
namespace eval ::critcl {}
proc ::critcl::include {args} {}
}
if {![llength [info commands ::critcl::ldflags]]} {
namespace eval ::critcl {}
proc ::critcl::ldflags {args} {}
}
if {![llength [info commands ::critcl::license]]} {
namespace eval ::critcl {}
proc ::critcl::license {args} {}
}
if {![llength [info commands ::critcl::load]]} {
namespace eval ::critcl {}
proc ::critcl::load {args} {return 1}
}
if {![llength [info commands ::critcl::make]]} {
namespace eval ::critcl {}
proc ::critcl::make {args} {}
}
if {![llength [info commands ::critcl::meta]]} {
namespace eval ::critcl {}
proc ::critcl::meta {args} {}
}
if {![llength [info commands ::critcl::platform]]} {
namespace eval ::critcl {}
proc ::critcl::platform {args} {}
}
if {![llength [info commands ::critcl::preload]]} {
namespace eval ::critcl {}
proc ::critcl::preload {args} {}
}
if {![llength [info commands ::critcl::source]]} {
namespace eval ::critcl {}
proc ::critcl::source {args} {}
}
if {![llength [info commands ::critcl::tcl]]} {
namespace eval ::critcl {}
proc ::critcl::tcl {args} {}
}
if {![llength [info commands ::critcl::tk]]} {
namespace eval ::critcl {}
proc ::critcl::tk {args} {}
}
if {![llength [info commands ::critcl::tsources]]} {
namespace eval ::critcl {}
proc ::critcl::tsources {args} {}
}
if {![llength [info commands ::critcl::userconfig]]} {
namespace eval ::critcl {}
proc ::critcl::userconfig {args} {}
}
# Define a clone of platform::generic, if needed
if {![llength [info commands ::platform::generic]]} {
namespace eval ::platform {}
proc ::platform::generic {} {
global tcl_platform
set plat [string tolower [lindex $tcl_platform(os) 0]]
set cpu $tcl_platform(machine)
switch -glob -- $cpu {
sun4* {
set cpu sparc
}
intel -
ia32* -
i*86* {
set cpu ix86
}
x86_64 {
if {$tcl_platform(wordSize) == 4} {
# See Example <1> at the top of this file.
set cpu ix86
}
}
ppc -
"Power*" {
set cpu powerpc
}
"arm*" {
set cpu arm
}
ia64 {
if {$tcl_platform(wordSize) == 4} {
append cpu _32
}
}
}
switch -glob -- $plat {
windows {
if {$tcl_platform(platform) eq "unix"} {
set plat cygwin
} else {
set plat win32
}
if {$cpu eq "amd64"} {
# Do not check wordSize, win32-x64 is an IL32P64 platform.
set cpu x86_64
}
}
sunos {
set plat solaris
if {[string match "ix86" $cpu]} {
if {$tcl_platform(wordSize) == 8} {
set cpu x86_64
}
} elseif {![string match "ia64*" $cpu]} {
# sparc
if {$tcl_platform(wordSize) == 8} {
append cpu 64
}
}
}
darwin {
set major [lindex [split $tcl_platform(osVersion) .] 0]
if {$major > 19} {
set plat macos
} else {
set plat macosx
}
# Correctly identify the cpu when running as a 64bit
# process on a machine with a 32bit kernel
if {$cpu eq "ix86"} {
if {$tcl_platform(wordSize) == 8} {
set cpu x86_64
}
}
}
aix {
set cpu powerpc
if {$tcl_platform(wordSize) == 8} {
append cpu 64
}
}
hp-ux {
set plat hpux
if {![string match "ia64*" $cpu]} {
set cpu parisc
if {$tcl_platform(wordSize) == 8} {
append cpu 64
}
}
}
osf1 {
set plat tru64
}
default {
set plat [lindex [split $plat _-] 0]
}
}
return "${plat}-${cpu}"
}
}

1
src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/license.terms

@ -0,0 +1 @@
<<Undefined>>

2
src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/pkgIndex.tcl

@ -0,0 +1,2 @@
if {![package vsatisfies [package provide Tcl] 9.0]} {return}
package ifneeded ankh 1.1 "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "ankh$ext"] ; load $lib Ankh ; ::critcl::runtime::Fetch $dir policy_1.tcl ; package provide ankh 1.1 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]"

47
src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/tcl/policy_1.tcl

@ -0,0 +1,47 @@
# -*- tcl -*-
## Ankh - Andreas Kupries Hashes
## (c) 2021-2024 Andreas Kupries http://wiki.tcl.tk/andreas%20kupries
# Generate the public ensemble structure from the low-level hash commands.
# # ## ### ##### ######## #############
foreach hash {
aich
blake2b blake2s
btih
ed2k
edonr/224 edonr/256 edonr/384 edonr/512
gost12/256 gost12/512
gost94
has160
md4
md5
ripemd160
sha1
sha2/224 sha2/256 sha2/384 sha2/512
sha3/224 sha3/256 sha3/384 sha3/512
snefru/128 snefru/256
tiger
tth
whirlpool
} {
namespace eval ::ak::hash [list namespace export $hash]
# All the aggregated commands are defined as cprocs and cconsts.
namespace eval ::ak::hash::${hash} {
namespace export path channel string size references
namespace ensemble create
}
}
namespace eval ::ak::hash {
namespace export list version
namespace ensemble create
}
namespace eval ::ak {
namespace export hash
namespace ensemble create
}
# # ## ### ##### ######## #############
return

17
src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/teapot.txt

@ -0,0 +1,17 @@
Package ankh 1.1
Meta platform win32-x86_64
Meta build::date 2025-12-14
Meta generated::by {critcl 3.3.1} ashok
Meta generated::date critcl
Meta require critcl::cutil
Meta license Under a BSD license.
Meta author {Andreas Kupries}
Meta summary Commands for using a variety of cryptographically secure
Meta summary hash functions
Meta description This package provides a number of commands giving
Meta description access to a variety of cryptographically secure hash
Meta description functions, old and new.
Meta subject hash {cryptographically secure hash} {secure hash} md4 md5
Meta subject sha1 sha2 sha3 haval ripemd
Meta included tcl/policy_1.tcl critcl-rt.tcl win32-x86_64/ankh.dll
Meta entrytclcommand {eval "[list proc __critcl_load__ {dir} { ; source [file join $dir critcl-rt.tcl] ; set path [file join $dir [::critcl::runtime::MapPlatform]] ; set ext [info sharedlibextension] ; set lib [file join $path "ankh$ext"] ; load $lib Ankh ; ::critcl::runtime::Fetch $dir policy_1.tcl ; package provide ankh 1.1 ; catch {rename __critcl_load__ {}}}] ; [list __critcl_load__ $dir]"}

BIN
src/vfs/punk9win.vfs/lib_tcl9/ankh1.1/win32-x86_64/ankh.dll

Binary file not shown.

0
src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/LICENSE → src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/LICENSE

64
src/vfs/punk9win.vfs/lib_tcl9/tclcffi2.0.3/pkgIndex.tcl → src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/pkgIndex.tcl

@ -1,32 +1,32 @@
#
# Tcl package index file - generated from pkgIndex.tcl.in
#
package ifneeded cffi 2.0.3 \
[list apply [list {dir} {
package require platform
set package_ns ::cffi
set initName [string totitle cffi]
if {[package vsatisfies [package require Tcl] 9]} {
set fileName "tcl9cffi203.dll"
} else {
set fileName "cffi203.dll"
}
set platformId [platform::identify]
set searchPaths [list [file join $dir $platformId] \
{*}[lmap platformId [platform::patterns $platformId] {
file join $dir $platformId
}] \
$dir]
foreach path $searchPaths {
set lib [file join $path $fileName]
if {[file exists $lib]} {
uplevel #0 [list load $lib $initName]
# Load was successful
set ${package_ns}::dll_path $lib
set ${package_ns}::package_dir $dir
return
}
}
error "Could not locate $fileName in directories [join $searchPaths {, }]"
}] $dir]
#
# Tcl package index file - generated from pkgIndex.tcl.in
#
package ifneeded cffi 2.0.3 \
[list apply [list {dir} {
package require platform
set package_ns ::cffi
set initName [string totitle cffi]
if {[package vsatisfies [package require Tcl] 9]} {
set fileName "tcl9cffi203.dll"
} else {
set fileName "cffi203t.dll"
}
set platformId [platform::identify]
set searchPaths [list [file join $dir $platformId] \
{*}[lmap platformId [platform::patterns $platformId] {
file join $dir $platformId
}] \
$dir]
foreach path $searchPaths {
set lib [file join $path $fileName]
if {[file exists $lib]} {
uplevel #0 [list load $lib $initName]
# Load was successful
set ${package_ns}::dll_path $lib
set ${package_ns}::package_dir $dir
return
}
}
error "Could not locate $fileName in directories [join $searchPaths {, }]"
}] $dir]

BIN
src/vfs/punk9win.vfs/lib_tcl9/cffi2.0.3/win32-x86_64/tcl9cffi203.dll

Binary file not shown.

67
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclConfig.sh

@ -1,67 +0,0 @@
# itclConfig.sh --
#
# This shell script (for sh) is generated automatically by Itcl's
# configure script. It will create shell variables for most of
# the configuration options discovered by the configure script.
# This script is intended to be included by the configure scripts
# for Itcl extensions so that they don't have to figure this all
# out for themselves. This file does not duplicate information
# already provided by tclConfig.sh, so you may need to use that
# file in addition to this one.
#
# The information in this file is specific to a single platform.
# Itcl's version number.
itcl_VERSION='4.3.2'
ITCL_VERSION='4.3.2'
# The name of the Itcl library (may be either a .a file or a shared library):
itcl_LIB_FILE=tcl9itcl432.dll
ITCL_LIB_FILE=tcl9itcl432.dll
# String to pass to linker to pick up the Itcl library from its
# build directory.
itcl_BUILD_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2 -litcl432'
ITCL_BUILD_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2 -litcl432'
# String to pass to linker to pick up the Itcl library from its
# installed directory.
itcl_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2 -litcl432'
ITCL_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2 -litcl432'
# The name of the Itcl stub library (a .a file):
itcl_STUB_LIB_FILE=libitclstub.a
ITCL_STUB_LIB_FILE=libitclstub.a
# String to pass to linker to pick up the Itcl stub library from its
# build directory.
itcl_BUILD_STUB_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2 -litclstub'
ITCL_BUILD_STUB_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2 -litclstub'
# String to pass to linker to pick up the Itcl stub library from its
# installed directory.
itcl_STUB_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2 -litclstub'
ITCL_STUB_LIB_SPEC='-LC:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2 -litclstub'
# String to pass to linker to pick up the Itcl stub library from its
# build directory.
itcl_BUILD_STUB_LIB_PATH='C:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2/libitclstub.a'
ITCL_BUILD_STUB_LIB_PATH='C:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2/libitclstub.a'
# String to pass to linker to pick up the Itcl stub library from its
# installed directory.
itcl_STUB_LIB_PATH='C:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2/libitclstub.a'
ITCL_STUB_LIB_PATH='C:/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Install/Tcl/lib/itcl4.3.2/libitclstub.a'
# Location of the top-level source directories from which [incr Tcl]
# was built. This is the directory that contains generic, unix, etc.
# If [incr Tcl] was compiled in a different place than the directory
# containing the source files, this points to the location of the sources,
# not the location where [incr Tcl] was compiled.
itcl_SRC_DIR='/c/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2'
ITCL_SRC_DIR='/c/BawtBuilds/TclDistribution/TclDistribution-9.0.1-9.0.1/Windows/x64/Release/Build/Tcl/pkgs/itcl4.3.2'
# String to pass to the compiler so that an extension can
# find installed Itcl headers.
itcl_INCLUDE_SPEC=''
ITCL_INCLUDE_SPEC=''

BIN
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/libitclstub.a

Binary file not shown.

14
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/pkgIndex.tcl

@ -1,14 +0,0 @@
# -*- tcl -*-
# Tcl package index file, version 1.1
#
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
if {[package vsatisfies [package provide Tcl] 9.0-]} {
package ifneeded itcl 4.3.2 \
[list load [file join $dir tcl9itcl432.dll] Itcl]
} else {
package ifneeded itcl 4.3.2 \
[list load [file join $dir itcl432.dll] Itcl]
}
package ifneeded Itcl 4.3.2 [list package require -exact itcl 4.3.2]

BIN
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/tcl9itcl432.dll

Binary file not shown.

0
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itcl.tcl → src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itcl.tcl

0
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclHullCmds.tcl → src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclHullCmds.tcl

0
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.2/itclWidget.tcl → src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclWidget.tcl

BIN
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/itclstub.lib

Binary file not shown.

14
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/pkgIndex.tcl

@ -0,0 +1,14 @@
# -*- tcl -*-
# Tcl package index file, version 1.1
#
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
if {[package vsatisfies [package provide Tcl] 9.0-]} {
package ifneeded itcl 4.3.5 \
[list load [file join $dir tcl9itcl435.dll] Itcl]
} else {
package ifneeded itcl 4.3.5 \
[list load [file join $dir itcl435.dll] Itcl]
}
package ifneeded Itcl 4.3.5 [list package require -exact itcl 4.3.5]

BIN
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/tcl9itcl435.dll

Binary file not shown.

26
src/vfs/punk9win.vfs/lib_tcl9/itcl4.3.5/test_Itcl_CreateObject.tcl

@ -0,0 +1,26 @@
# this is a program for testing the stubs interface ItclCreateObject.
# it uses itclTestRegisterC.c with the call C function functionality,
# so it also tests that feature.
# you need to define in Makefile CFLAGS: -DITCL_DEBUG_C_INTERFACE
# for makeing that work.
package require itcl
::itcl::class ::c1 {
public method c0 {args} @cArgFunc
public method m1 { args } { puts "Hello Tcl $args" }
}
set obj1 [::c1 #auto ]
$obj1 m1 World
# C method cargFunc implements a call to Itcl_CreateObject!
#
# args for method c0 of class ::c1
# arg1 does not matter
# arg2 is the class name
# arg3 is the full class name (full path name)
# arg4 is the object name of the created Itcl object
set obj2 [$obj1 c0 ::itcl::parser::handleClass ::c1 ::c1 ::c1::c11]
# test, if it is working!
$obj2 m1 Folks

5
src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/pkgIndex.tcl

@ -0,0 +1,5 @@
if {[package vsatisfies [package provide Tcl] 9.0-]} {
package ifneeded sqlite3 3.51.0 [list load [file join $dir tcl9sqlite3510.dll] [string totitle sqlite3]]
} else {
package ifneeded sqlite3 3.51.0 [list load [file join $dir sqlite3510t.dll] [string totitle sqlite3]]
}

15
src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/sqlite3.n

@ -0,0 +1,15 @@
.TH sqlite3 n 4.1 "Tcl-Extensions"
.HS sqlite3 tcl
.BS
.SH NAME
sqlite3 \- an interface to the SQLite3 database engine
.SH SYNOPSIS
\fBsqlite3\fI command_name ?filename?\fR
.br
.SH DESCRIPTION
SQLite3 is a self-contains, zero-configuration, transactional SQL database
engine. This extension provides an easy to use interface for accessing
SQLite database files from Tcl.
.PP
For full documentation see \fIhttp://www.sqlite.org/\fR and
in particular \fIhttp://www.sqlite.org/tclsqlite.html\fR.

BIN
src/vfs/punk9win.vfs/lib_tcl9/sqlite3.51.0/tcl9sqlite3510.dll

Binary file not shown.

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

Loading…
Cancel
Save