Browse Source

fix punk::zip, fixes for punk::args, more tclcore docs

master
Julian Noble 3 weeks ago
parent
commit
fad50adcf0
  1. 68
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  2. 1045
      src/bootsupport/modules/punk/args-0.1.8.tm
  3. 7959
      src/bootsupport/modules/punk/args-0.1.9.tm
  4. 11
      src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  5. 6
      src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  6. 40
      src/bootsupport/modules/punk/ns-0.1.0.tm
  7. 4
      src/bootsupport/modules/punk/zip-0.1.1.tm
  8. 74
      src/bootsupport/modules/textblock-0.1.3.tm
  9. 118
      src/modules/punk/args-999999.0a1.0.tm
  10. 493
      src/modules/punk/args/tclcore-999999.0a1.0.tm
  11. 4
      src/modules/punk/zip-999999.0a1.0.tm
  12. 68
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  13. 1045
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.8.tm
  14. 7959
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.9.tm
  15. 11
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  16. 6
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  17. 40
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  18. 4
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
  19. 74
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  20. 68
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm
  21. 1045
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.8.tm
  22. 7959
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.9.tm
  23. 11
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm
  24. 6
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm
  25. 40
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  26. 4
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/zip-0.1.1.tm
  27. 74
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm
  28. 68
      src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm
  29. 2131
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.8.tm
  30. 7959
      src/vfs/_vfscommon.vfs/modules/punk/args-0.1.9.tm
  31. 2146
      src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm
  32. 11
      src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm
  33. 6
      src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm
  34. 40
      src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm
  35. 4
      src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm
  36. 73
      src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm
  37. BIN
      src/vfs/_vfscommon.vfs/modules/test/punk/args-0.1.5.tm
  38. 74
      src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm

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

@ -3463,7 +3463,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set emit ""
#set parts [punk::ansi::ta::split_codes $text]
set parts [punk::ansi::ta::split_codes_single $text]
foreach {pt codegroup} $parts {
foreach {pt code} $parts {
switch -- [llength $codestack] {
0 {
append emit $base $pt $R
@ -3489,46 +3489,44 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
}
}
#parts ends on a pt - last codegroup always empty string
if {$codegroup ne ""} {
foreach code [punk::ansi::ta::get_codes_single $codegroup] {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
\x9b 8CSI\
\x1b\( 7GFX\
] $c1c2] 0 3]
switch -- $leadernorm {
7CSI - 8CSI {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#todo - make caching is_sgr method
set dup_posns [lsearch -all -exact $codestack $code]
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
} else {
#parts ends on a pt - last code always empty string
if {$code ne ""} {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
\x9b 8CSI\
\x1b\( 7GFX\
] $c1c2] 0 3]
switch -- $leadernorm {
7CSI - 8CSI {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#todo - make caching is_sgr method
set dup_posns [lsearch -all -exact $codestack $code]
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
} else {
}
}
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set o_gx_state on
}
"B" {
set o_gx_state off
}
}
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set o_gx_state on
}
"B" {
set o_gx_state off
}
}
default {
#other ansi codes
}
}
append emit $code
default {
#other ansi codes
}
}
append emit $code
}
}
return [append emit $R]

1045
src/bootsupport/modules/punk/args-0.1.8.tm

File diff suppressed because it is too large Load Diff

7959
src/bootsupport/modules/punk/args-0.1.9.tm

File diff suppressed because it is too large Load Diff

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

@ -496,10 +496,10 @@ namespace eval punk::cap::handlers::templates {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\
""
@opts -anyopts 1
@opts -any true
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
@values -maxvalues -1 -unnamed true
}]
method get_itemdict_projectlayouts {args} {
@ -552,6 +552,13 @@ namespace eval punk::cap::handlers::templates {
}
return $layoutdict
}
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs " -help\
""
@opts -arbitrary true
@values -maxvalues -1 -unnamed 1
}]
method get_itemdict_projectlayoutrefs {args} {
set config {
-templatefolder_subdir "layout_refs"\

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

@ -641,7 +641,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles
-stripbase -default 1 -type boolean
-formatsizes -default 1 -type boolean -help "Format file size numbers for clarity"
@values -min 0 -max -1
@values -min 0 -max -1 -unnamed true
}
proc dirfiles {args} {
set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args]
@ -735,7 +735,7 @@ tcl::namespace::eval punk::nav::fs {
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
@values -min 0 -max -1 -type string -unnamed true
}
proc dirfiles_dict {args} {
set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
@ -998,7 +998,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles_dict_as_lines
-stripbase -default 0 -type boolean
-formatsizes -default 1 -type boolean
@values -min 1 -max -1 -type dict
@values -min 1 -max -1 -type dict -unnamed true
}
#todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing?

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

@ -2642,6 +2642,7 @@ tcl::namespace::eval punk::ns {
set querycommand [dict get $values commandpath]
set queryargs [dict get $values subcommand]
#puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'"
#todo - similar to corp? review corp resolution process
#should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented
@ -2878,15 +2879,19 @@ tcl::namespace::eval punk::ns {
set nextqueryargs [list] ;#build a list of prefix-resolved queryargs
set queryargs_untested $queryargs
foreach q $queryargs {
if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} {
if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} {
#todo: fix
set subitems [dict get $spec FORMS $fid LEADER_NAMES]
if {[llength $subitems]} {
set next [lindex $subitems 0]
set arginfo [dict get $spec FORMS $fid ARG_INFO $next]
set allchoices [list]
set choices [punk::args::system::Dict_getdef $arginfo -choices {}]
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}]
set choices [punk::args::system::Dict_getdef $arginfo -choices {}]
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}]
#maintenance smell - similar/dup of some punk::args logic - review
#-choiceprefixdenylist ??
set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}]
if {[dict exists $choicegroups ""]} {
dict lappend choicegroups "" {*}$choices
} else {
@ -2895,8 +2900,8 @@ tcl::namespace::eval punk::ns {
dict for {groupname clist} $choicegroups {
lappend allchoices {*}$clist
}
set resolved_q [tcl::prefix::match -error "" $allchoices $q]
if {$resolved_q eq ""} {
set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q]
if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} {
break
}
lappend nextqueryargs $resolved_q
@ -3600,7 +3605,30 @@ tcl::namespace::eval punk::ns {
}
#todo - package up as navns
proc corp {path} {
punk::args::define {
@id -id ::punk::ns::corp
@cmd -name punk::ns::corp -help\
"Show alias or proc information.
'corp' (being the reverse spelling of proc)
will display the Tcl 'proc name args body' statement
for the proc.
Essentially this is a convenient way to display the
proc body including argument info, instead of
separately calling 'info args <proc>' 'info body <proc>'
etc.
The body may display with an additional
comment inserted to display information such as the
namespace origin. Such a comment begins with #corp#."
@opts
@values -min 1 -max -1
commandname -help\
"May be either the fully qualified path for the command,
or a relative name that is resolvable from the current
namespace."
}
proc corp {args} {
set argd [punk::args::parse $args withid ::punk::ns::corp]
set path [dict get $argd values commandname]
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp
#Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name)
if {[info exists punk::console::tabwidth]} {

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

@ -191,6 +191,8 @@ tcl::namespace::eval punk::zip {
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
#If we don't include --, the call walk <options> -- <base> <globs>.. will return nothing as 'base' will receive the --
-- -type none -optional 1
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
@ -651,7 +653,7 @@ tcl::namespace::eval punk::zip {
}
array set opts [dict get $argd opts]
if {$opts(-directory) ne ""} {
if {$opts(-base) ne ""} {

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

@ -3928,8 +3928,8 @@ tcl::namespace::eval textblock {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
set allcols [tcl::dict::keys $o_columndata]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
@ -5559,8 +5559,8 @@ tcl::namespace::eval textblock {
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
"
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
blocks -type any -multiple 1
}
@ -8519,7 +8519,25 @@ tcl::namespace::eval textblock {
set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth]
set cache_patternwidth $actual_contentwidth
set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n]
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern]
#review - why do we wrap before overtype call if they have same ansibase?
#underlay is just a block of spaces
#set wrapped_underlay $opt_ansibase$underlay$rstbase
#cache_contentpattern is replacement chars
#set wrapped_cache_contentpattern $opt_ansibase$cache_contentpattern
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $underlay $cache_contentpattern]
#puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner"
if {$opt_ansibase ne ""} {
if {[punk::ansi::ta::detect $cache_inner]} {
set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
} else {
set cache_inner "$opt_ansibase$cache_inner\x1b\[0m"
}
}
#after overtype::block - our actual patternwidth may be less
set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]]
@ -8587,9 +8605,6 @@ tcl::namespace::eval textblock {
if {$actual_contentwidth == 0} {
set fs [tcl::string::map [list $FSUB " "] $template]
} else {
set resultlines [list]
set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set contentindex 0
switch -- $opt_textalign {
left {set pad right}
right {set pad left}
@ -8603,6 +8618,17 @@ tcl::namespace::eval textblock {
}
#set cwidth [textblock::width $contents]
#JJJ
set contents_has_ansi [punk::ansi::ta::detect $contents]
if {$opt_ansibase ne ""} {
if {$contents_has_ansi} {
set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
} else {
set contents "$opt_ansibase$contents\x1b\[0m"
set contents_has_ansi 1
}
}
set cwidth $actual_contentwidth
if {$opt_pad} {
set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth)
@ -8612,36 +8638,50 @@ tcl::namespace::eval textblock {
set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents]
}
#important to supply end of opts -- to textblock::join - particularly here with arbitrary data
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
if {$contents_has_ansi} {
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
} else {
set contentblock $paddedcontents
}
} else {
if {$cwidth > $cache_patternwidth} {
set contents [overtype::renderspace -width $cache_patternwidth "" $contents]
}
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
if {$contents_has_ansi} {
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
} else {
set contentblock $contents
}
}
set tlines [split $template \n]
#we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too.
#after textblock::join the reset will be a separate code ie should be exactly ESC[0m
set R [a]
set rlen [tcl::string::length $R]
set clines [split $contentblock \n]
set fs ""
#set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set pattern_offset [expr {$cache_patternwidth -1}]
set contentindex 0
foreach tline $tlines {
if {[tcl::string::first $FSUB $tline] >= 0} {
set subposn [tcl::string::first $FSUB $tline]
if {$subposn >= 0} {
set content_line [lindex $clines $contentindex]
if {[tcl::string::first $R [string range $content_line 0 10]] == 0} {
set content_line [tcl::string::range $content_line $rlen end]
#review - different forms of reset e.g \x1b\[m ??
if {[string range $content_line 0 3] eq "\x1b\[0m"} {
set content_line [tcl::string::range $content_line 4 end]
}
#make sure to replay opt_ansibase to the right of the replacement
lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline]
append content_line $opt_ansibase
append fs [tcl::string::replace $tline $subposn $subposn+$pattern_offset $content_line] \n
incr contentindex
} else {
lappend resultlines $tline
append fs $tline \n
}
}
set fs [::join $resultlines \n]
if {[string index $fs end] eq "\n"} {
set fs [string range $fs 0 end-1]
}
}

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

@ -481,6 +481,12 @@ tcl::namespace::eval punk::args {
The number of elements in -typeranges must match
the number of elements specified in -type.
-typesynopsis <typedisplay|typedisplaylist>
Must be same length as value in -type
This provides and override for synopsis display of types.
Any desired italicization must be applied manually to the
value.
-optional <boolean>
(defaults to true for flags/switches false otherwise)
For non flag/switch arguments - all arguments with
@ -3292,6 +3298,7 @@ tcl::namespace::eval punk::args {
#todo
set form_synopsis [punk::args::synopsis -form $fid [dict get $spec_dict id]]
if {[string length $form_synopsis] > 90} {
#
set form_synopsis [punk::args::synopsis -return summary -form $fid [dict get $spec_dict id]]
}
if {[string match (autodef)* $form_synopsis]} {
@ -6644,9 +6651,12 @@ tcl::namespace::eval punk::args {
}
if {$has_punkansi} {
set I [punk::ansi::a+ italic]
set RST [punk::ansi::a]
set NI [punk::ansi::a+ noitalic]
#set RST [punk::ansi::a]
set RST "\x1b\[m"
} else {
set I ""
set NI ""
set RST ""
}
@ -6727,17 +6737,18 @@ tcl::namespace::eval punk::args {
if {[llength $typelist] == 1} {
set tp [lindex $typelist 0]
if {[dict exists $arginfo -typesynopsis]} {
set arg_display [dict get $arginfo -typesynopsis]
} else {
set arg_display $argname
}
if {$tp eq "literal"} {
set clause [lindex $argname end]
} elseif {[string match literal(*) $tp]} {
set match [string range $tp 8 end-1]
set clause $match
#set arg_display [dict get $arginfo -typesynopsis]
set clause [dict get $arginfo -typesynopsis]
} else {
set clause $I$arg_display$RST
#set arg_display $argname
if {$tp eq "literal"} {
set clause [lindex $argname end]
} elseif {[string match literal(*) $tp]} {
set match [string range $tp 8 end-1]
set clause $match
} else {
set clause $I$argname$NI
}
}
} else {
set n [expr {[llength $typelist]-1}]
@ -6765,9 +6776,9 @@ tcl::namespace::eval punk::args {
set c $match
} else {
if {$td eq ""} {
set c $I$tp$RST
set c $I$tp$NI
} else {
set c $I$td$RST
set c $td
}
}
if {$member_optional} {
@ -6779,10 +6790,10 @@ tcl::namespace::eval punk::args {
set clause [string trimleft $clause]
}
set ARGD [dict create argname $argname class value]
set ARGD [dict create argname $argname class leader]
if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} {
if {[dict get $arginfo -multiple]} {
#set display "?$I$argname$RST?..."
#set display "?$I$argname$NI?..."
set display "?$clause?..."
} else {
set display "?$clause?"
@ -6791,12 +6802,12 @@ tcl::namespace::eval punk::args {
#} elseif {[dict get $arginfo -type] eq "literal"} {
# set display "?$argname?"
#} else {
# set display "?$I$argname$RST?"
# set display "?$I$argname$NI?"
#}
}
} else {
if {[dict get $arginfo -multiple]} {
#set display "$I$argname$RST ?$I$argname$RST?..."
#set display "$I$argname$NI ?$I$argname$NI?..."
set display "$clause ?$clause?..."
} else {
set display $clause
@ -6805,7 +6816,7 @@ tcl::namespace::eval punk::args {
#} elseif {[dict get $arginfo -type] eq "literal"} {
# set display $argname
#} else {
# set display "$I$argname$RST"
# set display "$I$argname$NI"
#}
}
}
@ -6822,8 +6833,25 @@ tcl::namespace::eval punk::args {
if {[dict exists $arginfo -typesynopsis]} {
set tp_display [dict get $arginfo -typesynopsis]
} else {
set tp_display "<$tp>"
#set tp_display "<$tp>"
set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first)
foreach tp_member [split $tp |] {
#-type literal not valid for opt - review
if {[string match literal(*) $tp_member]} {
set match [string range $tp_member 8 end-1]
lappend alternates $match
} elseif {[string match literalprefix(*) $tp_member]} {
set match [string range $tp_member 14 end-1]
lappend alternates $match
} else {
lappend alternates $I<$tp_member>$NI
}
}
#todo - trie prefixes display?
set alternates [punk::args::lib::lunique $alternates]
set tp_display [join $alternates |]
}
if {[dict get $arginfo -optional]} {
if {[dict get $arginfo -multiple]} {
if {$tp eq "none"} {
@ -6865,28 +6893,29 @@ tcl::namespace::eval punk::args {
if {[llength $typelist] == 1} {
set tp [lindex $typelist 0]
if {[dict exists $arginfo -typesynopsis]} {
set arg_display [dict get $arginfo -typesynopsis]
#set arg_display [dict get $arginfo -typesynopsis]
set clause [dict get $arginfo -typesynopsis]
} else {
set arg_display $argname
}
set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first)
foreach tp_member [split $tp |] {
if {$tp_member eq "literal"} {
lappend alternates [lindex $argname end]
} elseif {[string match literal(*) $tp_member]} {
set match [string range $tp_member 8 end-1]
lappend alternates $match
} elseif {[string match literalprefix(*) $tp_member]} {
set match [string range $tp_member 14 end-1]
lappend alternates $match
} else {
lappend alternates $I$arg_display$RST
#set arg_display $argname
set alternates [list];#alternate acceptable types e.g literal(yes)|literal(ok) or indexpression|literal(first)
foreach tp_member [split $tp |] {
if {$tp_member eq "literal"} {
lappend alternates [lindex $argname end]
} elseif {[string match literal(*) $tp_member]} {
set match [string range $tp_member 8 end-1]
lappend alternates $match
} elseif {[string match literalprefix(*) $tp_member]} {
set match [string range $tp_member 14 end-1]
lappend alternates $match
} else {
lappend alternates $I$argname$NI
}
}
#remove dupes - but keep order (e.g of dupes -type string|int when no -typesynopsis was specified)
#todo - trie prefixes display
set alternates [punk::args::lib::lunique $alternates]
set clause [join $alternates |]
}
#remove dupes - but keep order (e.g of dupes -type string|int when no -typesynopsis was specified)
#todo - trie prefixes display
set alternates [punk::args::lib::lunique $alternates]
set clause [join $alternates |]
} else {
set n [expr {[llength $typelist]-1}]
set name_tail [lrange $argname end-$n end];#if there are enough tail words in the argname to match -types
@ -6919,9 +6948,9 @@ tcl::namespace::eval punk::args {
lappend alternates $match
} else {
if {$td eq ""} {
lappend alternates $I$tp$RST
lappend alternates $I$tp$NI
} else {
lappend alternates $I$td$RST
lappend alternates $td
}
}
}
@ -6939,7 +6968,7 @@ tcl::namespace::eval punk::args {
set ARGD [dict create argname $argname class value]
if {[dict get $arginfo -optional] || [dict exists $arginfo -default]} {
if {[dict get $arginfo -multiple]} {
#set display "?$I$argname$RST?..."
#set display "?$I$argname$NI?..."
set display "?$clause?..."
} else {
set display "?$clause?"
@ -6948,12 +6977,12 @@ tcl::namespace::eval punk::args {
#} elseif {[dict get $arginfo -type] eq "literal"} {
# set display "?$argname?"
#} else {
# set display "?$I$argname$RST?"
# set display "?$I$argname$NI?"
#}
}
} else {
if {[dict get $arginfo -multiple]} {
#set display "$I$argname$RST ?$I$argname$RST?..."
#set display "$I$argname$NI ?$I$argname$NI?..."
set display "$clause ?$clause?..."
} else {
set display $clause
@ -6962,7 +6991,7 @@ tcl::namespace::eval punk::args {
#} elseif {[dict get $arginfo -type] eq "literal"} {
# set display $argname
#} else {
# set display "$I$argname$RST"
# set display "$I$argname$NI"
#}
}
}
@ -6980,6 +7009,7 @@ tcl::namespace::eval punk::args {
}
summary {
set summary ""
showdict $SYND
dict for {form arglist} $SYND {
append summary $id
set class_state leader

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

@ -479,7 +479,6 @@ tcl::namespace::eval punk::args::tclcore {
method
} "@doc -name Manpage: -url [manpage_tcl info]"
#todo - make generic - take command and known_groups_dict
proc info_subcommands {} {
#package require punk::ns
#set subdict [punk::ns::ensemble_subcommands -return dict info]
@ -709,7 +708,7 @@ tcl::namespace::eval punk::args::tclcore {
@form -form {set}
@values -min 3 -max -1
channel
"optionName value" -type {string any} -typesynopsis {optionName value} -multiple 1 -optional 0
"optionName value" -type {string any} -typesynopsis {${$I}optionName value${$NI}} -multiple 1 -optional 0
} "@doc -name Manpage: -url [manpage_tcl chan]" ]
@ -815,7 +814,7 @@ tcl::namespace::eval punk::args::tclcore {
as arguments (keys and values alternating, with each key being followed by
its associated value)"
@values -min 2 -max -1
"key value" -type {string string} -typesynopsis {key value} -optional 1 -multiple 1
"key value" -type {string string} -typesynopsis {${$I}key${$NI} ${$I}value${$NI}} -optional 1 -multiple 1
} "@doc -name Manpage: -url [manpage_tcl dict]" ]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
lappend PUNKARGS [list {
@ -1116,8 +1115,8 @@ tcl::namespace::eval punk::args::tclcore {
to the ${$I}dictionaryVariable${$NI}'s contents only happen when ${$I}body${$NI} terminates."
@values -min 4 -max -1
dictionaryVariable -type string
"key varName" -type {any any} -typesynopsis {key varName} -optional 0 -multiple 1
body -type script -typesynopsis body<script> -optional 0
"key varName" -type {any any} -typesynopsis {${$I}key${$NI} ${$I}varName${$NI}} -optional 0 -multiple 1
body -type script -typesynopsis ${$I}body<script>${$NI} -optional 0
} "@doc -name Manpage: -url [manpage_tcl dict]" ]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
}
@ -3249,7 +3248,7 @@ tcl::namespace::eval punk::args::tclcore {
@opts
-nobackslashes -type none
-nocommands -type none
-novariable -type none
-novariables -type none
@values -min 1 -max -1
string -type string
} "@doc -name Manpage: -url [manpage_tcl subst]"
@ -3589,6 +3588,7 @@ tcl::namespace::eval punk::args::tclcore {
#we can't use 'namespace ensemble configure' to query it
#define subcommand documentation first
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@dynamic
@id -id "::zlib adler32"
@ -3601,6 +3601,7 @@ tcl::namespace::eval punk::args::tclcore {
initValue -type string -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@dynamic
@id -id "::zlib crc32"
@ -3613,6 +3614,7 @@ tcl::namespace::eval punk::args::tclcore {
initValue -type string -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@dynamic
@id -id "::zlib compress"
@ -3624,23 +3626,209 @@ tcl::namespace::eval punk::args::tclcore {
string -type string
level -type integer -range {0 9} -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@dynamic
@id -id "::zlib decompress"
@cmd -name "builtin: ::zlib compress" -help\
"Returns the uncompressed version of the raw compressed binary data in
${$I}string${$NI}. If present, ${$I}bufferSize${$NI} is a hint as to what size of buffer is to
be used to receive the data."
@values -min 1 -max 2
string -type string
bufferSize -type integer -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id "::zlib deflate"
@cmd -name "builtin: ::zlib deflate" -help\
"Returns the raw compressed binary data of the binary string in ${$I}string${$NI}.
If present, ${$I}level${$NI} gives the compression level to use (from 0, which is
uncompressed, to 9, maximally compressed)."
@values -min 1 -max 2
string -type string
level -type integer -range {0 9} -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id "::zlib push"
@cmd -name "builtin: ::zlib push" -help\
"Pushes a compressing or decompressing transformation onto the channel
channel. The transformation can be removed again with chan pop. The mode
argument determines what type of transformation is pushed.
Both compressing and decompressing channel transformations add extra
configuration options that may be accessed through chan configure.
The options are:
-checksum checksum
This read-only option gets the current checksum for the uncompressed
data that the compression engine has seen so far. It is valid for both
compressing and decompressing transforms, but not for the raw inflate
and deflate formats. The compression algorithm depends on what format
is being produced or consumed.
-dictionary binData
This read-write options gets or sets the initial compression dictionary
to use when working with compressing or decompressing the data to be
binData. It is not valid for transformations that work with gzip-format
data, and should not normally be set on compressing transformations
other than at the point where the transformation is stacked. Note that
this cannot be used to get the current active compression dictionary
mid-stream, as that information is not exposed by the underlying library.
-flush type
This write-only operation flushes the current state of the compressor to
the underlying channel. It is only valid for compressing transformations.
The type must be either sync or full for a normal flush or an expensive
flush respectively. Flushing degrades the compression ratio, but makes it
easier for a decompressor to recover more of the file in the case of data
corruption.
-header dictionary
This read-only option, only valid for decompressing transforms that are
processing gzip-format data, returns the dictionary describing the header
read off the data stream.
-limit readaheadLimit
This read-write option is used by decompressing channels to control the
maximum number of bytes ahead to read from the underlying data source.
See below for more information."
@leaders -min 1 -max 1
# -- --- --- --- --- --- --- --- --- --- ---
mode -type string -choicecolumns 2 -choices {compress decompress deflate gunzip gzip inflate} -choicelabels {
compress\
"The transformation will be a compressing
transformation that produces zlib-format
data on channel, which must be writable."
decompress\
"The transformation will be a decompressing
transformation that reads zlib-format data
from channel, which must be readable."
deflate\
"The transformation will be a compressing
transformation that produces raw compressed
data on channel, which must be writable."
gunzip\
"The transformation will be a decompressing
transformation that reads gzip-format data
from channel, which must be readable."
gzip\
"The transformation will be a compressing
transformation that produces gzip-format
data on channel, which must be writable."
inflate\
"The transformation will be a decompressing
transformation that reads raw compressed
data from channel, which must be readable."
}
@opts
-dictionary -type dict -typesynopsis ${$I}binData${$NI} -help\
"Sets the compression dictionary to use when working with compressing or
decompressing the data to be binData. Not valid for transformations that
work with gzip-format data. The dictionary should consist of strings
(byte sequences) that are likely to be encountered later in the data to
be compressed, with the most commonly used strings preferably put towards
the end of the dictionary. Tcl provides no mechanism for choosing a good
such dictionary for a particular data sequence."
-header -type dict -typesynopsis ${$I}dictionary${$NI} -help\
"Passes a description of the gzip header to create, in the same format that
zlib gzip understands."
-level -type integer -range {0 9} -typesynopsis ${$I}compressionLevel${$NI} -help\
"How hard to compress the data. Must be an integer from 0 (uncompressed) to
9 (maximally compressed)."
-limit -type integer -typesynopsis ${$I}readaheadLimit${$NI} -help\
"The maximum number of bytes ahead to read when decompressing.
This option has become irrelevant. It was originally introduced to prevent
Tcl from reading beyond the end of a compressed stream in multi-stream
channels to ensure that the data after was left alone for further reading,
at the cost of speed.
Tcl now automatically returns any bytes it has read beyond the end of a
compressed stream back to the channel, making them appear as unread to
further readers."
@values -min 0 -max 0
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id "::zlib gunzip"
@cmd -name "builtin: ::zlib gunzip" -help\
"Return the uncompressed contents of binary string ${$I}string${$NI}, which must have
been in gzip format. If ${$B}-headerVar${$N} is given, store a dictionary describing
the contents of the gzip header in the variable called varName. The keys of the
dictionary that may be present are:
${$B}comment${$N}
The comment field from the header, if present.
${$B}crc${$N}
A boolean value describing whether a CRC of the header is computed.
${$B}filename${$N}
The filename field from the header, if present.
${$B}os${$N}
The operating system type code field from the header (if not the QW unknown value).
See RFC 1952 for the meaning of these codes.
${$B}size${$N}
The size of the uncompressed data.
${$B}time${$N}
The time field from the header if non-zero, expected to be time that the file named
by the ${$B}filename${$N} field was modified. Suitable for use with ${$B}clock format${$N}.
${$B}type${$N}
The type of the uncompressed data (${$B}binary${$N} or ${$B}text${$N}) if known."
@leaders -min 1 -max 1
string -type string
@opts
-headerVar -type string -typesynopsis ${$I}varName${$NI}
@values -max 0
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id "::zlib gzip"
@cmd -name "builtin: ::zlib gzip" -help\
"Return the compressed contents of binary string string in gzip format.
If -level is given, level gives the compression level to use (from 0,
which is uncompressed, to 9, maximally compressed). If -header is given,
dict is a dictionary containing values used for the gzip header.
The following keys may be defined:
${$B}comment${$N}
Add the given comment to the header of the gzip-format data.
${$B}crc${$N}
A boolean saying whether to compute a CRC of the header. Note that
if the data is to be interchanged with the gzip program, a header CRC
should not be computed.
${$B}filename${$N}
The name of the file that the data to be compressed came from.
${$B}os${$N}
The operating system type code, which should be one of the values
described in RFC 1952.
${$B}time${$N}
The time that the file named in the filename key was last modified.
This will be in the same as is returned by clock seconds or ${$B}file
mtime${$N}.
${$B}type${$N}
The type of the data being compressed, being ${$B}binary${$N} or ${$B}text${$N}."
@leaders -min 1 -max 1
string -type string
@opts
-level -type integer -range {0 9} -typesynopsis ${$I}level${$NI}
-header -type dict -typesynopsis ${$I}dict${$NI}
@values -max 0
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set CHOICES [list compress decompress deflate gunzip gzip inflate push stream adler32 crc32]
#manual synopses for subcommands not yet defined
set CHOICELABELS {
set CHOICELABELS [subst -novariables {
compress "zlib compress string ?level?"
decompress "zlib decompress string ?buffersize?"
deflate "zlib deflate string ?level?"
gunzip "zlib gunzip string ?-headerVar varName?"
gzip "zlib gzip string ?-level level? ?-header dict?"
inflate "zlib inflate string ?bufferSize?"
push "zlib push mode channel ?options ...?"
push "zlib push [punk::ansi::a+ italic]mode[punk::ansi::a+ noitalic] channel ?options ...?"
stream "zlib stream mode ?options?"
adler32 "zlib adler32 string ?initValue?"
crc32 "zlib crc32 string ?initValue?"
}
}]
set CHOICEINFO [dict create]
foreach sub $CHOICES {
#default for all
@ -3674,6 +3862,293 @@ tcl::namespace::eval punk::args::tclcore {
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zlib]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
proc zipfs_subcommands {} {
dict set groups "" {canonical exists find info list mount mountdata root unmount}
dict set groups "ZIP Creation" {mkzip mkimg mkkey lmkimg lmkzip}
return [ensemble_subcommands_definition -groupdict $groups -columns 3 zipfs]
}
set DYN_ZIPFS_SUBCOMMANDS {${[punk::args::tclcore::argdoc::zipfs_subcommands]}}
punk::args::define {
@dynamic
@id -id ::zipfs
@cmd -name "builtin: ::zipfs" -help\
"Mount and work with ZIP files within Tcl
The ${$B}zipfs${$N} command provides Tcl with the ability to mount the contents of a
ZIP archive file as a virtual file system. Tcl's ZIP archive support is
limited to basic features and options. Supported storage methods include
only STORE and DEFLATE with optional simple encryption, sufficient to
prevent casual inspection of their contents but not able to prevent access
by even a moderately determined attacker. Strong encryption, multi-part
archives, platform metadata, zip64 formats and other compression methods
like bzip2 are not supported.
Files within mounted archives can be written to but new files or directories
cannot be created. Further, modifications to files are limited to the
mounted archive in memory and are not persisted to disk.
Paths in mounted archives are case-sensitive on all platforms."
@leaders -min 1 -max 1
${$DYN_ZIPFS_SUBCOMMANDS}
@values -min 0
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::canonical
@cmd -name "builtin: ::zipfs::canonical" -help\
"This takes the name of a file, ${$I}filename${$NI}, and produces where it would be
mapped into a zipfs mount as its result. If specified, mountpoint says
within which mount the mapping will be done; if omitted, the main root of
the zipfs system is used."
@leaders -min 0 -max 0
@values -min 1 -max 1
mountpoint -type string -optional 1
filename -type string
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::exists
@cmd -name "builtin: ::zipfs::exists" -help\
"Return 1 if the given filename exists in the mounted zipfs and 0 if it does not."
@leaders -min 0 -max 0
@values -min 1 -max 1
filename -type file
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::find
@cmd -name "builtin: ::zipfs::find" -help\
"Returns the list of paths under directory ${$I}directoryName${$NI} which need not
be within a zipfs mounted archive. The paths are prefixed with
${$I}directoryName${$NI}. This command is also used by the ${$B}zipfs mkzip${$N} and
${$B}zipfs mkimg${$N} commands."
@leaders -min 0 -max 0
@values -min 1 -max 1
directoryName -type directory
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::info
@cmd -name "builtin: ::zipfs::info" -help\
"Return information about the given ${$I}file${$NI} in the mounted zipfs.
The information consists of:
1. the name of the ZIP archive file that contains the file,
2. the size of the file after decompressions,
3. the compressed size of the file, and
4. the offset of the compressed data in the ZIP archive file.
As a special case, querying the mount point gives the start of the zip
data as the offset in (4), which can be used to truncate the zip
information from an executable. Querying an ancestor of a mount point
will raise an error."
@leaders -min 0 -max 0
@values -min 1 -max 1
file -type string
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::list
@cmd -name "builtin: ::zipfs::list" -help\
"If pattern is not specified, the command returns a list of files across
all zipfs mounted archives. If pattern is specified, only those paths
matching the pattern are returned. By default, or with the -glob option,
the pattern is treated as a glob pattern and matching is done as described
for the string match command. Alternatively, the -regexp option may be
used to specify matching pattern as a regular expression. The file names
are returned in arbitrary order. Note that path separators are treated as
ordinary characters in the matching. Thus forward slashes should be used
as path separators in the pattern. The returned paths only include those
actually in the archive and does not include intermediate directories in
mount paths."
@leaders -min 0 -max 0
@values -min 1 -max 1
#patterntype -type literalprefix(-glob)|literalprefix(-regexp) -optional 1
patterntype -type string -default -glob -choices {-glob -regexp} -typesynopsis -glob|-regex
pattern -type string -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::lmkimg
@cmd -name "builtin: ::zipfs::lmkimg" -help\
"This command is like ${$B}zipfs mkimg${$N}, but instead of an input directory,
${$I}inlist${$NI} must be a Tcl list where the odd elements are the names of files
to be copied into the archive in the image, and the even elements are
their respective names within that archive."
@leaders -min 0 -max 0
@values -min 2 -max 4
outfile -type file
inlist -type dict
password -type any -optional 1
infile -type file -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::lmkzip
@cmd -name "builtin: ::zipfs::lmkzip" -help\
"This command is like ${$B}zipfs mkzip${$N}, but instead of an input directory,
${$I}inlist${$NI} must be a Tcl list where the odd elements are the names of files
to be copied into the archive, and the even elements are their respective
names within that archive."
@leaders -min 0 -max 0
@values -min 2 -max 3
outfile -type file
inlist -type dict
password -type any -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::mount
@cmd -name "builtin: ::zipfs::mount" -help\
"The ${$B}zipfs mount${$N} command mounts ZIP archives as Tcl virtual file systems
and returns information about current mounts.
With no arguments, the command returns a dictionary mapping mount points
to the path of the corresponding ZIP archive.
In the single argument form, the command returns the file path of the ZIP
archive mounted at the specified mount point.
In the third form, the command mounts the ZIP archive zipfile as a Tcl
virtual filesystem at ${$I}mountpoint${$NI}. After this command executes, files
contained in zipfile will appear to Tcl to be regular files at the mount
point. If ${$I}mountpoint${$NI} is specified as an empty string, it is defaulted to
the ${$B}[zipfs root]${$N}. The command returns the normalized mount point path.
If not under the zipfs file system root, ${$I}mountpoint${$NI} is normalized with
respect to it. For example, a mount point passed as either ${$B}mt${$N} or ${$B}/mt${$N} would
be normalized to ${$B}//zipfs:/mt${$N} (given that ${$B}zipfs root${$N} returns “//zipfs:/”).
An error is raised if the mount point includes a drive or UNC volume.
${$B}NB${$N}: because the current working directory is a concept maintained by the
operating system, using ${$B}cd${$N} into a mounted archive will only work in the
current process, and then not entirely consistently (e.g., if a shared
library uses direct access to the OS rather than through Tcl's filesystem
API, it will not see the current directory as being inside the mount and
will not be able to access the files inside the mount)."
@leaders -min 0 -max 0
@form -form dict
@values -min 0 -max 0
@form -form query
@values -min 1 -max 1
mountpoint
@form -form mount
@values -min 2 -max 3
zipfile -type file
mountpoint -type string
password -type string -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::mountdata
@cmd -name "builtin: ::zipfs::mountdata" -help\
"Mounts the ZIP archive content ${$I}data${$NI} as a Tcl virtual filesystem at ${$I}mountpoint${$NI}."
@leaders -min 0 -max 0
@values -min 1 -max 1
data -type any
mountpoint -type string
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::mkzip
@cmd -name "builtin: ::zipfs::mkzip" -help\
"Creates a ZIP archive file named outfile from the contents of the input
directory indir (contained regular files only) with optional ZIP password
password. While processing the files below indir the optional file name
prefix given in strip is stripped off the beginning of the respective file
name if non-empty. When stripping, it is common to remove either the whole
source directory name or the name of its parent directory.
Caution: the choice of the indir parameter (less the optional stripped
prefix) determines the later root name of the archive's content."
@leaders -min 0 -max 0
@values -min 2 -max 4
outfile
indir
strip -type string -optional 1 -help\
"file name prefix"
password -type any -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::mkimg
@cmd -name "builtin: ::zipfs::mkzip" -help\
"Creates an image (potentially a new executable file) similar to ${$B}zipfs mkzip${$N};
see that command for a description of most parameters to this command, as
they behave identically here. If outfile exists, it will be silently
overwritten.
If the ${$I}infile${$NI} parameter is specified, this file is prepended in front of the
ZIP archive, otherwise the file returned by ${$B}info nameofexecutable${$N} (i.e., the
executable file of the running process, typically ${$B}wish${$N} or ${$B}tclsh${$N}) is used. If
the ${$I}password${$NI} parameter is not the empty string, an obfuscated version of that
password (see ${$B}zipfs mkkey${$N}) is placed between the image and ZIP chunks of the
output file and the contents of the ZIP chunk are protected with that
password. If the starting image has a ZIP archive already attached to it, it
is removed from the copy in ${$I}outfile${$NI} before the new ZIP archive is added.
If there is a file, main.tcl, in the root directory of the resulting archive
and the image file that the archive is attached to is a ${$B}tclsh${$N} (or ${$B}wish${$N})
instance (true by default, but depends on your configuration), then the
resulting image is an executable that will ${$B}source${$N} the script in that main.tcl
after mounting the ZIP archive, and will ${$B}exit${$N} once that script has been
executed.
Note: ${$B}tclsh${$N} and ${$B}wish${$N} can be built using either dynamic binding or static
binding of the core implementation libraries. With a dynamic binding, the
base application Tcl_Library contents are attached to the libtcl and libtk
shared library, respectively. With a static binding, the Tcl_Library contents,
etc., are attached to the application, tclsh or wish. When using ${$B}mkimg${$N} with a
statically built tclsh, it is the user's responsibility to preserve the
attached archive by first extracting it to a temporary location, and then add
whatever additional files desired, before creating and attaching the new
archive to the new application."
@leaders -min 0 -max 0
@values -min 2 -max 5
outfile
indir
strip -type string -optional 1 -help\
"file name prefix"
password -type string -optional 1
infile -type string -optional 1
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::mkkey
@cmd -name "builtin: ::zipfs::mkzip" -help\
"Given the clear text ${$I}password${$NI} argument, an obfuscated string version is
returned with the same format used in the ${$B}zipfs mkimg${$N} command."
@leaders -min 0 -max 0
@values -min 1 -max 1
password -type string
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::root
@cmd -name "builtin: ::zipfs::root" -help\
"Returns a constant string which indicates the mount point for zipfs
volumes for the current platform. User should not rely on the mount point
being the same constant string for all platforms."
@leaders -min 0 -max 0
@opts -min 0 -max 0
@values -min 0 -max 0
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
punk::args::define {
@id -id ::tcl::zipfs::unmount
@cmd -name "builtin: ::zipfs::unmount" -help\
"Unmounts a previously mounted ZIP archive mounted to ${$I}mountpoint${$NI}. The
command will fail with an error exception if there are any files within
the mounted archive are open."
@leaders -min 0 -max 0
@opts -min 0 -max 0
@values -min 1 -max 1
mountpoint
} "@doc -name Manpage: -url [punk::args::tclcore::manpage_tcl zipfs]"
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---

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

@ -191,6 +191,8 @@ tcl::namespace::eval punk::zip {
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
#If we don't include --, the call walk <options> -- <base> <globs>.. will return nothing as 'base' will receive the --
-- -type none -optional 1
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
@ -651,7 +653,7 @@ tcl::namespace::eval punk::zip {
}
array set opts [dict get $argd opts]
if {$opts(-directory) ne ""} {
if {$opts(-base) ne ""} {

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

@ -3463,7 +3463,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set emit ""
#set parts [punk::ansi::ta::split_codes $text]
set parts [punk::ansi::ta::split_codes_single $text]
foreach {pt codegroup} $parts {
foreach {pt code} $parts {
switch -- [llength $codestack] {
0 {
append emit $base $pt $R
@ -3489,46 +3489,44 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
}
}
#parts ends on a pt - last codegroup always empty string
if {$codegroup ne ""} {
foreach code [punk::ansi::ta::get_codes_single $codegroup] {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
\x9b 8CSI\
\x1b\( 7GFX\
] $c1c2] 0 3]
switch -- $leadernorm {
7CSI - 8CSI {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#todo - make caching is_sgr method
set dup_posns [lsearch -all -exact $codestack $code]
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
} else {
#parts ends on a pt - last code always empty string
if {$code ne ""} {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
\x9b 8CSI\
\x1b\( 7GFX\
] $c1c2] 0 3]
switch -- $leadernorm {
7CSI - 8CSI {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#todo - make caching is_sgr method
set dup_posns [lsearch -all -exact $codestack $code]
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
} else {
}
}
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set o_gx_state on
}
"B" {
set o_gx_state off
}
}
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set o_gx_state on
}
"B" {
set o_gx_state off
}
}
default {
#other ansi codes
}
}
append emit $code
default {
#other ansi codes
}
}
append emit $code
}
}
return [append emit $R]

1045
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.8.tm

File diff suppressed because it is too large Load Diff

7959
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.9.tm

File diff suppressed because it is too large Load Diff

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

@ -496,10 +496,10 @@ namespace eval punk::cap::handlers::templates {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\
""
@opts -anyopts 1
@opts -any true
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
@values -maxvalues -1 -unnamed true
}]
method get_itemdict_projectlayouts {args} {
@ -552,6 +552,13 @@ namespace eval punk::cap::handlers::templates {
}
return $layoutdict
}
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs " -help\
""
@opts -arbitrary true
@values -maxvalues -1 -unnamed 1
}]
method get_itemdict_projectlayoutrefs {args} {
set config {
-templatefolder_subdir "layout_refs"\

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

@ -641,7 +641,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles
-stripbase -default 1 -type boolean
-formatsizes -default 1 -type boolean -help "Format file size numbers for clarity"
@values -min 0 -max -1
@values -min 0 -max -1 -unnamed true
}
proc dirfiles {args} {
set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args]
@ -735,7 +735,7 @@ tcl::namespace::eval punk::nav::fs {
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
@values -min 0 -max -1 -type string -unnamed true
}
proc dirfiles_dict {args} {
set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
@ -998,7 +998,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles_dict_as_lines
-stripbase -default 0 -type boolean
-formatsizes -default 1 -type boolean
@values -min 1 -max -1 -type dict
@values -min 1 -max -1 -type dict -unnamed true
}
#todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing?

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

@ -2642,6 +2642,7 @@ tcl::namespace::eval punk::ns {
set querycommand [dict get $values commandpath]
set queryargs [dict get $values subcommand]
#puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'"
#todo - similar to corp? review corp resolution process
#should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented
@ -2878,15 +2879,19 @@ tcl::namespace::eval punk::ns {
set nextqueryargs [list] ;#build a list of prefix-resolved queryargs
set queryargs_untested $queryargs
foreach q $queryargs {
if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} {
if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} {
#todo: fix
set subitems [dict get $spec FORMS $fid LEADER_NAMES]
if {[llength $subitems]} {
set next [lindex $subitems 0]
set arginfo [dict get $spec FORMS $fid ARG_INFO $next]
set allchoices [list]
set choices [punk::args::system::Dict_getdef $arginfo -choices {}]
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}]
set choices [punk::args::system::Dict_getdef $arginfo -choices {}]
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}]
#maintenance smell - similar/dup of some punk::args logic - review
#-choiceprefixdenylist ??
set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}]
if {[dict exists $choicegroups ""]} {
dict lappend choicegroups "" {*}$choices
} else {
@ -2895,8 +2900,8 @@ tcl::namespace::eval punk::ns {
dict for {groupname clist} $choicegroups {
lappend allchoices {*}$clist
}
set resolved_q [tcl::prefix::match -error "" $allchoices $q]
if {$resolved_q eq ""} {
set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q]
if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} {
break
}
lappend nextqueryargs $resolved_q
@ -3600,7 +3605,30 @@ tcl::namespace::eval punk::ns {
}
#todo - package up as navns
proc corp {path} {
punk::args::define {
@id -id ::punk::ns::corp
@cmd -name punk::ns::corp -help\
"Show alias or proc information.
'corp' (being the reverse spelling of proc)
will display the Tcl 'proc name args body' statement
for the proc.
Essentially this is a convenient way to display the
proc body including argument info, instead of
separately calling 'info args <proc>' 'info body <proc>'
etc.
The body may display with an additional
comment inserted to display information such as the
namespace origin. Such a comment begins with #corp#."
@opts
@values -min 1 -max -1
commandname -help\
"May be either the fully qualified path for the command,
or a relative name that is resolvable from the current
namespace."
}
proc corp {args} {
set argd [punk::args::parse $args withid ::punk::ns::corp]
set path [dict get $argd values commandname]
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp
#Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name)
if {[info exists punk::console::tabwidth]} {

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

@ -191,6 +191,8 @@ tcl::namespace::eval punk::zip {
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
#If we don't include --, the call walk <options> -- <base> <globs>.. will return nothing as 'base' will receive the --
-- -type none -optional 1
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
@ -651,7 +653,7 @@ tcl::namespace::eval punk::zip {
}
array set opts [dict get $argd opts]
if {$opts(-directory) ne ""} {
if {$opts(-base) ne ""} {

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

@ -3928,8 +3928,8 @@ tcl::namespace::eval textblock {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
set allcols [tcl::dict::keys $o_columndata]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
@ -5559,8 +5559,8 @@ tcl::namespace::eval textblock {
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
"
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
blocks -type any -multiple 1
}
@ -8519,7 +8519,25 @@ tcl::namespace::eval textblock {
set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth]
set cache_patternwidth $actual_contentwidth
set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n]
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern]
#review - why do we wrap before overtype call if they have same ansibase?
#underlay is just a block of spaces
#set wrapped_underlay $opt_ansibase$underlay$rstbase
#cache_contentpattern is replacement chars
#set wrapped_cache_contentpattern $opt_ansibase$cache_contentpattern
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $underlay $cache_contentpattern]
#puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner"
if {$opt_ansibase ne ""} {
if {[punk::ansi::ta::detect $cache_inner]} {
set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
} else {
set cache_inner "$opt_ansibase$cache_inner\x1b\[0m"
}
}
#after overtype::block - our actual patternwidth may be less
set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]]
@ -8587,9 +8605,6 @@ tcl::namespace::eval textblock {
if {$actual_contentwidth == 0} {
set fs [tcl::string::map [list $FSUB " "] $template]
} else {
set resultlines [list]
set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set contentindex 0
switch -- $opt_textalign {
left {set pad right}
right {set pad left}
@ -8603,6 +8618,17 @@ tcl::namespace::eval textblock {
}
#set cwidth [textblock::width $contents]
#JJJ
set contents_has_ansi [punk::ansi::ta::detect $contents]
if {$opt_ansibase ne ""} {
if {$contents_has_ansi} {
set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
} else {
set contents "$opt_ansibase$contents\x1b\[0m"
set contents_has_ansi 1
}
}
set cwidth $actual_contentwidth
if {$opt_pad} {
set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth)
@ -8612,36 +8638,50 @@ tcl::namespace::eval textblock {
set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents]
}
#important to supply end of opts -- to textblock::join - particularly here with arbitrary data
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
if {$contents_has_ansi} {
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
} else {
set contentblock $paddedcontents
}
} else {
if {$cwidth > $cache_patternwidth} {
set contents [overtype::renderspace -width $cache_patternwidth "" $contents]
}
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
if {$contents_has_ansi} {
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
} else {
set contentblock $contents
}
}
set tlines [split $template \n]
#we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too.
#after textblock::join the reset will be a separate code ie should be exactly ESC[0m
set R [a]
set rlen [tcl::string::length $R]
set clines [split $contentblock \n]
set fs ""
#set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set pattern_offset [expr {$cache_patternwidth -1}]
set contentindex 0
foreach tline $tlines {
if {[tcl::string::first $FSUB $tline] >= 0} {
set subposn [tcl::string::first $FSUB $tline]
if {$subposn >= 0} {
set content_line [lindex $clines $contentindex]
if {[tcl::string::first $R [string range $content_line 0 10]] == 0} {
set content_line [tcl::string::range $content_line $rlen end]
#review - different forms of reset e.g \x1b\[m ??
if {[string range $content_line 0 3] eq "\x1b\[0m"} {
set content_line [tcl::string::range $content_line 4 end]
}
#make sure to replay opt_ansibase to the right of the replacement
lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline]
append content_line $opt_ansibase
append fs [tcl::string::replace $tline $subposn $subposn+$pattern_offset $content_line] \n
incr contentindex
} else {
lappend resultlines $tline
append fs $tline \n
}
}
set fs [::join $resultlines \n]
if {[string index $fs end] eq "\n"} {
set fs [string range $fs 0 end-1]
}
}

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

@ -3463,7 +3463,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set emit ""
#set parts [punk::ansi::ta::split_codes $text]
set parts [punk::ansi::ta::split_codes_single $text]
foreach {pt codegroup} $parts {
foreach {pt code} $parts {
switch -- [llength $codestack] {
0 {
append emit $base $pt $R
@ -3489,46 +3489,44 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
}
}
#parts ends on a pt - last codegroup always empty string
if {$codegroup ne ""} {
foreach code [punk::ansi::ta::get_codes_single $codegroup] {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
\x9b 8CSI\
\x1b\( 7GFX\
] $c1c2] 0 3]
switch -- $leadernorm {
7CSI - 8CSI {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#todo - make caching is_sgr method
set dup_posns [lsearch -all -exact $codestack $code]
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
} else {
#parts ends on a pt - last code always empty string
if {$code ne ""} {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
\x9b 8CSI\
\x1b\( 7GFX\
] $c1c2] 0 3]
switch -- $leadernorm {
7CSI - 8CSI {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#todo - make caching is_sgr method
set dup_posns [lsearch -all -exact $codestack $code]
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
} else {
}
}
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set o_gx_state on
}
"B" {
set o_gx_state off
}
}
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set o_gx_state on
}
"B" {
set o_gx_state off
}
}
default {
#other ansi codes
}
}
append emit $code
default {
#other ansi codes
}
}
append emit $code
}
}
return [append emit $R]

1045
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.8.tm

File diff suppressed because it is too large Load Diff

7959
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.9.tm

File diff suppressed because it is too large Load Diff

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

@ -496,10 +496,10 @@ namespace eval punk::cap::handlers::templates {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\
""
@opts -anyopts 1
@opts -any true
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
@values -maxvalues -1 -unnamed true
}]
method get_itemdict_projectlayouts {args} {
@ -552,6 +552,13 @@ namespace eval punk::cap::handlers::templates {
}
return $layoutdict
}
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs " -help\
""
@opts -arbitrary true
@values -maxvalues -1 -unnamed 1
}]
method get_itemdict_projectlayoutrefs {args} {
set config {
-templatefolder_subdir "layout_refs"\

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

@ -641,7 +641,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles
-stripbase -default 1 -type boolean
-formatsizes -default 1 -type boolean -help "Format file size numbers for clarity"
@values -min 0 -max -1
@values -min 0 -max -1 -unnamed true
}
proc dirfiles {args} {
set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args]
@ -735,7 +735,7 @@ tcl::namespace::eval punk::nav::fs {
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
@values -min 0 -max -1 -type string -unnamed true
}
proc dirfiles_dict {args} {
set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
@ -998,7 +998,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles_dict_as_lines
-stripbase -default 0 -type boolean
-formatsizes -default 1 -type boolean
@values -min 1 -max -1 -type dict
@values -min 1 -max -1 -type dict -unnamed true
}
#todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing?

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

@ -2642,6 +2642,7 @@ tcl::namespace::eval punk::ns {
set querycommand [dict get $values commandpath]
set queryargs [dict get $values subcommand]
#puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'"
#todo - similar to corp? review corp resolution process
#should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented
@ -2878,15 +2879,19 @@ tcl::namespace::eval punk::ns {
set nextqueryargs [list] ;#build a list of prefix-resolved queryargs
set queryargs_untested $queryargs
foreach q $queryargs {
if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} {
if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} {
#todo: fix
set subitems [dict get $spec FORMS $fid LEADER_NAMES]
if {[llength $subitems]} {
set next [lindex $subitems 0]
set arginfo [dict get $spec FORMS $fid ARG_INFO $next]
set allchoices [list]
set choices [punk::args::system::Dict_getdef $arginfo -choices {}]
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}]
set choices [punk::args::system::Dict_getdef $arginfo -choices {}]
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}]
#maintenance smell - similar/dup of some punk::args logic - review
#-choiceprefixdenylist ??
set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}]
if {[dict exists $choicegroups ""]} {
dict lappend choicegroups "" {*}$choices
} else {
@ -2895,8 +2900,8 @@ tcl::namespace::eval punk::ns {
dict for {groupname clist} $choicegroups {
lappend allchoices {*}$clist
}
set resolved_q [tcl::prefix::match -error "" $allchoices $q]
if {$resolved_q eq ""} {
set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q]
if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} {
break
}
lappend nextqueryargs $resolved_q
@ -3600,7 +3605,30 @@ tcl::namespace::eval punk::ns {
}
#todo - package up as navns
proc corp {path} {
punk::args::define {
@id -id ::punk::ns::corp
@cmd -name punk::ns::corp -help\
"Show alias or proc information.
'corp' (being the reverse spelling of proc)
will display the Tcl 'proc name args body' statement
for the proc.
Essentially this is a convenient way to display the
proc body including argument info, instead of
separately calling 'info args <proc>' 'info body <proc>'
etc.
The body may display with an additional
comment inserted to display information such as the
namespace origin. Such a comment begins with #corp#."
@opts
@values -min 1 -max -1
commandname -help\
"May be either the fully qualified path for the command,
or a relative name that is resolvable from the current
namespace."
}
proc corp {args} {
set argd [punk::args::parse $args withid ::punk::ns::corp]
set path [dict get $argd values commandname]
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp
#Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name)
if {[info exists punk::console::tabwidth]} {

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

@ -191,6 +191,8 @@ tcl::namespace::eval punk::zip {
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
#If we don't include --, the call walk <options> -- <base> <globs>.. will return nothing as 'base' will receive the --
-- -type none -optional 1
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
@ -651,7 +653,7 @@ tcl::namespace::eval punk::zip {
}
array set opts [dict get $argd opts]
if {$opts(-directory) ne ""} {
if {$opts(-base) ne ""} {

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

@ -3928,8 +3928,8 @@ tcl::namespace::eval textblock {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
set allcols [tcl::dict::keys $o_columndata]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
@ -5559,8 +5559,8 @@ tcl::namespace::eval textblock {
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
"
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
blocks -type any -multiple 1
}
@ -8519,7 +8519,25 @@ tcl::namespace::eval textblock {
set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth]
set cache_patternwidth $actual_contentwidth
set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n]
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern]
#review - why do we wrap before overtype call if they have same ansibase?
#underlay is just a block of spaces
#set wrapped_underlay $opt_ansibase$underlay$rstbase
#cache_contentpattern is replacement chars
#set wrapped_cache_contentpattern $opt_ansibase$cache_contentpattern
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $underlay $cache_contentpattern]
#puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner"
if {$opt_ansibase ne ""} {
if {[punk::ansi::ta::detect $cache_inner]} {
set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
} else {
set cache_inner "$opt_ansibase$cache_inner\x1b\[0m"
}
}
#after overtype::block - our actual patternwidth may be less
set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]]
@ -8587,9 +8605,6 @@ tcl::namespace::eval textblock {
if {$actual_contentwidth == 0} {
set fs [tcl::string::map [list $FSUB " "] $template]
} else {
set resultlines [list]
set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set contentindex 0
switch -- $opt_textalign {
left {set pad right}
right {set pad left}
@ -8603,6 +8618,17 @@ tcl::namespace::eval textblock {
}
#set cwidth [textblock::width $contents]
#JJJ
set contents_has_ansi [punk::ansi::ta::detect $contents]
if {$opt_ansibase ne ""} {
if {$contents_has_ansi} {
set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
} else {
set contents "$opt_ansibase$contents\x1b\[0m"
set contents_has_ansi 1
}
}
set cwidth $actual_contentwidth
if {$opt_pad} {
set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth)
@ -8612,36 +8638,50 @@ tcl::namespace::eval textblock {
set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents]
}
#important to supply end of opts -- to textblock::join - particularly here with arbitrary data
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
if {$contents_has_ansi} {
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
} else {
set contentblock $paddedcontents
}
} else {
if {$cwidth > $cache_patternwidth} {
set contents [overtype::renderspace -width $cache_patternwidth "" $contents]
}
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
if {$contents_has_ansi} {
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
} else {
set contentblock $contents
}
}
set tlines [split $template \n]
#we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too.
#after textblock::join the reset will be a separate code ie should be exactly ESC[0m
set R [a]
set rlen [tcl::string::length $R]
set clines [split $contentblock \n]
set fs ""
#set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set pattern_offset [expr {$cache_patternwidth -1}]
set contentindex 0
foreach tline $tlines {
if {[tcl::string::first $FSUB $tline] >= 0} {
set subposn [tcl::string::first $FSUB $tline]
if {$subposn >= 0} {
set content_line [lindex $clines $contentindex]
if {[tcl::string::first $R [string range $content_line 0 10]] == 0} {
set content_line [tcl::string::range $content_line $rlen end]
#review - different forms of reset e.g \x1b\[m ??
if {[string range $content_line 0 3] eq "\x1b\[0m"} {
set content_line [tcl::string::range $content_line 4 end]
}
#make sure to replay opt_ansibase to the right of the replacement
lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline]
append content_line $opt_ansibase
append fs [tcl::string::replace $tline $subposn $subposn+$pattern_offset $content_line] \n
incr contentindex
} else {
lappend resultlines $tline
append fs $tline \n
}
}
set fs [::join $resultlines \n]
if {[string index $fs end] eq "\n"} {
set fs [string range $fs 0 end-1]
}
}

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

@ -3463,7 +3463,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set emit ""
#set parts [punk::ansi::ta::split_codes $text]
set parts [punk::ansi::ta::split_codes_single $text]
foreach {pt codegroup} $parts {
foreach {pt code} $parts {
switch -- [llength $codestack] {
0 {
append emit $base $pt $R
@ -3489,46 +3489,44 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
}
}
#parts ends on a pt - last codegroup always empty string
if {$codegroup ne ""} {
foreach code [punk::ansi::ta::get_codes_single $codegroup] {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
\x9b 8CSI\
\x1b\( 7GFX\
] $c1c2] 0 3]
switch -- $leadernorm {
7CSI - 8CSI {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#todo - make caching is_sgr method
set dup_posns [lsearch -all -exact $codestack $code]
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
} else {
#parts ends on a pt - last code always empty string
if {$code ne ""} {
set c1c2 [tcl::string::range $code 0 1]
set leadernorm [tcl::string::range [tcl::string::map [list\
\x1b\[ 7CSI\
\x9b 8CSI\
\x1b\( 7GFX\
] $c1c2] 0 3]
switch -- $leadernorm {
7CSI - 8CSI {
if {[punk::ansi::codetype::is_sgr_reset $code]} {
set codestack [list "\x1b\[m"]
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} {
set codestack [list $code]
} elseif {[punk::ansi::codetype::is_sgr $code]} {
#todo - make caching is_sgr method
set dup_posns [lsearch -all -exact $codestack $code]
set codestack [lremove $codestack {*}$dup_posns]
lappend codestack $code
} else {
}
}
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set o_gx_state on
}
"B" {
set o_gx_state off
}
}
7GFX {
switch -- [tcl::string::index $code 2] {
"0" {
set o_gx_state on
}
"B" {
set o_gx_state off
}
}
default {
#other ansi codes
}
}
append emit $code
default {
#other ansi codes
}
}
append emit $code
}
}
return [append emit $R]

2131
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.8.tm

File diff suppressed because it is too large Load Diff

7959
src/vfs/_vfscommon.vfs/modules/punk/args-0.1.9.tm

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

11
src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm

@ -496,10 +496,10 @@ namespace eval punk::cap::handlers::templates {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayouts " -help\
""
@opts -anyopts 1
@opts -any true
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here
-startdir -default ""
@values -maxvalues -1
@values -maxvalues -1 -unnamed true
}]
method get_itemdict_projectlayouts {args} {
@ -552,6 +552,13 @@ namespace eval punk::cap::handlers::templates {
}
return $layoutdict
}
lappend ${class_ns}::PUNKARGS [list {
@id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs"
@cmd -name "punk::cap::handlers::templates::class::api get_itemdict_projectlayoutrefs " -help\
""
@opts -arbitrary true
@values -maxvalues -1 -unnamed 1
}]
method get_itemdict_projectlayoutrefs {args} {
set config {
-templatefolder_subdir "layout_refs"\

6
src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm

@ -641,7 +641,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles
-stripbase -default 1 -type boolean
-formatsizes -default 1 -type boolean -help "Format file size numbers for clarity"
@values -min 0 -max -1
@values -min 0 -max -1 -unnamed true
}
proc dirfiles {args} {
set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args]
@ -735,7 +735,7 @@ tcl::namespace::eval punk::nav::fs {
#with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du)
-with_sizes -default "\uFFFF" -type string
-with_times -default "\uFFFF" -type string
@values -min 0 -max -1 -type string
@values -min 0 -max -1 -type string -unnamed true
}
proc dirfiles_dict {args} {
set argd [punk::args::parse $args withid ::punk::nav::fs::dirfiles_dict]
@ -998,7 +998,7 @@ tcl::namespace::eval punk::nav::fs {
@id -id ::punk::nav::fs::dirfiles_dict_as_lines
-stripbase -default 0 -type boolean
-formatsizes -default 1 -type boolean
@values -min 1 -max -1 -type dict
@values -min 1 -max -1 -type dict -unnamed true
}
#todo - color key via repl-telemetry? help command? documentation? or add tag columns as done in namespace listing?

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

@ -2642,6 +2642,7 @@ tcl::namespace::eval punk::ns {
set querycommand [dict get $values commandpath]
set queryargs [dict get $values subcommand]
#puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'"
#todo - similar to corp? review corp resolution process
#should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented
@ -2878,15 +2879,19 @@ tcl::namespace::eval punk::ns {
set nextqueryargs [list] ;#build a list of prefix-resolved queryargs
set queryargs_untested $queryargs
foreach q $queryargs {
if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} {
if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} {
#todo: fix
set subitems [dict get $spec FORMS $fid LEADER_NAMES]
if {[llength $subitems]} {
set next [lindex $subitems 0]
set arginfo [dict get $spec FORMS $fid ARG_INFO $next]
set allchoices [list]
set choices [punk::args::system::Dict_getdef $arginfo -choices {}]
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}]
set choices [punk::args::system::Dict_getdef $arginfo -choices {}]
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}]
#maintenance smell - similar/dup of some punk::args logic - review
#-choiceprefixdenylist ??
set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}]
if {[dict exists $choicegroups ""]} {
dict lappend choicegroups "" {*}$choices
} else {
@ -2895,8 +2900,8 @@ tcl::namespace::eval punk::ns {
dict for {groupname clist} $choicegroups {
lappend allchoices {*}$clist
}
set resolved_q [tcl::prefix::match -error "" $allchoices $q]
if {$resolved_q eq ""} {
set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q]
if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} {
break
}
lappend nextqueryargs $resolved_q
@ -3600,7 +3605,30 @@ tcl::namespace::eval punk::ns {
}
#todo - package up as navns
proc corp {path} {
punk::args::define {
@id -id ::punk::ns::corp
@cmd -name punk::ns::corp -help\
"Show alias or proc information.
'corp' (being the reverse spelling of proc)
will display the Tcl 'proc name args body' statement
for the proc.
Essentially this is a convenient way to display the
proc body including argument info, instead of
separately calling 'info args <proc>' 'info body <proc>'
etc.
The body may display with an additional
comment inserted to display information such as the
namespace origin. Such a comment begins with #corp#."
@opts
@values -min 1 -max -1
commandname -help\
"May be either the fully qualified path for the command,
or a relative name that is resolvable from the current
namespace."
}
proc corp {args} {
set argd [punk::args::parse $args withid ::punk::ns::corp]
set path [dict get $argd values commandname]
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp
#Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name)
if {[info exists punk::console::tabwidth]} {

4
src/vfs/_vfscommon.vfs/modules/punk/zip-0.1.1.tm

@ -191,6 +191,8 @@ tcl::namespace::eval punk::zip {
-excludes -default "" -help "list of glob expressions to match against files and exclude"
-subpath -default "" -help\
"May contain glob chars for folder elements"
#If we don't include --, the call walk <options> -- <base> <globs>.. will return nothing as 'base' will receive the --
-- -type none -optional 1
@values -min 1 -max -1
base
fileglobs -default {*} -multiple 1
@ -651,7 +653,7 @@ tcl::namespace::eval punk::zip {
}
array set opts [dict get $argd opts]
if {$opts(-directory) ne ""} {
if {$opts(-base) ne ""} {

73
src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm

@ -12,6 +12,7 @@ package require punk::ansi
#The user can always use exec for different process error semantics (they don't get exitcode with exec)
namespace eval shellrun {
variable PUNKARGS
variable runout
variable runerr
@ -127,19 +128,35 @@ namespace eval shellrun {
#todo - investigate cause of punk86 run hanging sometimes. An 'after 500' before exit in the called script fixes the issue. punk87 doesn't seem to be affected.
lappend PUNKARGS [list {
@id -id ::shellrun::run
@leaders -min 0 -max 0
@opts
-nonewline -type none
-tcl -type none -default 0
-debug -type none -default 0
--timeout= -type integer
@values -min 1 -max -1
cmdname -type string
cmdarg -type any -multiple 1 -optional 1
}]
proc run {args} {
#set_last_run_display [list]
set splitargs [get_run_opts $args]
set runopts [dict get $splitargs runopts]
set runoptslong [dict get $splitargs runoptslong]
set cmdargs [dict get $splitargs cmdargs]
#set splitargs [get_run_opts $args]
#set runopts [dict get $splitargs runopts]
#set runoptslong [dict get $splitargs runoptslong]
#set cmdargs [dict get $splitargs cmdargs]
set argd [punk::args::parse $args withid ::shellrun::run]
lassign [dict values $argd] leaders opts values received
if {"-nonewline" in $runopts} {
if {[dict exists $received "-nonewline"]} {
set nonewline 1
} else {
set nonewline 0
}
#review nonewline does nothing here..
set idlist_stderr [list]
#we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do.
#stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command.
@ -151,15 +168,22 @@ namespace eval shellrun {
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}]
set callopts [dict create]
if {"-tcl" in $runopts} {
dict set callopts -tclscript 1
if {[dict exists $received "-tcl"]} {
dict set callopts -tclscript 1
}
if {"-debug" in $runopts} {
if {[dict exists $received "-debug"]} {
dict set callopts -debug 1
}
if {[dict exists $runoptslong --timeout]} {
dict set callopts -timeout [dict get $runoptslong --timeout] ;#convert to single dash
if {[dict exists $received --timeout]} {
dict set callopts -timeout [dict get $opts --timeout] ;#convert to single dash
}
set cmdname [dict get $values cmdname]
if {[dict exists $received cmdarg]} {
set cmdarglist [dict get $values cmdarg]
} else {
set cmdarglist {}
}
set cmdargs [concat $cmdname $cmdarglist]
#---------------------------------------------------------------------------------------------
set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ]
#---------------------------------------------------------------------------------------------
@ -178,19 +202,31 @@ namespace eval shellrun {
return $exitinfo
}
lappend PUNKARGS [list {
@id -id ::shellrun::runconsole
@leaders -min 0 -max 0
@opts
@values -min 1 -max -1
cmdname -type string
cmdarg -type any -multiple 1 -optional 1
}]
#run in the way tcl unknown does - but without regard to auto_noexec
proc runconsole {args} {
if {![llength $args]} {
error "no commandline specified"
return
set argd [punk::args::parse $args withid ::shellrun::runconsole]
lassign [dict values $argd] leaders opts values received
set cmdname [dict get $values cmdname]
if {[dict exists $received cmdarg]} {
set arglist [dict get $values cmdarg]
} else {
set arglist {}
}
set name [lindex $args 0]
set new [auto_execok $name]
set resolved_cmdname [auto_execok $cmdname]
set repl_runid [punk::get_repl_runid]
#set ::punk::last_run_display [list]
set redir ">&@stdout <@stdin"
uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions]
uplevel 1 [list ::catch [concat exec $redir $resolved_cmdname $arglist] ::tcl::UnknownResult ::tcl::UnknownOptions]
#we can't detect stdout/stderr output from the exec
#for now emit an extra \n on stderr
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console
@ -777,6 +813,11 @@ namespace eval shellrun {
}
}
namespace eval ::punk::args::register {
#use fully qualified so 8.6 doesn't find existing var in global namespace
lappend ::punk::args::register::NAMESPACES ::shellrun
}
package provide shellrun [namespace eval shellrun {
variable version

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

Binary file not shown.

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

@ -3928,8 +3928,8 @@ tcl::namespace::eval textblock {
set cols [tcl::dict::keys $o_columndata]
} else {
set cols [list]
set allcols [tcl::dict::keys $o_columndata]
foreach colspec $args {
set allcols [tcl::dict::keys $o_columndata]
if {[tcl::string::first .. $colspec] >=0} {
set parts [punk::ansi::ta::_perlish_split {\.\.} $colspec]
if {[llength $parts] != 3} {
@ -5559,8 +5559,8 @@ tcl::namespace::eval textblock {
"Join blocks of text line by line but don't add padding on each line to enforce uniform width.
Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner
"
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
-ansiresets -type any -default auto
-- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags"
blocks -type any -multiple 1
}
@ -8519,7 +8519,25 @@ tcl::namespace::eval textblock {
set cache_contentline [tcl::string::repeat $FSUB $actual_contentwidth]
set cache_patternwidth $actual_contentwidth
set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n]
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern]
#review - why do we wrap before overtype call if they have same ansibase?
#underlay is just a block of spaces
#set wrapped_underlay $opt_ansibase$underlay$rstbase
#cache_contentpattern is replacement chars
#set wrapped_cache_contentpattern $opt_ansibase$cache_contentpattern
set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $underlay $cache_contentpattern]
#puts "frame--->ansiwrap -rawansi [ansistring VIEW $opt_ansibase] $cache_inner"
if {$opt_ansibase ne ""} {
if {[punk::ansi::ta::detect $cache_inner]} {
set cache_inner [punk::ansi::ansiwrap -rawansi $opt_ansibase $cache_inner]
} else {
set cache_inner "$opt_ansibase$cache_inner\x1b\[0m"
}
}
#after overtype::block - our actual patternwidth may be less
set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]]
@ -8587,9 +8605,6 @@ tcl::namespace::eval textblock {
if {$actual_contentwidth == 0} {
set fs [tcl::string::map [list $FSUB " "] $template]
} else {
set resultlines [list]
set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set contentindex 0
switch -- $opt_textalign {
left {set pad right}
right {set pad left}
@ -8603,6 +8618,17 @@ tcl::namespace::eval textblock {
}
#set cwidth [textblock::width $contents]
#JJJ
set contents_has_ansi [punk::ansi::ta::detect $contents]
if {$opt_ansibase ne ""} {
if {$contents_has_ansi} {
set contents [punk::ansi::ansiwrap -rawansi $opt_ansibase $contents]
} else {
set contents "$opt_ansibase$contents\x1b\[0m"
set contents_has_ansi 1
}
}
set cwidth $actual_contentwidth
if {$opt_pad} {
set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth)
@ -8612,36 +8638,50 @@ tcl::namespace::eval textblock {
set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents]
}
#important to supply end of opts -- to textblock::join - particularly here with arbitrary data
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
if {$contents_has_ansi} {
set contentblock [textblock::join -- $paddedcontents] ;#make sure each line has ansi replays
} else {
set contentblock $paddedcontents
}
} else {
if {$cwidth > $cache_patternwidth} {
set contents [overtype::renderspace -width $cache_patternwidth "" $contents]
}
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
if {$contents_has_ansi} {
set contentblock [textblock::join -- $contents] ;# adds ansiresets and any required replays on each line
} else {
set contentblock $contents
}
}
set tlines [split $template \n]
#we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too.
#after textblock::join the reset will be a separate code ie should be exactly ESC[0m
set R [a]
set rlen [tcl::string::length $R]
set clines [split $contentblock \n]
set fs ""
#set overwritable [tcl::string::repeat $FSUB $cache_patternwidth]
set pattern_offset [expr {$cache_patternwidth -1}]
set contentindex 0
foreach tline $tlines {
if {[tcl::string::first $FSUB $tline] >= 0} {
set subposn [tcl::string::first $FSUB $tline]
if {$subposn >= 0} {
set content_line [lindex $clines $contentindex]
if {[tcl::string::first $R [string range $content_line 0 10]] == 0} {
set content_line [tcl::string::range $content_line $rlen end]
#review - different forms of reset e.g \x1b\[m ??
if {[string range $content_line 0 3] eq "\x1b\[0m"} {
set content_line [tcl::string::range $content_line 4 end]
}
#make sure to replay opt_ansibase to the right of the replacement
lappend resultlines [tcl::string::map [list $overwritable $content_line$opt_ansibase] $tline]
append content_line $opt_ansibase
append fs [tcl::string::replace $tline $subposn $subposn+$pattern_offset $content_line] \n
incr contentindex
} else {
lappend resultlines $tline
append fs $tline \n
}
}
set fs [::join $resultlines \n]
if {[string index $fs end] eq "\n"} {
set fs [string range $fs 0 end-1]
}
}

Loading…
Cancel
Save