Browse Source

better no_color support, slightly better ctrl-c handling (windows) + multishell.cmd fix to avoid batch file termination prompt

master
Julian Noble 6 months ago
parent
commit
b045baed30
  1. 201
      src/bootsupport/modules/oolib-0.1.2.tm
  2. 3655
      src/bootsupport/modules/overtype-1.6.3.tm
  3. 2118
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  4. 20
      src/bootsupport/modules/punk/char-0.1.0.tm
  5. 110
      src/bootsupport/modules/punk/console-0.1.1.tm
  6. 165
      src/bootsupport/modules/punk/lib-0.1.1.tm
  7. 8
      src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd
  8. 2
      src/bootsupport/modules/punk/ns-0.1.0.tm
  9. 2132
      src/bootsupport/modules/textblock-0.1.1.tm
  10. 18
      src/modules/punk-0.1.tm
  11. 427
      src/modules/punk/ansi-999999.0a1.0.tm
  12. 70
      src/modules/punk/console-999999.0a1.0.tm
  13. 8
      src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd
  14. 349
      src/modules/punk/repl-0.1.tm
  15. 111
      src/modules/shellfilter-0.1.9.tm
  16. 6
      src/modules/shellrun-0.1.1.tm
  17. 67
      src/modules/textblock-999999.0a1.0.tm
  18. 39
      src/modules/winlibreoffice-999999.0a1.0.tm
  19. 2
      src/punk86.vfs/lib/app-punk/repl.tcl
  20. 4
      src/punk86.vfs/main.tcl

201
src/bootsupport/modules/oolib-0.1.2.tm

@ -0,0 +1,201 @@
#JMN - api should be kept in sync with package patternlib where possible
#
package provide oolib [namespace eval oolib {
variable version
set version 0.1.2
}]
namespace eval oolib {
oo::class create collection {
variable o_data ;#dict
#variable o_alias
constructor {} {
set o_data [dict create]
}
method info {} {
return [dict info $o_data]
}
method count {} {
return [dict size $o_data]
}
method isEmpty {} {
expr {[dict size $o_data] == 0}
}
method names {{globOrIdx {}}} {
if {[llength $globOrIdx]} {
if {[string is integer -strict $globOrIdx]} {
set idx $globOrIdx
if {$idx < 0} {
set idx "end-[expr {abs($idx + 1)}]"
}
if {[catch {lindex [dict keys $o_data] $idx} result]} {
error "[self object] no such index : '$idx'"
} else {
return $result
}
} else {
#glob
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx]
}
} else {
return [dict keys $o_data]
}
}
#like names but without globbing
method keys {} {
dict keys $o_data
}
method key {{posn 0}} {
if {$posn < 0} {
set posn "end-[expr {abs($posn + 1)}]"
}
if {[catch {lindex [dict keys $o_data] $posn} result]} {
error "[self object] no such index : '$posn'"
} else {
return $result
}
}
method hasKey {key} {
dict exists $o_data $key
}
method get {} {
return $o_data
}
method items {} {
return [dict values $o_data]
}
method item {key} {
if {[string is integer -strict $key]} {
if {$key >= 0} {
set valposn [expr {(2*$key) +1}]
return [lindex $o_data $valposn]
} else {
set key "end-[expr {abs($key + 1)}]"
return [lindex $o_data $key]
#return [lindex [dict keys $o_data] $key]
}
}
if {[dict exists $o_data $key]} {
return [dict get $o_data $key]
}
}
#inverse lookup
method itemKeys {value} {
set value_indices [lsearch -all [dict values $o_data] $value]
set keylist [list]
foreach i $value_indices {
set idx [expr {(($i + 1) *2) -2}]
lappend keylist [lindex $o_data $idx]
}
return $keylist
}
method search {value args} {
set matches [lsearch {*}$args [dict values $o_data] $value]
if {"-inline" in $args} {
return $matches
} else {
set keylist [list]
foreach i $matches {
set idx [expr {(($i + 1) *2) -2}]
lappend keylist [lindex $o_data $idx]
}
return $keylist
}
}
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists?
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well?
#method alias {newAlias existingKeyOrAlias} {
# if {[string is integer -strict $newAlias]} {
# error "[self object] collection key alias cannot be integer"
# }
# if {[string length $existingKeyOrAlias]} {
# set o_alias($newAlias) $existingKeyOrAlias
# } else {
# unset o_alias($newAlias)
# }
#}
#method aliases {{key ""}} {
# if {[string length $key]} {
# set result [list]
# foreach {n v} [array get o_alias] {
# if {$v eq $key} {
# lappend result $n $v
# }
# }
# return $result
# } else {
# return [array get o_alias]
# }
#}
##if the supplied index is an alias, return the underlying key; else return the index supplied.
#method realKey {idx} {
# if {[catch {set o_alias($idx)} key]} {
# return $idx
# } else {
# return $key
# }
#}
method add {value key} {
if {[string is integer -strict $key]} {
error "[self object] collection key must not be an integer. Use another structure if integer keys required"
}
if {[dict exists $o_data $key]} {
error "[self object] col_processors object error: key '$key' already exists in collection"
}
dict set o_data $key $value
return [expr {[dict size $o_data] - 1}] ;#return index of item
}
method remove {idx {endRange ""}} {
if {[string length $endRange]} {
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time"
}
if {[string is integer -strict $idx]} {
if {$idx < 0} {
set idx "end-[expr {abs($idx+1)}]"
}
set key [lindex [dict keys $o_data] $idx]
set posn $idx
} else {
set key $idx
set posn [lsearch -exact [dict keys $o_data] $key]
if {$posn < 0} {
error "[self object] no such index: '$idx' in this collection"
}
}
dict unset o_data $key
return
}
method clear {} {
set o_data [dict create]
return
}
method reverse_the_collection {} {
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy.
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations.
set dictnew [dict create]
foreach k [lreverse [dict keys $o_data]] {
dict set dictnew $k [dict get $o_data $k]
}
set o_data $dictnew
return
}
#review - cmd as list vs cmd as script?
method map {cmd} {
set seed [list]
dict for {k v} $o_data {
lappend seed [uplevel #0 [list {*}$cmd $v]]
}
return $seed
}
method objectmap {cmd} {
set seed [list]
dict for {k v} $o_data {
lappend seed [uplevel #0 [list $v {*}$cmd]]
}
return $seed
}
}
}

3655
src/bootsupport/modules/overtype-1.6.3.tm

File diff suppressed because it is too large Load Diff

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

File diff suppressed because it is too large Load Diff

20
src/bootsupport/modules/punk/char-0.1.0.tm

@ -1852,15 +1852,27 @@ namespace eval punk::char {
#intended for single grapheme - but will work for multiple #intended for single grapheme - but will work for multiple
#cannot contain ansi or newlines #cannot contain ansi or newlines
#(a cache of ansifreestring_width calls - as these are quite regex heavy) #(a cache of ansifreestring_width calls - as these are quite regex heavy)
proc grapheme_width_cached {ch} { #review - effective memory leak on longrunning programs if never cleared
#tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner
proc grapheme_width_cached {ch {key ""}} {
variable grapheme_widths variable grapheme_widths
if {[dict exists $grapheme_widths $ch]} { #if key eq "*" - we won't be able to clear that cache individually. Perhaps that's ok
return [dict get $grapheme_widths $ch] if {[dict exists $grapheme_widths $key $ch]} {
return [dict get $grapheme_widths $key $ch]
} }
set width [punk::char::ansifreestring_width $ch] ;#review - can we provide faster version if we know it's a single grapheme rather than a string? (grapheme is still a string as it may have combiners/diacritics) set width [punk::char::ansifreestring_width $ch] ;#review - can we provide faster version if we know it's a single grapheme rather than a string? (grapheme is still a string as it may have combiners/diacritics)
dict set grapheme_widths $ch $width dict set grapheme_widths $key $ch $width
return $width return $width
} }
proc grapheme_width_cache_clear {key} {
variable grapheme_widths
if {$key eq "*} {
set grapheme_widths [dict create]
} else {
dict unset grapheme_widths $key
}
return
}
#no char_width - use grapheme_width terminology to be clearer #no char_width - use grapheme_width terminology to be clearer
proc grapheme_width {char} { proc grapheme_width {char} {
error "grapheme_width unimplemented - use ansifreestring_width" error "grapheme_width unimplemented - use ansifreestring_width"

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

@ -775,61 +775,47 @@ namespace eval punk::console {
#a and a+ functions are not very useful when emitting directly to console #a and a+ functions are not very useful when emitting directly to console
#e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first #e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first
#proc a {args} {
# variable colour_disabled
# variable ansi_wanted
# if {$colour_disabled || $ansi_wanted <= 0} {
# return
# }
# #stdout
# tailcall ansi::a {*}$args
#}
#proc a+ {args} {
# variable colour_disabled
# variable ansi_wanted
# if {$colour_disabled || $ansi_wanted <= 0} {
# return
# }
# #stdout
# tailcall ansi::a+ {*}$args
#}
proc a? {args} { proc a? {args} {
#stdout #stdout
variable colour_disabled
variable ansi_wanted variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} { if {$ansi_wanted <= 0} {
puts -nonewline [punk::ansi::stripansi [::punk::ansi::a?]] puts -nonewline [punk::ansi::stripansi [::punk::ansi::a?]]
} else { } else {
tailcall ansi::a? {*}$args tailcall ansi::a? {*}$args
} }
} }
proc code_a+ {args} {
variable ansi_wanted
if {$ansi_wanted <= 0} {
return
}
#a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here
#tailcall punk::ansi::a+ {*}$args
::punk::ansi::a+ {*}$args
}
proc code_a {args} { proc code_a {args} {
variable colour_disabled
variable ansi_wanted variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} { if {$ansi_wanted <= 0} {
return return
} }
tailcall punk::ansi::a {*}$args #tailcall punk::ansi::a {*}$args
::punk::ansi::a {*}$args
} }
proc code_a? {args} { proc code_a? {args} {
variable colour_disabled
variable ansi_wanted variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} { if {$ansi_wanted <= 0} {
return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]] return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]]
} else { } else {
tailcall ::punk::ansi::a? {*}$args tailcall ::punk::ansi::a? {*}$args
} }
} }
proc code_a+ {args} {
variable colour_disabled
variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} {
return
}
tailcall punk::ansi::a+ {*}$args
}
#REVIEW! this needs reworking.
#It needs to be clarified as to what ansi off is supposed to do.
#Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames?
#It will stop underlines/bold/reverse as well as SGR colours
#what about ansi movement codes etc?
proc ansi {{onoff {}}} { proc ansi {{onoff {}}} {
variable ansi_wanted variable ansi_wanted
if {[string length $onoff]} { if {[string length $onoff]} {
@ -846,6 +832,7 @@ namespace eval punk::console {
false - false -
no { no {
set ansi_wanted 0 set ansi_wanted 0
punk::ansi::sgr_cache clear
} }
default { default {
set ansi_wanted 2 set ansi_wanted 2
@ -855,25 +842,36 @@ namespace eval punk::console {
} }
} }
} }
catch {repl::reset_prompt} catch {punk::repl::reset_prompt}
return [expr {$ansi_wanted}] return [expr {$ansi_wanted}]
} }
proc colour {{onoff {}}} {
#colour
# Turning colour off will stop SGR colour codes from being generated unless 'forcecolour' is added to the argument list for the punk::ans::a functions
proc colour {{on {}}} {
variable colour_disabled variable colour_disabled
if {[string length $onoff]} { if {$on ne ""} {
set onoff [string tolower $onoff] if {![string is boolean -strict $on]} {
error "punk::console::colour expected a boolean e.g 0|1|on|off|true|false|yes|no"
}
#an experiment with complete disabling vs test of state for each call #an experiment with complete disabling vs test of state for each call
if {$onoff in [list 1 on true yes]} { if {$on} {
interp alias "" a+ "" punk::console::code_a+ if {$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
catch {punk::repl::reset_prompt}
set colour_disabled 0 set colour_disabled 0
} elseif {$onoff in [list 0 off false no]} { }
interp alias "" a+ "" control::no-op
set colour_disabled 1
} else { } else {
error "punk::console::colour expected 0|1|on|off|true|false|yes|no" #we don't disable a/a+ entirely - they must still emit underlines/bold/reverse
if {!$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
catch {punk::repl::reset_prompt}
set colour_disabled 1
}
} }
} }
catch {repl::reset_prompt}
return [expr {!$colour_disabled}] return [expr {!$colour_disabled}]
} }
@ -1197,6 +1195,9 @@ namespace eval punk::console {
namespace import ansi::cursor_on namespace import ansi::cursor_on
namespace import ansi::cursor_off namespace import ansi::cursor_off
#review - the concept of using local mechanisms at all (ie apis) vs ansi is not necessarily something we want/need to support.
#For the system to be really useful if needs to operate in conditions where the terminal is remote
#This seems to be why windows console is deprecating various non-ansi api methods for interacting with the console.
namespace eval local { namespace eval local {
proc titleset {windowtitle} { proc titleset {windowtitle} {
if {"windows" eq $::tcl_platform(platform)} { if {"windows" eq $::tcl_platform(platform)} {
@ -1243,17 +1244,21 @@ namespace eval punk::console {
return [local::titleget] return [local::titleget]
} }
proc infocmp_test {} { proc infocmp {} {
set cmd1 [auto_execok infocmp] set cmd1 [auto_execok infocmp]
if {[string length $cmd1]} { if {[string length $cmd1]} {
puts stderr "infocmp seems to be available" puts stderr ""
return [exec {*}$cmd1] return [exec {*}$cmd1]
} else { } else {
puts stderr "infcmp doesn't seem to be present" puts stderr "infocmp doesn't seem to be present"
if {$::tcl_platform(os) eq "FreeBSD"} {
puts stderr "For FreeBSD - install ncurses to get infocmp and related binaries and also install terminfo-db"
}
set tcmd [auto_execok tput] set tcmd [auto_execok tput]
if {[string length $tcmd]} { if {[string length $tcmd]} {
puts stderr "tput seems to be available. Try something like: tput -S - (freebsd)" puts stderr "tput seems to be available. Try something like: tput -S - (freebsd)"
} }
#todo - what? can tput query all caps? OS differences?
} }
} }
@ -1280,6 +1285,7 @@ namespace eval punk::console {
return [split $data ";"] return [split $data ";"]
} }
#channel?
namespace eval ansi { namespace eval ansi {
proc move {row col} { proc move {row col} {
puts -nonewline stdout [punk::ansi::move $row $col] puts -nonewline stdout [punk::ansi::move $row $col]
@ -1320,6 +1326,12 @@ namespace eval punk::console {
proc scroll_down {n} { proc scroll_down {n} {
puts -nonewline stdout [punk::ansi::scroll_down $n] puts -nonewline stdout [punk::ansi::scroll_down $n]
} }
proc enable_alt_screen {} {
puts -nonewline stdout [punk::ansi::enable_alt_screen]
}
proc disable_alt_screen {} {
puts -nonewline stdout [punk::ansi::disable_alt_screen]
}
#review - worth the extra microseconds to inline? might be if used in for example prompt on every keypress. #review - worth the extra microseconds to inline? might be if used in for example prompt on every keypress.
#caller should build as much as possible using the punk::ansi versions to avoid extra puts calls #caller should build as much as possible using the punk::ansi versions to avoid extra puts calls
@ -1373,8 +1385,10 @@ namespace eval punk::console {
namespace import ansi::cursor_restore namespace import ansi::cursor_restore
namespace import ansi::cursor_save_dec namespace import ansi::cursor_save_dec
namespace import ansi::cursor_restore_dec namespace import ansi::cursor_restore_dec
namespace import ansi::scroll_down
namespace import ansi::scroll_up namespace import ansi::scroll_up
namespace import ansi::scroll_down
namespace import ansi::enable_alt_screen
namespace import ansi::disable_alt_screen
namespace import ansi::insert_spaces namespace import ansi::insert_spaces
namespace import ansi::delete_characters namespace import ansi::delete_characters
namespace import ansi::erase_characters namespace import ansi::erase_characters

165
src/bootsupport/modules/punk/lib-0.1.1.tm

@ -179,6 +179,54 @@ namespace eval punk::lib::compat {
} }
#slight isolation - varnames don't leak - but calling context vars can be affected
proc lmaptcl2 {varnames list script} {
set result [list]
set values [list]
foreach v $varnames {
lappend values "\$$v"
}
set linkvars [uplevel 1 [list info vars]]
set nscaller [uplevel 1 [list namespace current]]
set apply_script ""
foreach vname $linkvars {
append apply_script [string map [list %vname% $vname]\
{upvar 2 %vname% %vname%}\
] \n
}
append apply_script $script \n
#puts "--> $apply_script"
foreach $varnames $list {
lappend result [apply\
[list\
$varnames\
$apply_script\
$nscaller\
] {*}[subst $values]\
]
}
return $result
}
if {"::lmap" ne [info commands ::lmap]} {
#puts stderr "Warning - no built-in lpop"
interp alias {} lpop {} ::punk::lib::compat::lmaptcl
}
#lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway
proc lmaptcl {varnames list script} {
set result [list]
set varlist [list]
foreach varname $varnames {
upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc
lappend varlist var_$varname
}
foreach $varlist $list {
lappend result [uplevel 1 $script]
}
return $result
}
#*** !doctools #*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}]
@ -196,6 +244,99 @@ namespace eval punk::lib {
#[para] Core API functions for punk::lib #[para] Core API functions for punk::lib
#[list_begin definitions] #[list_begin definitions]
#The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env
proc lmapflat_closure {varnames list script} {
set result [list]
set values [list]
foreach v $varnames {
lappend values "\$$v"
}
# -- --- ---
#capture - use uplevel 1 or namespace eval depending on context
set capture [uplevel 1 {
apply { varnames {
set capturevars [dict create]
set capturearrs [dict create]
foreach fullv $varnames {
set v [namespace tail $fullv]
upvar 1 $v var
if {[info exists var]} {
if {(![array exists var])} {
dict set capturevars $v $var
} else {
dict set capturearrs capturedarray_$v [array get var]
}
} else {
#A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set
}
}
return [dict create vars $capturevars arrs $capturearrs]
} } [info vars]
} ]
# -- --- ---
set cvars [dict get $capture vars]
set carrs [dict get $capture arrs]
set apply_script ""
foreach arrayalias [dict keys $carrs] {
set realname [string range $arrayalias [string first _ $arrayalias]+1 end]
append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] {
array set %realname% [set %arrayalias%][unset %arrayalias%]
}]
}
append apply_script [string map [list %script% $script] {
#foreach arrayalias [info vars capturedarray_*] {
# set realname [string range $arrayalias [string first _ $arrayalias]+1 end]
# array set $realname [set $arrayalias][unset arrayalias]
#}
#return [eval %script%]
%script%
}]
#puts "--> $apply_script"
foreach $varnames $list {
lappend result {*}[apply\
[list\
[concat $varnames [dict keys $cvars] [dict keys $carrs] ]\
$apply_script\
] {*}[subst $values] {*}[dict values $cvars] {*}[dict values $carrs] ]
}
return $result
}
#link version - can write to vars in calling context - but keeps varnames themselves isolated
#performance much better than capture version - but still a big price to pay for the isolation
proc lmapflat_link {varnames list script} {
set result [list]
set values [list]
foreach v $varnames {
lappend values "\$$v"
}
set linkvars [uplevel 1 [list info vars]]
set nscaller [uplevel 1 [list namespace current]]
set apply_script ""
foreach vname $linkvars {
append apply_script [string map [list %vname% $vname]\
{upvar 2 %vname% %vname%}\
] \n
}
append apply_script $script \n
#puts "--> $apply_script"
foreach $varnames $list {
lappend result {*}[apply\
[list\
$varnames\
$apply_script\
$nscaller\
] {*}[subst $values]\
]
}
return $result
}
proc lmapflat {varnames list script} {
concat {*}[uplevel 1 [list lmap $varnames $list $script]]
}
proc dict_getdef {dictValue args} { proc dict_getdef {dictValue args} {
if {[llength $args] < 1} { if {[llength $args] < 1} {
@ -970,11 +1111,12 @@ namespace eval punk::lib {
-block {trimhead1 trimtail1}\ -block {trimhead1 trimtail1}\
-line {}\ -line {}\
-commandprefix ""\ -commandprefix ""\
-ansiresets 0\ -ansiresets auto\
-ansireplays 0\
] ]
dict for {o v} $arglist { dict for {o v} $arglist {
switch -- $o { switch -- $o {
-block - -line - -commandprefix - -ansiresets {} -block - -line - -commandprefix - -ansiresets - -ansireplays {}
default { default {
error "linelist: Unrecognized option '$o' usage:$usage" error "linelist: Unrecognized option '$o' usage:$usage"
} }
@ -1033,6 +1175,17 @@ namespace eval punk::lib {
# -- --- --- --- --- --- # -- --- --- --- --- ---
set opt_ansiresets [dict get $opts -ansiresets] set opt_ansiresets [dict get $opts -ansiresets]
# -- --- --- --- --- --- # -- --- --- --- --- ---
set opt_ansireplays [dict get $opts -ansireplays]
if {$opt_ansireplays} {
if {$opt_ansiresets eq "auto"} {
set opt_ansiresets 1
}
} else {
if {$opt_ansiresets eq "auto"} {
set opt_ansiresets 0
}
}
# -- --- --- --- --- ---
set linelist [list] set linelist [list]
set nlsplit [split $text \n] set nlsplit [split $text \n]
if {![llength $opt_line]} { if {![llength $opt_line]} {
@ -1119,17 +1272,23 @@ namespace eval punk::lib {
#review - we need to make sure ansiresets don't accumulate/grow on any line #review - we need to make sure ansiresets don't accumulate/grow on any line
#Each resulting line should have a reset of some type at start and a pure-reset at end to stop #Each resulting line should have a reset of some type at start and a pure-reset at end to stop
#see if we can find an ST sequence that most terminals will not display for marking sections? #see if we can find an ST sequence that most terminals will not display for marking sections?
if {$opt_ansiresets} { if {$opt_ansireplays} {
package require punk::ansi package require punk::ansi
if {$opt_ansiresets} {
set RST [punk::ansi::a] set RST [punk::ansi::a]
} else {
set RST ""
}
set replaycodes $RST ;#todo - default? set replaycodes $RST ;#todo - default?
set transformed [list] set transformed [list]
#shortcircuit common case of no ansi #shortcircuit common case of no ansi
if {![punk::ansi::ta::detect $linelist]} { if {![punk::ansi::ta::detect $linelist]} {
if {$opt_ansiresets} {
foreach ln $linelist { foreach ln $linelist {
lappend transformed $RST$ln$RST lappend transformed $RST$ln$RST
} }
set linelist $transformed set linelist $transformed
}
} else { } else {
#INLINE punk::ansi::codetype::is_sgr_reset #INLINE punk::ansi::codetype::is_sgr_reset

8
src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd

@ -54,9 +54,9 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
@REM @ECHO nextshelltype is %nextshelltype[win32___________]% @REM @ECHO nextshelltype is %nextshelltype[win32___________]%
@REM @SET "selected_shelltype=%nextshelltype[win32___________]%" @REM @SET "selected_shelltype=%nextshelltype[win32___________]%"
@SET "selected_shelltype=%nextshelltype[win32___________]%" @SET "selected_shelltype=%nextshelltype[win32___________]%"
@ECHO selected_shelltype %selected_shelltype% @REM @ECHO selected_shelltype %selected_shelltype%
@CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed @CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed
@ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% @REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed%
@SET "selected_shellpath=%nextshellpath[win32___________]%" @SET "selected_shellpath=%nextshellpath[win32___________]%"
@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed @CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed
@CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%" @CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%"
@ -202,8 +202,8 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
IF NOT "x%keyRemoved%"=="x%validshelltypes%" ( IF NOT "x%keyRemoved%"=="x%validshelltypes%" (
REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl
REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx
%selected_shellpath_trimmed% "%~dp0%fname%" %arglist% REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode
SET task_exitcode=!errorlevel! %selected_shellpath_trimmed% "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call;
) ELSE ( ) ELSE (
ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes%
SET task_exitcode=66 SET task_exitcode=66

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

@ -1580,7 +1580,7 @@ namespace eval punk::ns {
#review - upvar in apply within ns eval vs direct access of ${ns}::varname #review - upvar in apply within ns eval vs direct access of ${ns}::varname
set capture [namespace eval $ns { set capture [namespace eval $ns {
apply { varnames { apply { varnames {
while {"prev_args_[incr n]" in $varnames} {} while {"prev_args[incr n]" in $varnames} {}
set capturevars [dict create] set capturevars [dict create]
set capturearrs [dict create] set capturearrs [dict create]
foreach fullv $varnames { foreach fullv $varnames {

2132
src/bootsupport/modules/textblock-0.1.1.tm

File diff suppressed because it is too large Load Diff

18
src/modules/punk-0.1.tm

@ -7222,11 +7222,6 @@ namespace eval punk {
interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#|
#interp alias {} c {} clear ;#external executable 'clear' may not always be available
#todo - review
#repl::term notifies prompt system of reset
interp alias {} clear {} repl::term::reset
interp alias {} c {} repl::term::reset
interp alias {} colour {} punk::console::colour interp alias {} colour {} punk::console::colour
@ -7237,7 +7232,18 @@ namespace eval punk {
interp alias {} a {} punk::console::code_a interp alias {} a {} punk::console::code_a
interp alias {} a? {} punk::console::code_a? interp alias {} a? {} punk::console::code_a?
#interp alias {} c {} clear ;#external executable 'clear' may not always be available
#todo - review
interp alias {} clear {} ::punk::reset
interp alias {} c {} ::punk::reset
proc reset {} {
if {[llength [info commands ::punk::repl::reset_terminal]]} {
#punk::repl::reset_terminal notifies prompt system of reset
punk::repl::reset_terminal
} else {
puts -nonewline stdout [punk::ansi::reset]
}
}

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

@ -966,7 +966,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
dict set WEB_colour_map_purple violet 238-130-238 ;# #EE82EE dict set WEB_colour_map_purple violet 238-130-238 ;# #EE82EE
dict set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD dict set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD
dict set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8 dict set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8
dict set WEB_colour_map_purple lavender 230-230-150 ;# #E6E6FA dict set WEB_colour_map_purple lavender 230-230-250 ;# #E6E6FA
# -- --- --- # -- --- ---
#Blue colours #Blue colours
variable WEB_colour_map_blue variable WEB_colour_map_blue
@ -1422,33 +1422,66 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
return $SGR_map return $SGR_map
} }
proc colourmap1 {{bgname White}} { proc colourmap1 {args} {
package require textblock set defaults {-bg Web-white -forcecolour 0}
dict for {k v} $args {
switch -- $k {
-bg - -forcecolour {}
default {
error "colourmap1 unrecognised option $k. Known-options: [dict keys $defaults]
}
}
}
set opts [dict merge $defaults $args]
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
} else {
set fc ""
}
set bgname [dict get $opts -bg]
set bg [textblock::block 33 3 "[a+ $bgname] [a]"] package require textblock
set bg [textblock::block 33 3 "[a+ {*}$fc $bgname] [a]"]
set colourmap "" set colourmap ""
set RST [a]
for {set i 0} {$i <= 7} {incr i} { for {set i 0} {$i <= 7} {incr i} {
append colourmap "_[a+ white bold 48\;5\;$i] $i [a]" #append colourmap "_[a+ white bold 48\;5\;$i] $i [a]"
append colourmap "_[a+ {*}$fc white bold Term-$i] $i $RST"
} }
set map1 [overtype::left -transparent _ $bg "\n$colourmap"] set map1 [overtype::left -transparent _ $bg "\n$colourmap"]
return $map1 return $map1
} }
proc colourmap2 {{bgname White}} { proc colourmap2 {args} {
set defaults {-forcecolour 0 -bg Web-white}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
set bgname [dict get $opts -bg]
package require textblock package require textblock
set bg [textblock::block 39 3 "[a+ $bgname] [a]"] set bg [textblock::block 39 3 "[a+ {*}$fc $bgname] [a]"]
set colourmap "" set colourmap ""
set RST [a]
for {set i 8} {$i <= 15} {incr i} { for {set i 8} {$i <= 15} {incr i} {
if {$i == 8} { if {$i == 8} {
set fg "bold white" set fg "bold white"
} else { } else {
set fg "black normal" ;#black normal is often blacker than black bold - which can display as a grey set fg "black normal" ;#black normal is often blacker than black bold - which can display as a grey
} }
append colourmap "_[a+ {*}$fg 48\;5\;$i] $i [a]" append colourmap "_[a+ {*}$fc {*}$fg 48\;5\;$i] $i $RST"
} }
set map2 [overtype::left -transparent _ $bg "\n$colourmap"] set map2 [overtype::left -transparent _ $bg "\n$colourmap"]
return $map2 return $map2
} }
proc colourtable_216 {} { proc colourtable_216 {args} {
set defaults {-forcecolour 0}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
package require textblock package require textblock
set clist [list] set clist [list]
set fg "black" set fg "black"
@ -1460,7 +1493,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set fg "black" set fg "black"
} }
} }
lappend clist "[a+ {*}$fg Term$i][format %3s $i]" lappend clist "[a+ {*}$fc {*}$fg Term$i][format %3s $i]"
} }
set t [textblock::list_as_table 36 $clist -return object] set t [textblock::list_as_table 36 $clist -return object]
@ -1470,7 +1503,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} }
#1st 16 colours of 256 - match SGR colours #1st 16 colours of 256 - match SGR colours
proc colourblock_16 {} { proc colourblock_16 {args} {
set defaults {-forcecolour 0}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
set out "" set out ""
set fg "bold white" set fg "bold white"
for {set i 0} {$i <= 15} {incr i} { for {set i 0} {$i <= 15} {incr i} {
@ -1478,11 +1517,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
if {$i > 8} { if {$i > 8} {
set fg "web-black" set fg "web-black"
} }
append out "[a+ {*}$fg Term$i][format %3s $i] " append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] "
} }
return $out[a] return $out[a]
} }
proc colourtable_16_names {} { proc colourtable_16_names {args} {
set defaults {-forcecolour 0}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
variable TERM_colour_map_reverse variable TERM_colour_map_reverse
set rows [list] set rows [list]
set row [list] set row [list]
@ -1500,8 +1545,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} elseif {$i > 6} { } elseif {$i > 6} {
set fg "web-black" set fg "web-black"
} }
#lappend row "[a+ {*}$fg Term-$cname][format %3s $i] $cname " #lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname "
lappend row "[a+ {*}$fg Term-$i][format %3s $i] $cname " lappend row "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] $cname "
} }
lappend rows $row lappend rows $row
foreach r $rows { foreach r $rows {
@ -1514,7 +1559,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} }
#216 colours of 256 #216 colours of 256
proc colourblock_216 {} { proc colourblock_216 {args} {
set defaults {-forcecolour 0}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
set out "" set out ""
set fg "web-black" set fg "web-black"
for {set i 16} {$i <=231} {incr i} { for {set i 16} {$i <=231} {incr i} {
@ -1528,14 +1579,22 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} else { } else {
set br "" set br ""
} }
append out "$br[a+ {*}$fg Term$i][format %3s $i] " append out "$br[a+ {*}$fc {*}$fg Term$i][format %3s $i] "
} }
append out [a] append out [a]
return [string trimleft $out \n] return [string trimleft $out \n]
} }
#x6 is reasonable from a width (124 screen cols) and colour viewing perspective #x6 is reasonable from a width (124 screen cols) and colour viewing perspective
proc colourtable_216_names {{cols 6}} { proc colourtable_216_names {args} {
set defaults {-forcecolour 0 -columns 6}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
set cols [dict get $opts -columns]
set out "" set out ""
#use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names #use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names
variable TERM_colour_map_reverse variable TERM_colour_map_reverse
@ -1557,7 +1616,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set fg "web-black" set fg "web-black"
} }
} }
lappend row "[a+ {*}$fg Term-$cname][format %3s $i] $cname " lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname "
} }
lappend rows $row lappend rows $row
foreach r $rows { foreach r $rows {
@ -1568,7 +1627,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append out [a] append out [a]
return [string trimleft $out \n] return [string trimleft $out \n]
} }
proc colourtable_term_pastel {} { proc colourtable_term_pastel {args} {
set defaults {-forcecolour 0}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
set out "" set out ""
set rows [list] set rows [list]
#see https://www.hackitu.de/termcolor256/ #see https://www.hackitu.de/termcolor256/
@ -1597,7 +1662,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
foreach r $rows { foreach r $rows {
set rowcells [list] set rowcells [list]
foreach cnum $r { foreach cnum $r {
lappend rowcells "[a+ $fg Term-$cnum][format %3s $cnum] " lappend rowcells "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] "
} }
$t add_row $rowcells $t add_row $rowcells
} }
@ -1606,14 +1671,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set pastel8 [list 102 138 144 108 109 103 139 145] set pastel8 [list 102 138 144 108 109 103 139 145]
set p8 "" set p8 ""
foreach cnum $pastel8 { foreach cnum $pastel8 {
append p8 "[a+ $fg Term-$cnum][format %3s $cnum] " append p8 "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] "
} }
append p8 [a]\n append p8 [a]\n
append out \n $p8 append out \n $p8
return $out return $out
} }
proc colourtable_term_rainbow {} { proc colourtable_term_rainbow {args} {
set defaults {-forcecolour 0}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
set out "" set out ""
set rows [list] set rows [list]
set fgwhite [list 16 52 88 124 160 22 17 18 19 20 21 57 56 93 55 92 54 91 53 90 89 126 88 125 124 160] set fgwhite [list 16 52 88 124 160 22 17 18 19 20 21 57 56 93 55 92 54 91 53 90 89 126 88 125 124 160]
@ -1666,7 +1737,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} else { } else {
set fg "web-black" set fg "web-black"
} }
lappend rowcells "[a+ $fg Term-$cnum][format %3s $cnum] " lappend rowcells "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] "
} }
$t add_row $rowcells $t add_row $rowcells
} }
@ -1675,19 +1746,33 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
return $out return $out
} }
#24 greys of 256 #24 greys of 256
proc colourblock_24 {} { proc colourblock_24 {args} {
set defaults {-forcecolour 0}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
set out "" set out ""
set fg "bold white" set fg "bold white"
for {set i 232} {$i <= 255} {incr i} { for {set i 232} {$i <= 255} {incr i} {
if {$i > 243} { if {$i > 243} {
set fg "web-black" set fg "web-black"
} }
append out "[a+ {*}$fg Term$i][format %3s $i] " append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] "
} }
return $out[a] return $out[a]
} }
proc colourtable_24_names {} { proc colourtable_24_names {args} {
set defaults {-forcecolour 0}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
variable TERM_colour_map_reverse variable TERM_colour_map_reverse
set rows [list] set rows [list]
set row [list] set row [list]
@ -1703,7 +1788,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
if {$i > 243} { if {$i > 243} {
set fg "web-black" set fg "web-black"
} }
lappend row "[a+ {*}$fg Term-$cname][format %3s $i] $cname " lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname "
} }
lappend rows $row lappend rows $row
foreach r $rows { foreach r $rows {
@ -1729,7 +1814,23 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
# $WEB_colour_map_white\ # $WEB_colour_map_white\
# $WEB_colour_map_gray\ # $WEB_colour_map_gray\
#] #]
proc colourtable_web {{groups *}} { proc colourtable_web {args} {
set defaults {-forcecolour 0 -groups *}
foreach {k v} $args {
switch -- $k {
-groups - -forcecolour {}
default {
error "colourtable_web unrecognised option '$k'. Known-options: [dict keys $defaults]"
}
}
}
set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
set groups [dict get $opts -groups]
#set all_groupnames [list basic pink red orange yellow brown purple blue cyan green white gray] #set all_groupnames [list basic pink red orange yellow brown purple blue cyan green white gray]
set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray] set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray]
switch -- $groups { switch -- $groups {
@ -1772,13 +1873,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} else { } else {
set fg "web-black" set fg "web-black"
} }
#$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ $fg Rgb-$cdec] #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec]
$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ $fg Web-$cname] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname]
} }
$t configure -frametype {} $t configure -frametype {}
$t configure_column 0 -headers [list "[string totitle $g] colours"] $t configure_column 0 -headers [list "[string totitle $g] colours"]
$t configure_column 0 -header_colspans [list all] $t configure_column 0 -header_colspans [list all]
$t configure -ansibase_header [a+ web-black Web-white] $t configure -ansibase_header [a+ {*}$fc web-black Web-white]
lappend grouptables [$t print] lappend grouptables [$t print]
$t destroy $t destroy
} }
@ -1794,17 +1895,22 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
variable X11_colour_map_diff variable X11_colour_map_diff
variable WEB_colour_map variable WEB_colour_map
set defaults [dict create\ set defaults [dict create\
-forcecolour 0\
-return "string"\ -return "string"\
] ]
dict for {k v} $args { dict for {k v} $args {
switch -- $k { switch -- $k {
-return {} -return - -forcecolour {}
default { default {
error "colourtable_x11diff unrecognised option '$k'. Known options [dict keys $defaults]" error "colourtable_x11diff unrecognised option '$k'. Known options [dict keys $defaults]"
} }
} }
} }
set opts [dict merge $defaults $args] set opts [dict merge $defaults $args]
set fc ""
if {[dict get $opts -forcecolour]} {
set fc "forcecolour"
}
set comparetables [list] ;# 2 side by side x11 and web set comparetables [list] ;# 2 side by side x11 and web
@ -1814,12 +1920,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
dict for {cname cdec} [set X11_colour_map_diff] { dict for {cname cdec} [set X11_colour_map_diff] {
$t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec]
set fg "web-white" set fg "web-white"
$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ $fg X11-$cname] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg X11-$cname]
} }
$t configure -frametype block $t configure -frametype block
$t configure_column 0 -headers [list "X11"] $t configure_column 0 -headers [list "X11"]
$t configure_column 0 -header_colspans [list all] $t configure_column 0 -header_colspans [list all]
$t configure -ansibase_header [a+ web-black Web-white] $t configure -ansibase_header [a+ {*}$fc web-black Web-white]
lappend comparetables [$t print] lappend comparetables [$t print]
$t destroy $t destroy
# -- --- --- # -- --- ---
@ -1835,12 +1941,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
dict for {cname cdec} [set WEB_map_subset] { dict for {cname cdec} [set WEB_map_subset] {
$t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec]
set fg "web-white" set fg "web-white"
$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ $fg Web-$cname] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname]
} }
$t configure -frametype block $t configure -frametype block
$t configure_column 0 -headers [list "Web"] $t configure_column 0 -headers [list "Web"]
$t configure_column 0 -header_colspans [list all] $t configure_column 0 -header_colspans [list all]
$t configure -ansibase_header [a+ web-black Web-white] $t configure -ansibase_header [a+ {*}$fc web-black Web-white]
lappend comparetables [$t print] lappend comparetables [$t print]
$t destroy $t destroy
# -- --- --- # -- --- ---
@ -1862,12 +1968,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#[para]Return an ansi string representing a table of codes and a panel showing the colours #[para]Return an ansi string representing a table of codes and a panel showing the colours
variable SGR_setting_map variable SGR_setting_map
variable SGR_colour_map variable SGR_colour_map
set fcposn [lsearch $args "forcecol*"]
set fc ""
set opt_forcecolour 0
if {$fcposn >= 0} {
set fc "forcecolour"
set opt_forcecolour 1
set args [lremove $args $fcposn]
}
if {![llength $args]} { if {![llength $args]} {
set out "" set out ""
set indent " " set indent " "
set RST [a] set RST [a]
append out "[a+ web-white]Extended underlines$RST" \n append out "[a+ {*}$fc web-white]Extended underlines$RST" \n
set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST" set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST"
set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST" set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST"
set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST" set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST"
@ -1876,8 +1990,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append out "${indent}$underdashed" \n append out "${indent}$underdashed" \n
append out "${indent}$underline_c" \n append out "${indent}$underline_c" \n
append out "${indent}Extended underlines/colours can suppress other SGR codes on terminals that don't support them if codes are merged." \n append out "${indent}Extended underlines/colours can suppress other SGR codes on terminals that don't support them if codes are merged." \n
append out "${indent}punk::ansi tries to keep them in separate escape sequences even during merge operations to avoid this" \n append out "${indent}punk::ansi tries to keep them in separate escape sequences (standard SGR followed by extended) even during merge operations to avoid this." \n
append out "[a+ web-white]Standard SGR colours and attributes $RST" \n append out "${indent}If a fallback to standard underline is required, underline should be added along with extended codes such as underlinedotted, underlinedouble etc" \n
append out "${indent}e.g cyan with curly yellow underline or fallback all cyan underlined \[a+ cyan undercurly underline undt-yellow\]text\[a] -> [a+ {*}$fc cyan undercurly underline undt-yellow]text$RST" \n
append out "[a+ {*}$fc web-white]Standard SGR colours and attributes $RST" \n
set settings_applied $SGR_setting_map set settings_applied $SGR_setting_map
set strmap [list] set strmap [list]
dict for {k v} $SGR_setting_map { dict for {k v} $SGR_setting_map {
@ -1903,37 +2019,45 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append out [textblock::join $indent [string map $strmap $settings_applied]] \n append out [textblock::join $indent [string map $strmap $settings_applied]] \n
append out [textblock::join $indent [string trim $SGR_colour_map \n]] \n append out [textblock::join $indent [string trim $SGR_colour_map \n]] \n
append out [textblock::join $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n append out [textblock::join $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n
set bgname "White" set bgname "Web-white"
set map1 [colourmap1 $bgname] set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour]
set map1 [overtype::centre -transparent 1 $map1 "[a black $bgname]Standard colours[a]"] set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"]
set map2 [colourmap2 $bgname] set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour]
set map2 [overtype::centre -transparent 1 $map2 "[a black $bgname]High-intensity colours[a]"] set map2 [overtype::centre -transparent 1 $map2 "[a {*}$fc black $bgname]High-intensity colours[a]"]
append out [textblock::join $indent [textblock::join $map1 $map2]] \n append out [textblock::join $indent [textblock::join $map1 $map2]] \n
append out "[a+ web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n append out "[a+ {*}$fc web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n
append out [textblock::join $indent [colourblock_216]] \n append out [textblock::join $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n
append out "[a+ web-white]24 Greyscale colours[a]" \n append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n
append out [textblock::join $indent [colourblock_24]] \n append out [textblock::join $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n
append out \n append out \n
append out [textblock::join $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ Term-92 term-49]text[a]"] \n append out [textblock::join $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n
append out [textblock::join $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ Term-lightsteelblue term-gold1]text[a]"] \n append out [textblock::join $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n
append out [textblock::join $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ term-lightsteelblue Term-gold1]text[a]"] \n append out [textblock::join $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n
append out \n append out \n
append out "[a+ web-white]16 Million colours[a]" \n append out "[a+ {*}$fc web-white]16 Million colours[a]" \n
#dict set WEB_colour_map mediumvioletred 199-21-133 ;# #C71585 #dict set WEB_colour_map mediumvioletred 199-21-133 ;# #C71585
append out [textblock::join $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ rgb-199-21-133]text[a]"] \n append out [textblock::join $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n
append out [textblock::join $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ Rgb#C71585]text[a]"] \n append out [textblock::join $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n
append out [textblock::join $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n append out [textblock::join $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n
append out \n append out \n
append out "[a+ web-white]Web colours[a]" \n append out "[a+ {*}$fc web-white]Web colours[a]" \n
append out [textblock::join $indent "To see all names use: a? web"] \n append out [textblock::join $indent "To see all names use: a? web"] \n
append out [textblock::join $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n append out [textblock::join $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n
append out [textblock::join $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n append out [textblock::join $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n
append out \n append out \n
append out [textblock::join $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ Web-springgreen web-coral]text[a]"] \n append out [textblock::join $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n
append out \n append out \n
append out "[a+ web-white]X11 colours[a] - mostly match Web colours" \n append out "[a+ {*}$fc web-white]X11 colours[a] - mostly match Web colours" \n
append out [textblock::join $indent "To see differences: a? x11"] \n append out [textblock::join $indent "To see differences: a? x11"] \n
if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} {
append out \n
if {$fc ne ""} {
append out "[a+ {*}$fc web-white]Colour is currently disabled - returning with colour anyway because 'forcecolour' argument was supplied[a]" \n
} else {
append out "Colour is currently disabled - to return with colour anyway - add the 'forcecolour' argument" \n
}
}
} on error {result options} { } on error {result options} {
puts stderr "Failed to draw colourmap" puts stderr "Failed to draw colourmap"
@ -1952,22 +2076,22 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} }
} }
set out "16 basic colours\n" set out "16 basic colours\n"
append out [colourtable_16_names] \n append out [colourtable_16_names -forcecolour $opt_forcecolour] \n
append out "216 colours\n" append out "216 colours\n"
append out [colourtable_216_names] \n append out [colourtable_216_names -forcecolour $opt_forcecolour] \n
append out "24 greyscale colours\n" append out "24 greyscale colours\n"
append out [colourtable_24_names] append out [colourtable_24_names -forcecolour $opt_forcecolour]
foreach ta $termargs { foreach ta $termargs {
switch -- $ta { switch -- $ta {
pastel { pastel {
append out \n append out \n
append out "Pastel Colour Space (punk::ansi::colourtable_term_pastel)\n" append out "Pastel Colour Space (punk::ansi::colourtable_term_pastel)\n"
append out [colourtable_term_pastel] append out [colourtable_term_pastel -forcecolour $opt_forcecolour]
} }
rainbow { rainbow {
append out \n append out \n
append out "Rainbow Colours (punk::ansi::colourtable_term_rainbow)\n" append out "Rainbow Colours (punk::ansi::colourtable_term_rainbow)\n"
append out [colourtable_term_rainbow] append out [colourtable_term_rainbow -forcecolour $opt_forcecolour]
} }
} }
} }
@ -1975,12 +2099,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
return $out return $out
} }
web { web {
return [colourtable_web [lrange $args 1 end]] return [colourtable_web -forcecolour $opt_forcecolour -groups [lrange $args 1 end]]
} }
x11 { x11 {
set out "" set out ""
append out " Mostly same as web - known differences displayed" \n append out " Mostly same as web - known differences displayed" \n
append out [colourtable_x11diff] append out [colourtable_x11diff -forcecolour $opt_forcecolour]
return $out return $out
} }
} }
@ -1997,7 +2121,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set resultlist [list] set resultlist [list]
foreach i $args { foreach i $args {
set f4 [string range $i 0 3] set f4 [string range $i 0 3]
set s [a+ $i]sample set s [a+ {*}$fc $i]sample
switch -- $f4 { switch -- $f4 {
web- - Web- - WEB- { web- - Web- - WEB- {
set tail [string tolower [string trim [string range $i 4 end] -]] set tail [string tolower [string trim [string range $i 4 end] -]]
@ -2083,6 +2207,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
undercurly - underdotted - underdashed - undersingle - underdouble { undercurly - underdotted - underdashed - undersingle - underdouble {
$t add_row [list $i extended $s [ansistring VIEW $s]] $t add_row [list $i extended $s [ansistring VIEW $s]]
} }
underline {
$t add_row [list $i "SGR 4" $s [ansistring VIEW $s]]
}
default { default {
$t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]]
} }
@ -2102,7 +2229,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} }
} }
} }
set ansi [a+ {*}$args] set ansi [a+ {*}$fc {*}$args]
set s ${ansi}sample set s ${ansi}sample
#set merged [punk::ansi::codetype::sgr_merge_singles [list $ansi]] #set merged [punk::ansi::codetype::sgr_merge_singles [list $ansi]]
set merged [punk::ansi::codetype::sgr_merge [list $ansi]] set merged [punk::ansi::codetype::sgr_merge [list $ansi]]
@ -2187,8 +2314,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#function name part of cache-key because a and a+ return slightly different results (a has leading reset) #function name part of cache-key because a and a+ return slightly different results (a has leading reset)
variable sgr_cache variable sgr_cache
if {[dict exists $sgr_cache a+$args]} { set cache_key a+$args ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key
return [dict get $sgr_cache a+$args] if {[dict exists $sgr_cache $cache_key]} {
return [dict get $sgr_cache $cache_key]
} }
#don't disable ansi here. #don't disable ansi here.
@ -2196,6 +2324,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
variable WEB_colour_map variable WEB_colour_map
variable TERM_colour_map variable TERM_colour_map
set colour_disabled 0
#whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear
if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} {
set colour_disabled 1
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
if {$fcpos >= 0} {
set forcecolour 1
set args [lremove $args $fcpos]
}
set t [list] set t [list]
set e [list] ;#extended codes needing to go in own escape sequence set e [list] ;#extended codes needing to go in own escape sequence
foreach i $args { foreach i $args {
@ -2250,6 +2392,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
underline { underline {
lappend t 4 ;#underline lappend t 4 ;#underline
} }
underextendedoff {
#lremove any existing 4:1 etc
set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]]
lappend e 4:0
}
undersingle { undersingle {
lappend e 4:1 lappend e 4:1
} }
@ -2265,10 +2412,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
underdashed { underdashed {
lappend e 4:5 lappend e 4:5
} }
default {
puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)"
}
} }
} }
doub {lappend t 21 ;#doubleunderline} doub {lappend t 21 ;#doubleunderline}
noun {lappend t 24 ;#nounderline} noun {
lappend t 24 ;#nounderline
#set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]]
lappend e 4:0
}
stri {lappend t 9 ;#strike} stri {lappend t 9 ;#strike}
nost {lappend t 29 ;#nostrike} nost {lappend t 29 ;#nostrike}
ital {lappend t 3 ;#italic} ital {lappend t 3 ;#italic}
@ -2451,6 +2605,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
default { default {
if {[string is integer -strict $i] || [string first ";" $i] > 0} { if {[string is integer -strict $i] || [string first ";" $i] > 0} {
lappend t $i lappend t $i
} elseif {[string first : $i] > 0} {
lappend e $i
} else { } else {
puts stderr "ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" puts stderr "ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-"
} }
@ -2458,6 +2614,32 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} }
} }
#the performance penalty must not be placed on the standard colour_enabled path.
#This is punk. Colour is the happy path despite the costs.
#The no_color users will still get a performance boost from shorter string processing if that's one of their motivations.
#As no_color doesn't strip all ansi - the motivation for it should not generally be
if {$colour_disabled && !$forcecolour} {
set tkeep [list]
foreach code $t {
switch -- $code {
0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 {
#SGR underline and other non colour effects
lappend tkeep $code
}
}
}
set t $tkeep
set ekeep [list]
foreach code $e {
switch -- $code {
4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 {
lappend ekeep $code
}
}
}
set e $ekeep
}
# \033 - octal. equivalently \x1b in hex which is more common in documentation # \033 - octal. equivalently \x1b in hex which is more common in documentation
if {![llength $t]} { if {![llength $t]} {
if {![llength $e]} { if {![llength $e]} {
@ -2472,7 +2654,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m" set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m"
} }
} }
dict set sgr_cache a+$args $result dict set sgr_cache $cache_key $result
return $result return $result
} }
@ -2489,8 +2671,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
#It's important to put the functionname in the cache-key because a and a+ return slightly different results #It's important to put the functionname in the cache-key because a and a+ return slightly different results
variable sgr_cache variable sgr_cache
if {[dict exists $sgr_cache a_$args]} { set cache_key a_$args
return [dict get $sgr_cache a_$args] if {[dict exists $sgr_cache $cache_key]} {
return [dict get $sgr_cache $cache_key]
} }
#don't disable ansi here. #don't disable ansi here.
@ -2498,6 +2681,19 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
variable WEB_colour_map variable WEB_colour_map
variable TERM_colour_map variable TERM_colour_map
set colour_disabled 0
#whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear
if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} {
set colour_disabled 1
}
#allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything.
set forcecolour 0
set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour
if {$fcpos >=0} {
set forcecolour 1
set args [lremove $args $fcpos]
}
set t [list] set t [list]
set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence
foreach i $args { foreach i $args {
@ -2549,6 +2745,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
underline { underline {
lappend t 4 ;#underline lappend t 4 ;#underline
} }
underextendedoff {
#lremove any existing 4:1 etc
set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]]
lappend e 4:0
}
undersingle { undersingle {
lappend e 4:1 lappend e 4:1
} }
@ -2564,10 +2765,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
underdashed { underdashed {
lappend e 4:5 lappend e 4:5
} }
default {
puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)"
}
} }
} }
doub {lappend t 21 ;#doubleunderline} doub {lappend t 21 ;#doubleunderline}
noun {lappend t 24 ;#nounderline} noun {
lappend t 24 ;#nounderline
#set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]]
lappend e 4:0
}
stri {lappend t 9 ;#strike} stri {lappend t 9 ;#strike}
nost {lappend t 29 ;#nostrike} nost {lappend t 29 ;#nostrike}
ital {lappend t 3 ;#italic} ital {lappend t 3 ;#italic}
@ -2750,6 +2958,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
default { default {
if {[string is integer -strict $i] || [string first ";" $i] > 0} { if {[string is integer -strict $i] || [string first ";" $i] > 0} {
lappend t $i lappend t $i
} elseif {[string first : $i] > 0} {
lappend e $i
} else { } else {
puts stderr "ansi name unmatched: '$i' in call 'a $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" puts stderr "ansi name unmatched: '$i' in call 'a $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-"
} }
@ -2757,16 +2967,38 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} }
} }
if {$colour_disabled && !$forcecolour} {
set tkeep [list]
foreach code $t {
switch -- $code {
0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 {
#SGR underline and other non colour effects
lappend tkeep $code
}
}
}
set t $tkeep
set ekeep [list]
foreach code $e {
switch -- $code {
4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 {
lappend ekeep $code
}
}
}
set e $ekeep
}
# \033 - octal. equivalently \x1b in hex which is more common in documentation # \033 - octal. equivalently \x1b in hex which is more common in documentation
# empty list [a] should do reset - same for [a nonexistant] # empty list [a] should do reset - same for [a nonexistant]
# explicit reset at beginning of parameter list for a= (as opposed to a+) # explicit reset at beginning of parameter list for a= (as opposed to a+)
set t [linsert $t[unset t] 0 0] set t [linsert $t[unset t] 0 0]
if {[![llength $e]]} { if {![llength $e]} {
set result "\x1b\[[join $t {;}]m" set result "\x1b\[[join $t {;}]m"
} else { } else {
set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m" set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m"
} }
dict set sgr_cache a_$args $result dict set sgr_cache $cache_key $result
return $result return $result
} }
@ -3400,10 +3632,15 @@ namespace eval punk::ansi {
dict set codestate_empty italic "" ;#3 on 23 off dict set codestate_empty italic "" ;#3 on 23 off
dict set codestate_empty underline "" ;#4 on 24 off dict set codestate_empty underline "" ;#4 on 24 off
#nonstandard 4:3,4:4,4:5 #nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5
dict set codestate_empty curlyunderline "" #4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions
dict set codestate_empty dottedunderline "" #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines
dict set codestate_empty dashedunderline "" dict set codestate_empty underextended "" ;#4:0 for no extended underline 4:1 etc for underline styles
#dict set codestate_empty undersingle ""
#dict set codestate_empty underdouble ""
#dict set codestate_empty undercurly ""
#dict set codestate_empty underdottedn ""
#dict set codestate_empty underdashed ""
dict set codestate_empty blink "" ;#5 or 6 for slow/fast, 25 for off dict set codestate_empty blink "" ;#5 or 6 for slow/fast, 25 for off
dict set codestate_empty reverse "" ;#7 on 27 off dict set codestate_empty reverse "" ;#7 on 27 off
@ -3411,7 +3648,7 @@ namespace eval punk::ansi {
dict set codestate_empty strike "" ;#9 on 29 off dict set codestate_empty strike "" ;#9 on 29 off
dict set codestate_empty font "" ;#10, 11-19 10 being primary dict set codestate_empty font "" ;#10, 11-19 10 being primary
dict set codestate_empty gothic "" ;#20 dict set codestate_empty gothic "" ;#20
dict set codestate_empty doubleunderline "" ;#21 dict set codestate_empty doubleunderline "" ;#21 (standard SGR double as opposed to underdouble)
dict set codestate_empty proportional "" ;#26 - see note below dict set codestate_empty proportional "" ;#26 - see note below
dict set codestate_empty frame_or_circle "" ;#51,52 on - 54 off (54 off) (not generally used - mintty has repurposed for emoji variation selector) dict set codestate_empty frame_or_circle "" ;#51,52 on - 54 off (54 off) (not generally used - mintty has repurposed for emoji variation selector)
@ -3422,7 +3659,7 @@ namespace eval punk::ansi {
dict set codestate_empty ideogram_doubleoverline "" dict set codestate_empty ideogram_doubleoverline ""
dict set codestate_empty ideogram_clear "" dict set codestate_empty ideogram_clear ""
dict set codestate_empty overline "" ;#53 on 55 off - probably not supported - pass through. dict set codestate_empty overline "" ;#53 on 55 off - probably not supported - pass through. Seem to be ok to merge with other SGR even if not supported.
dict set codestate_empty underlinecolour "" ;#58 - same arguments as 256colour and rgb (nonstandard - in Kitty ,VTE,mintty and iTerm2) dict set codestate_empty underlinecolour "" ;#58 - same arguments as 256colour and rgb (nonstandard - in Kitty ,VTE,mintty and iTerm2)
# -- mintty? # -- mintty?
@ -3556,26 +3793,24 @@ namespace eval punk::ansi {
} else { } else {
switch -- [lindex $paramsplit 1] { switch -- [lindex $paramsplit 1] {
0 { 0 {
#no underline #no *extended* underline
dict set codestate underline 24 #dict set codestate underline 24
dict set codestate curlyunderline "" dict set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended
dict set codestate dottedunderline ""
dict set codestate dashedunderline ""
} }
1 { 1 {
dict set codestate underline 4 ;#straight underline dict set codestate underextended 4:1
} }
2 { 2 {
dict set codestate doubleunderline 21 dict set codestate underextended 4:2
} }
3 { 3 {
dict set codestate curlyunderline "4:3" dict set codestate underextended "4:3"
} }
4 { 4 {
dict set codestate dottedunderline "4:4" dict set codestate underextended "4:4"
} }
5 { 5 {
dict set codestate dashedunderline "4:5" dict set codestate underextended "4:5"
} }
} }
@ -3614,9 +3849,7 @@ namespace eval punk::ansi {
} }
24 { 24 {
dict set codestate underline 24 ;#off dict set codestate underline 24 ;#off
dict set codestate curlyunderline "" dict set codestate underextended "4:0" ;#review
dict set codestate dottedunderline ""
dict set codestate dashedunderline ""
} }
25 { 25 {
dict set codestate blink 25 ;#off dict set codestate blink 25 ;#off
@ -3806,7 +4039,7 @@ namespace eval punk::ansi {
append codemerge "${v}\;" append codemerge "${v}\;"
} }
} }
underlinecolour - curlyunderline - dashedunderline - dottedunderline { underlinecolour - underextended {
append unmergeable "${v}\;" append unmergeable "${v}\;"
} }
default { default {
@ -3822,7 +4055,7 @@ namespace eval punk::ansi {
"" {} "" {}
default { default {
switch -- $k { switch -- $k {
underlinecolour - curlyunderline - dashedunderline - dottedunderline { underlinecolour - underextended {
append unmergeable "${v}\;" append unmergeable "${v}\;"
} }
default { default {

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

@ -775,29 +775,10 @@ namespace eval punk::console {
#a and a+ functions are not very useful when emitting directly to console #a and a+ functions are not very useful when emitting directly to console
#e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first #e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first
#proc a {args} {
# variable colour_disabled
# variable ansi_wanted
# if {$colour_disabled || $ansi_wanted <= 0} {
# return
# }
# #stdout
# tailcall ansi::a {*}$args
#}
#proc a+ {args} {
# variable colour_disabled
# variable ansi_wanted
# if {$colour_disabled || $ansi_wanted <= 0} {
# return
# }
# #stdout
# tailcall ansi::a+ {*}$args
#}
proc a? {args} { proc a? {args} {
#stdout #stdout
variable colour_disabled
variable ansi_wanted variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} { if {$ansi_wanted <= 0} {
puts -nonewline [punk::ansi::stripansi [::punk::ansi::a?]] puts -nonewline [punk::ansi::stripansi [::punk::ansi::a?]]
} else { } else {
tailcall ansi::a? {*}$args tailcall ansi::a? {*}$args
@ -805,9 +786,8 @@ namespace eval punk::console {
} }
proc code_a+ {args} { proc code_a+ {args} {
variable colour_disabled
variable ansi_wanted variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} { if {$ansi_wanted <= 0} {
return return
} }
#a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here
@ -815,24 +795,27 @@ namespace eval punk::console {
::punk::ansi::a+ {*}$args ::punk::ansi::a+ {*}$args
} }
proc code_a {args} { proc code_a {args} {
variable colour_disabled
variable ansi_wanted variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} { if {$ansi_wanted <= 0} {
return return
} }
#tailcall punk::ansi::a {*}$args #tailcall punk::ansi::a {*}$args
::punk::ansi::a {*}$args ::punk::ansi::a {*}$args
} }
proc code_a? {args} { proc code_a? {args} {
variable colour_disabled
variable ansi_wanted variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} { if {$ansi_wanted <= 0} {
return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]] return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]]
} else { } else {
tailcall ::punk::ansi::a? {*}$args tailcall ::punk::ansi::a? {*}$args
} }
} }
#REVIEW! this needs reworking.
#It needs to be clarified as to what ansi off is supposed to do.
#Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames?
#It will stop underlines/bold/reverse as well as SGR colours
#what about ansi movement codes etc?
proc ansi {{onoff {}}} { proc ansi {{onoff {}}} {
variable ansi_wanted variable ansi_wanted
if {[string length $onoff]} { if {[string length $onoff]} {
@ -859,25 +842,36 @@ namespace eval punk::console {
} }
} }
} }
catch {repl::reset_prompt} catch {punk::repl::reset_prompt}
return [expr {$ansi_wanted}] return [expr {$ansi_wanted}]
} }
proc colour {{onoff {}}} {
#colour
# Turning colour off will stop SGR colour codes from being generated unless 'forcecolour' is added to the argument list for the punk::ans::a functions
proc colour {{on {}}} {
variable colour_disabled variable colour_disabled
if {[string length $onoff]} { if {$on ne ""} {
set onoff [string tolower $onoff] if {![string is boolean -strict $on]} {
error "punk::console::colour expected a boolean e.g 0|1|on|off|true|false|yes|no"
}
#an experiment with complete disabling vs test of state for each call #an experiment with complete disabling vs test of state for each call
if {$onoff in [list 1 on true yes]} { if {$on} {
interp alias "" a+ "" punk::console::code_a+ if {$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
catch {punk::repl::reset_prompt}
set colour_disabled 0 set colour_disabled 0
} elseif {$onoff in [list 0 off false no]} { }
interp alias "" a+ "" control::no-op
set colour_disabled 1
} else { } else {
error "punk::console::colour expected 0|1|on|off|true|false|yes|no" #we don't disable a/a+ entirely - they must still emit underlines/bold/reverse
if {!$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
catch {punk::repl::reset_prompt}
set colour_disabled 1
}
} }
} }
catch {repl::reset_prompt}
return [expr {!$colour_disabled}] return [expr {!$colour_disabled}]
} }
@ -1253,7 +1247,7 @@ namespace eval punk::console {
proc infocmp {} { proc infocmp {} {
set cmd1 [auto_execok infocmp] set cmd1 [auto_execok infocmp]
if {[string length $cmd1]} { if {[string length $cmd1]} {
puts stderr "Using infocmp executable" puts stderr ""
return [exec {*}$cmd1] return [exec {*}$cmd1]
} else { } else {
puts stderr "infocmp doesn't seem to be present" puts stderr "infocmp doesn't seem to be present"

8
src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd

@ -54,9 +54,9 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
@REM @ECHO nextshelltype is %nextshelltype[win32___________]% @REM @ECHO nextshelltype is %nextshelltype[win32___________]%
@REM @SET "selected_shelltype=%nextshelltype[win32___________]%" @REM @SET "selected_shelltype=%nextshelltype[win32___________]%"
@SET "selected_shelltype=%nextshelltype[win32___________]%" @SET "selected_shelltype=%nextshelltype[win32___________]%"
@ECHO selected_shelltype %selected_shelltype% @REM @ECHO selected_shelltype %selected_shelltype%
@CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed @CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed
@ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% @REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed%
@SET "selected_shellpath=%nextshellpath[win32___________]%" @SET "selected_shellpath=%nextshellpath[win32___________]%"
@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed @CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed
@CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%" @CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%"
@ -202,8 +202,8 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @'
IF NOT "x%keyRemoved%"=="x%validshelltypes%" ( IF NOT "x%keyRemoved%"=="x%validshelltypes%" (
REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl
REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx
%selected_shellpath_trimmed% "%~dp0%fname%" %arglist% REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode
SET task_exitcode=!errorlevel! %selected_shellpath_trimmed% "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call;
) ELSE ( ) ELSE (
ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes%
SET task_exitcode=66 SET task_exitcode=66

349
src/modules/punk/repl-0.1.tm

@ -54,7 +54,7 @@ if {![info exists ::env(TERM)]} {
#} #}
} }
#todo - move to less generic namespace #todo - move to less generic namespace ie punk::repl
namespace eval repl { namespace eval repl {
variable screen_last_chars "" ;#a small sliding append buffer for last char of any screen output to detect \n vs string variable screen_last_chars "" ;#a small sliding append buffer for last char of any screen output to detect \n vs string
variable screen_last_char_list [list] variable screen_last_char_list [list]
@ -65,11 +65,12 @@ namespace eval repl {
#important not to initialize - as it can be preset by cooperating package before app-punk has been package required #important not to initialize - as it can be preset by cooperating package before app-punk has been package required
#(this is an example of a deaddrop) #(this is an example of a deaddrop)
variable post_script variable post_script
variable signal_control_c 0
} }
namespace eval punk::repl { namespace eval punk::repl {
variable debug_repl 0 variable debug_repl 0
variable signal_control_c 0
variable signal_control_c_msg ""
proc todo {} { proc todo {} {
puts "tcl History" puts "tcl History"
@ -100,7 +101,7 @@ namespace eval punk::repl {
#todo - make optional/configurable? #todo - make optional/configurable?
proc bgerror2 {args} { proc bgerror2 {args} {
puts stderr "====================" puts stderr "===================="
puts stderr "repl::bgerror" puts stderr "punk::repl::bgerror"
puts stderr "====================" puts stderr "===================="
puts stderr "[lindex $args 0]" puts stderr "[lindex $args 0]"
puts stderr "-------------------" puts stderr "-------------------"
@ -124,79 +125,107 @@ namespace eval punk::repl {
} }
if {![llength [info commands ::bgerror]]} { if {![llength [info commands ::bgerror]]} {
#interp alias {} bgerror {} ::repl::bgerror #interp alias {} bgerror {} ::punk::repl::bgerror
} }
interp bgerror "" ::punk::repl::bgerror interp bgerror "" ::punk::repl::bgerror
} }
namespace eval repl { namespace eval repl {
}
namespace eval ::repl::term {
} }
package require term::ansi::code::ctrl
if {$::tcl_platform(platform) eq "windows"} { if {$::tcl_platform(platform) eq "windows"} {
#jmn disable twapi
#package require zzzload
#zzzload::pkg_require twapi
after idle [list after 1000 {
#puts stdout "===============repl loading twapi===========" #puts stdout "===============repl loading twapi==========="
#zzzload::pkg_wait twapi
if {![catch {package require twapi}]} { if {![catch {package require twapi}]} {
proc ::repl::term::handler_console_control {args} { #If script launched with windows batch file - we have to be careful to stop a ctrl-c from eventually reaching the batch file when the program terminates, even if fully handled here.
#puts -nonewline stdout . #This is done from within the launching batch file
#flush stdout proc ::punk::repl::handler_console_control {args} {
incr ::repl::signal_control_c variable signal_control_c
variable signal_control_c_msg
switch -- [lindex $args 0] {
ctrl-c {
#puts stderr "->event $args"
flush stderr
incr signal_control_c
#rputs stderr "* console_control: $args" #rputs stderr "* console_control: $args"
if {$::punk::console::is_raw} { if {$::punk::console::is_raw} {
if {[lindex $::errorCode 0] eq "CHILDKILLED"} {
#rputs stderr "\n|repl> ctrl-c errorCode: $::errorCode"
#avoid spurious triggers after interrupting a command..
#review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl
set ::punk::repl::signal_control_c 0
set preverr [string map [list "child killed" "child_killed"] $::errorInfo]
catch {error $preverr} ;#for errorInfo display
return 42
} else {
#how to let rawmode loop handle it? It doesn't seem to get through if we return 0 #how to let rawmode loop handle it? It doesn't seem to get through if we return 0
puts stderr "signal ctrl-c while in raw mode" #puts stderr "signal ctrl-c while in raw mode"
after 200 {exit 42} ;#temp #flush stderr
set signal_control_c_msg "signal ctrl-c while in raw mode"
if {$signal_control_c > 5} {
puts stderr "signal ctrl-c $signal_control_c received - sending to default handler"
flush stderr flush stderr
punk::mode line
return 0
}
return 1
#after 200 {exit 42} ;#temp
#return 42
}
}
if {[lindex $::errorCode 0] eq "CHILDKILLED"} {
set signal_control_c 0
set preverr [string map [list "child killed" "child_killed"] $::errorInfo]
catch {error $preverr} ;#for errorInfo display
return 42 return 42
} }
#note - returning 0 means pass event to other handlers including OS default handler #note - returning 0 means pass event to other handlers including OS default handler
if {$::repl::signal_control_c <= 2} { if {$signal_control_c <= 2} {
set remaining [expr {3 - $::repl::signal_control_c}] set remaining [expr {3 - $signal_control_c}]
puts stderr "signal ctrl-c (perform $remaining more to quit, enter to return to repl)" puts stderr "signal ctrl-c (perform $remaining more to quit, enter to return to repl)"
flush stderr flush stderr
return 1 return 1
} elseif {$::repl::signal_control_c == 3} { } elseif {$signal_control_c == 3} {
puts stderr "signal ctrl-c x3 received - quitting" puts stderr "signal ctrl-c x3 received - quitting."
flush stderr flush stderr
after 25 after 25
quit quit
return 1 return 1
} elseif {$::repl::signal_control_c == 4} { } elseif {$signal_control_c == 4} {
puts stderr "signal ctrl-c x4 received - one more to hard exit" puts stderr "signal ctrl-c x4 received - one more to hard exit"
flush stderr flush stderr
return 1 return 1
} elseif {$::repl::signal_control_c >= 5} { } elseif {$signal_control_c >= 5} {
#a script that allows events to be processed could still be running #a script that allows events to be processed could still be running
puts stderr "signal ctrl-c x5 received - hard exit" puts stderr "signal ctrl-c x5 received - hard exit"
flush stderr flush stderr
after 25 after 25
exit 499 ;# HTTP 'client closed request' - just for the hell of it. exit 499 ;# HTTP 'client closed request' - just for the hell of it.
} else { } else {
puts stderr "signal ctrl-c $::repl::signal_control_c received" puts stderr "signal ctrl-c $signal_control_c received"
flush stderr flush stderr
#return 0 to fall through to default handler #return 0 to fall through to default handler
return 0 return 0
} }
}
default {
puts stderr "unhandled console signal $args"
return 1
}
} }
twapi::set_console_control_handler ::repl::term::handler_console_control }
twapi::set_console_control_handler ::punk::repl::handler_console_control
#we can't yet emit from an event with proper prompt handling - #we can't yet emit from an event with proper prompt handling -
#repl::rputs stdout "twapi loaded" #repl::rputs stdout "twapi loaded"
} else { } else {
#repl::rputs stderr " Failed to load twapi" #repl::rputs stderr " Failed to load twapi"
} }
}]
} else { } else {
#TODO #TODO
} }
@ -367,7 +396,7 @@ proc ::unknown args {
} }
#experiment todo - use twapi and named pipes #windows experiment todo - use twapi and named pipes
#twapi::namedpipe_server {\\.\pipe\something} #twapi::namedpipe_server {\\.\pipe\something}
#Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones
#These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc
@ -379,99 +408,7 @@ proc ::unknown args {
set c1 $new set c1 $new
} }
# 'script' command to fake a tty # -- --- --- --- ---
# note that we lose the exit code from the underlying command by using 'script' if we call shellfilter::run without -e option to script
set scr [auto_execok script]
set scr "" ;#set src to empty to disable - script is just a problematic experiment
if {$scr ne ""} {
#set scriptrun "( $c1 [lrange $args 1 end] )"
if 0 {
set scriptrun "( $c1 "
foreach a [lrange $args 1 end] {
if {[string first " " $a] > 0} {
#append scriptrun "\"$a\""
append scriptrun $a
} else {
append scriptrun $a
}
append scriptrun " "
}
append scriptrun " )"
}
#-------------------------------------
if 0 {
package require string::token::shell
set shellparts [string token shell -indices $args]
set scriptrun "( $c1 "
foreach info [lrange $shellparts 1 end] {
set type [lindex $info 0]
if {$type eq "D:QUOTED"} {
append scriptrun "\""
append scriptrun [lindex $info 3]
append scriptrun "\""
} elseif {$type eq "S:QUOTED"} {
append scriptrun "'"
append scriptrun [lindex $info 3]
append scriptrun "'"
} elseif {$type eq "PLAIN"} {
append scriptrun [lindex $info 3]
} else {
error "Can't interpret '$args' with sh-like syntax"
}
append scriptrun " "
}
append scriptrun " )"
}
#-------------------------------------
#uplevel 1 [list ::catch \
[list ::shellfilter::run [list $scr -q -e -c $scriptrun /dev/null] -teehandle punk -inbuffering line -outbuffering none ] \
::tcl::UnknownResult ::tcl::UnknownOptions]
if {[string tolower [file rootname [file tail $new]]] ne "script"} {
if {$::env(SHELL) eq "punk86"} {
set shellcmdflag "punk86 cmdb"
} elseif {$::env(SHELL) eq "cmd"} {
set shellcmdflag "cmd /c"
} elseif {$::env(SHELL) eq "pwsh"} {
set shellcmdflag "pwsh -c"
} else {
# sh etc
#set shellcmdflag "$::env(SHELL) -c"
set shellcmdflag "-c"
}
#set commandlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not [concat [list $new ] [lrange $args 1 end]]]
set commandlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $args $shellcmdflag]
puts stderr ">>> [lindex $commandlist 4]"
} else {
set commandlist [list $new {*}[lrange $args 1 end]]
}
puts stderr ">>>scriptrun_commandlist: $commandlist"
#ansiwrap for testing
#set id_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}]
uplevel #0 [list ::catch [list ::shellfilter::run $commandlist -teehandle punk -inbuffering line -outbuffering none ] ::tcl::UnknownResult ::tcl::UnknownOptions]
#shellfilter::stack::remove stderr $id_stderr
puts stdout "script result $::tcl::UnknownOptions $::tcl::UnknownResult"
if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} {
dict set ::tcl::UnknownOptions -code error
set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult"
} else {
#no point returning "exitcode 0" if that's the only non-error return.
#It is misleading. Better to return empty string.
set ::tcl::UnknownResult ""
}
} else {
set idlist_stdout [list] set idlist_stdout [list]
set idlist_stderr [list] set idlist_stderr [list]
set shellrun::runout "" set shellrun::runout ""
@ -480,8 +417,13 @@ proc ::unknown args {
#lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}]
if {![dict get $::punk::config::running exec_unknown]} { if {![dict get $::punk::config::running exec_unknown]} {
#This runs external executables in a context in which they are not attached to a terminal
#VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output
#ctrl-c propagation also needs to be considered
set teehandle punksh
uplevel 1 [list ::catch \ uplevel 1 [list ::catch \
[list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle punk -inbuffering line -outbuffering none ] \ [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] \
::tcl::UnknownResult ::tcl::UnknownOptions] ::tcl::UnknownResult ::tcl::UnknownOptions]
if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} {
@ -499,7 +441,8 @@ proc ::unknown args {
uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions]
#we can't detect stdout/stderr output from the exec #we can't detect stdout/stderr output from the exec
#for now emit an extra \n on stderr #for now emit an extra \n on stderr
#todo - use console apis (twapi on windows) to detect cursor posn? #todo - there is probably no way around this but to somehow exec in the context of a completely separate console
#This is probably a tricky problem - especially to do cross-platform
# #
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit
if {[dict get $::tcl::UnknownOptions -code] == 0} { if {[dict get $::tcl::UnknownOptions -code] == 0} {
@ -521,7 +464,7 @@ proc ::unknown args {
foreach id $idlist_stderr { foreach id $idlist_stderr {
shellfilter::stack::remove stderr $id shellfilter::stack::remove stderr $id
} }
} # -- --- --- --- ---
#uplevel 1 [list ::catch \ #uplevel 1 [list ::catch \
@ -573,6 +516,7 @@ proc ::unknown args {
} }
} }
} }
#punk - disable prefix match search #punk - disable prefix match search
set default_cmd_search 0 set default_cmd_search 0
if {$default_cmd_search} { if {$default_cmd_search} {
@ -602,16 +546,16 @@ punk::configure_unknown ;#must be called because we hacked the tcl 'unknown' pro
proc repl::reset_prompt {} { proc punk::repl::reset_prompt {} {
variable prompt_reset_flag variable prompt_reset_flag
set prompt_reset_flag 1 set prompt_reset_flag 1
} }
#todo - review #aliases c and clear to this by ::punk
proc repl::term::reset {} { proc punk::repl::reset_terminal {} {
set prompt_reset_flag 1 set prompt_reset_flag 1
#clear ;#call to external executable which may not be available #clear ;#call to external executable which may not be available
puts stdout [::term::ansi::code::ctrl::rd] puts -nonewline stdout [::punk::ansi::reset]
} }
proc repl::get_prompt_config {} { proc repl::get_prompt_config {} {
@ -630,6 +574,7 @@ proc repl::get_prompt_config {} {
return [list resultprompt $resultprompt nlprompt $nlprompt infoprompt $infoprompt debugprompt $debugprompt] return [list resultprompt $resultprompt nlprompt $nlprompt infoprompt $infoprompt debugprompt $debugprompt]
} }
proc repl::start {inchan args} { proc repl::start {inchan args} {
#puts stderr "-->repl::start $inchan $args"
variable commandstr variable commandstr
variable readingchunk variable readingchunk
@ -647,6 +592,7 @@ proc repl::start {inchan args} {
variable startinstance variable startinstance
variable loopinstance variable loopinstance
if {[namespace exists ::punkapp]} { if {[namespace exists ::punkapp]} {
#review - document ?
if {[dict exists $args -defaultresult]} { if {[dict exists $args -defaultresult]} {
set ::punkapp::default_result [dict get $args -defaultresult] set ::punkapp::default_result [dict get $args -defaultresult]
} }
@ -680,10 +626,12 @@ proc repl::start {inchan args} {
#set punk::console::tabwidth [punk::console::get_tabstop_apparent_width] #set punk::console::tabwidth [punk::console::get_tabstop_apparent_width]
} }
vwait [namespace current]::done vwait [namespace current]::done
#puts stderr "-->start done = $::repl::done"
#todo - override exit? #todo - override exit?
#after 0 ::repl::post_operations #after 0 ::repl::post_operations
after idle ::repl::post_operations after idle ::repl::post_operations
vwait repl::post_operations_done vwait repl::post_operations_done
#puts stderr "-->start post_operations_done = $::repl::post_operations_done"
if {[namespace exists ::punkapp]} { if {[namespace exists ::punkapp]} {
#todo check and get punkapp::result array - but what key? #todo check and get punkapp::result array - but what key?
if {[info exists ::punkapp::result(shell)]} { if {[info exists ::punkapp::result(shell)]} {
@ -696,6 +644,7 @@ proc repl::start {inchan args} {
return $temp return $temp
} }
} }
punk::mode line
return 0 return 0
} }
proc repl::post_operations {} { proc repl::post_operations {} {
@ -730,18 +679,21 @@ proc repl::reopen_stdin {} {
twapi::SetStdHandle -10 $h twapi::SetStdHandle -10 $h
} }
puts stderr "restarting repl on inputchannel:$s" puts stderr "restarting repl on inputchannel:$s"
return [repl::start $s] return [repl::start $s -title "reopen_stdin a"]
} else { } else {
#/dev/tty - reference to the controlling terminal for a process #/dev/tty - reference to the controlling terminal for a process
#review/test #review/test
set s [open "/dev/tty" r] set s [open "/dev/tty" r]
} }
repl::start stdin repl::start stdin -title "reopen_stdin b"
} }
#todo - avoid putting this in gobal namespace?
#collisions with other libraries apps?
proc quit {} { proc quit {} {
set ::repl::done "quit" set ::repl::done "quit"
#puts stderr "quit called"
return "" ;#make sure to return nothing so "quit" doesn't land on stdout return "" ;#make sure to return nothing so "quit" doesn't land on stdout
} }
@ -1463,30 +1415,78 @@ namespace eval punk::repl::class {
} }
} }
proc repl::repl_handler_checkchannel {inputchan} {
if {$::repl::signal_control_c > 0 || [chan eof $inputchan]} {
if {[lindex $::errorCode 0] eq "CHILDKILLED"} { proc ::punk::repl::repl_handler_checkchannel {inputchan} {
#rputs stderr "\n|repl> ctrl-c errorCode: $::errorCode" if {[catch {chan eof $inputchan} is_eof]} {
#avoid spurious triggers after interrupting a command.. ::repl::rputs stderr "\n|repl> repl_handler_checkchannel error on $inputchan. (closed?) msg:$is_eof"
#review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl
set ::repl::signal_control_c 0
set preverr [string map [list "child killed" "child_killed"] $::errorInfo]
catch {error $preverr} ;#for errorInfo display
} else { } else {
set ::repl::signal_control_c 0 if {$is_eof} {
fileevent $inputchan readable {}
set reading 0
set running 0
if {$::tcl_interactive} { if {$::tcl_interactive} {
rputs stderr "\n|repl> EOF on $inputchan." ::repl::rputs stderr "\n|repl> repl_handler_checkchannel EOF on $inputchan."
} }
set [namespace current]::done 1
after 1 [list repl::reopen_stdin]
#tailcall repl::reopen_stdin
} }
} }
} }
proc ::punk::repl::repl_handler_checkcontrolsignal_linemode {inputchan} {
#todo - what?
return
variable signal_control_c
if {$signal_control_c > 0} {
if {$::tcl_interactive} {
::repl::rputs stderr "\n|repl> repl_handler_checkcontrolsignal_linemode ctrl-c errorCode 0: [lindex $::errorCode 0]"
}
}
}
proc ::punk::repl::repl_handler_checkcontrolsignal_rawmode {inputchan} {
variable signal_control_c
variable signal_control_c_msg
if {$signal_control_c > 0 && $signal_control_c_msg ne "" } {
#if {$::tcl_interactive} {
# ::repl::rputs stderr "\n|repl> repl_handler_checkcontrolsignal_rawmode ctrl-c errorCode 0: [lindex $::errorCode 0]"
#}
set signal_control_c_msg ""
if {$signal_control_c <= 2} {
set remaining [expr {3 - $signal_control_c}]
if {$::tcl_interactive} {
puts stderr "rawmode signal ctrl-c (perform $remaining more to quit, enter to return to repl)"
flush stderr
}
return 1
} elseif {$signal_control_c == 3} {
if {$::tcl_interactive} {
puts stderr "rawmode signal ctrl-c x3 received - quitting"
flush stderr
}
after 25
quit
return 1
} elseif {$signal_control_c == 4} {
if {$::tcl_interactive} {
puts stderr "rawmode signal ctrl-c x4 received - one more to hard exit"
flush stderr
}
return 1
} elseif {$signal_control_c >= 5} {
#a script that allows events to be processed could still be running
if {$::tcl_interactive} {
puts stderr "rawmode signal ctrl-c x5 received - hard exit"
flush stderr
}
punk::mode line
after 25
exit 499 ;# HTTP 'client closed request' - just for the hell of it.
} else {
#shouldn't get here.. if we do somehow - let the default handler have a go
puts stderr "rawmode signal ctrl-c $signal_control_c received"
flush stderr
#return 0 to fall through to default handler
punk::mode line
return 0
}
}
}
proc repl::repl_handler_restorechannel {inputchan previous_input_state} { proc repl::repl_handler_restorechannel {inputchan previous_input_state} {
if {[chan conf $inputchan] ne $previous_input_state} { if {[chan conf $inputchan] ne $previous_input_state} {
set restore_input_conf [dict remove $previous_input_state -inputmode] ;#Attempting to set input mode often gives permission denied on windows - why? set restore_input_conf [dict remove $previous_input_state -inputmode] ;#Attempting to set input mode often gives permission denied on windows - why?
@ -1502,8 +1502,16 @@ proc repl::repl_handler_restorechannel {inputchan previous_input_state} {
return [chan conf $inputchan] return [chan conf $inputchan]
} }
proc repl::repl_handler {inputchan prompt_config} { proc repl::repl_handler {inputchan prompt_config} {
# -- review
variable in_repl_handler variable in_repl_handler
set in_repl_handler [list $inputchan $prompt_config] set in_repl_handler [list $inputchan $prompt_config]
# --
variable prompt_reset_flag
if {$prompt_reset_flag == 1} {
set prompt_config [get_prompt_config]
set prompt_reset_flag 0
}
fileevent $inputchan readable {} fileevent $inputchan readable {}
upvar ::punk::console::input_chunks_waiting input_chunks_waiting upvar ::punk::console::input_chunks_waiting input_chunks_waiting
@ -1593,7 +1601,8 @@ proc repl::repl_handler {inputchan prompt_config} {
} }
} else { } else {
repl_handler_checkchannel $inputchan punk::repl::repl_handler_checkchannel $inputchan
punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan
# -- --- --- # -- --- ---
#set chunksize [gets $inputchan chunk] #set chunksize [gets $inputchan chunk]
# -- --- --- # -- --- ---
@ -1628,7 +1637,9 @@ proc repl::repl_handler {inputchan prompt_config} {
} else { } else {
repl_handler_checkchannel $inputchan punk::repl::repl_handler_checkchannel $inputchan
punk::repl::repl_handler_checkcontrolsignal_rawmode $inputchan
if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} {
chan configure $inputchan -blocking 0 chan configure $inputchan -blocking 0
chan configure $inputchan -translation lf chan configure $inputchan -translation lf
@ -1663,21 +1674,30 @@ proc repl::repl_handler {inputchan prompt_config} {
} }
#################################################### ####################################################
} else { } else {
#rputs stderr "repl_handler EOF inputchannel:[chan conf $inputchan]" #repl_handler_checkchannel $inputchan
repl_handler_checkchannel $inputchan fileevent $inputchan readable {}
set reading 0
set running 0
if {$::tcl_interactive} {
rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]"
#rputs stderr "\n|repl> ctrl-c EOF on $inputchan."
}
set [namespace current]::done 1
after 1 [list repl::reopen_stdin]
} }
set in_repl_handler [list] set in_repl_handler [list]
} }
proc repl::editbuf {index args} {
variable editbuf_list proc punk::repl::editbuf {index args} {
set editbuf [lindex $editbuf_list $index] set editbuf [lindex $::repl::editbuf_list $index]
if {$editbuf ne ""} { if {$editbuf ne ""} {
$editbuf {*}$args $editbuf {*}$args
} else { } else {
return "No such index in editbuf list" return "No such index in editbuf list"
} }
} }
interp alias {} editbuf {} ::repl::editbuf interp alias {} editbuf {} ::punk::repl::editbuf
proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} { proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} {
variable loopinstance variable loopinstance
variable loopcomplete variable loopcomplete
@ -1800,13 +1820,13 @@ proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} {
#if we get just ctrl-c in one chunk #if we get just ctrl-c in one chunk
#ctrl-c #ctrl-c
if {$chunk eq "\x03"} { if {$chunk eq "\x03"} {
#::repl::term::handler_console_control "ctrl-c_via_rawloop" #::punk::repl::handler_console_control "ctrl-c_via_rawloop"
error "character 03 -> ctrl-c" error "character 03 -> ctrl-c"
} }
#for now - exit with small delay for tidyup #for now - exit with small delay for tidyup
#ctrl-z #ctrl-z
if {$chunk eq "\x1a"} { if {$chunk eq "\x1a"} {
#::repl::term::handler_console_control "ctrl-z_via_rawloop" #::punk::repl::handler_console_control "ctrl-z_via_rawloop"
punk::mode line punk::mode line
after 1000 exit after 1000 exit
return return
@ -2483,8 +2503,8 @@ proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} {
} else { } else {
#append commandstr \n #append commandstr \n
if {$::repl::signal_control_c} { if {$::punk::repl::signal_control_c} {
set ::repl::signal_control_c 0 set ::punk::repl::signal_control_c 0
fileevent $inputchan readable {} fileevent $inputchan readable {}
rputs stderr "* console_control: control-c" rputs stderr "* console_control: control-c"
flush stderr flush stderr
@ -2579,8 +2599,7 @@ package provide punk::repl [namespace eval punk::repl {
set version 0.1 set version 0.1
}] }]
#repl::start stdin
#exit 0
#repl::start $program_read_stdin_pipe #repl::start $program_read_stdin_pipe

111
src/modules/shellfilter-0.1.9.tm

@ -128,117 +128,6 @@ namespace eval shellfilter::pipe {
} }
} }
namespace eval shellfilter::ansi2 {
#shellfilter::ansi procs only: adapted from ansicolor page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control except where otherwise marked
variable test "blah\033\[1;33mETC\033\[0;mOK"
namespace export + = ?
#CSI <n> m = SGR (Select Graphic Rendition)
variable SGR_setting_map {
bold 1 dim 2 blink 5 fastblink 6 noblink 25 hide 8 normal 22
underline 4 doubleunderline 21 nounderline 24 strike 9 nostrike 29 italic 3 noitalic 23
reverse 7 noreverse 27 defaultfg 39 defaultbg 49
overline 53 nooverline 55 frame 51 framecircle 52 noframe 54
}
variable SGR_colour_map {
black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37
Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47
BLACK 100 RED 101 GREEN 102 YELLOW 103 BLUE 104 PURPLE 105 CYAN 106 WHITE 107
}
variable SGR_map
set SGR_map [dict merge $SGR_colour_map $SGR_setting_map]
proc + {args} {
#don't disable ansi here.
#we want this to be available to call even if ansi is off
variable SGR_map
set t [list]
foreach i $args {
if {[string is integer -strict $i]} {
lappend t $i
} elseif {[string first ";" $i] >=0} {
#literal with params
lappend t $i
} else {
if {[dict exists $SGR_map $i]} {
lappend t [dict get $SGR_map $i]
} else {
#accept examples for foreground
# 256f-# or 256fg-# or 256f#
# rgbf-<r>-<g>-<b> or rgbfg-<r>-<g>-<b> or rgbf<r>-<g>-<b>
switch -nocase -glob $i {
"256f*" {
set cc [string trim [string range $i 4 end] -gG]
lappend t "38;5;$cc"
}
"256b*" {
set cc [string trim [string range $i 4 end] -gG]
lappend t "48;5;$cc"
}
"rgbf*" {
set rgb [string trim [string range $i 4 end] -gG]
lassign [split $rgb -] r g b
lappend t "38;2;$r;$g;$b"
}
"rgbb*" {
set rgb [string trim [string range $i 4 end] -gG]
lassign [split $rgb -] r g b
lappend t "48;2;$r;$g;$b"
}
}
}
}
}
# \033 - octal. equivalently \x1b in hex which is more common in documentation
if {![llength $t]} {
return "" ;# a+ nonexistent should return nothing rather than a reset ( \033\[\;m is a reset even without explicit zero(s))
}
return "\x1b\[[join $t {;}]m"
}
proc = {args} {
#don't disable ansi here.
#we want this to be available to call even if ansi is off
variable SGR_map
set t [list]
foreach i $args {
if {[string is integer -strict $i]} {
lappend t $i
} elseif {[string first ";" $i] >=0} {
#literal with params
lappend t $i
} else {
if {[dict exists $SGR_map $i]} {
lappend t [dict get $SGR_map $i]
} else {
#accept examples for foreground
# 256f-# or 256fg-# or 256f#
# rgbf-<r>-<g>-<b> or rgbfg-<r>-<g>-<b> or rgbf<r>-<g>-<b>
if {[string match -nocase "256f*" $i]} {
set cc [string trim [string range $i 4 end] -gG]
lappend t "38;5;$cc"
} elseif {[string match -nocase 256b* $i]} {
set cc [string trim [string range $i 4 end] -gG]
lappend t "48;5;$cc"
} elseif {[string match -nocase rgbf* $i]} {
set rgb [string trim [string range $i 4 end] -gG]
lassign [split $rgb -] r g b
lappend t "38;2;$r;$g;$b"
} elseif {[string match -nocase rgbb* $i]} {
set rgb [string trim [string range $i 4 end] -gG]
lassign [split $rgb -] r g b
lappend t "48;2;$r;$g;$b"
}
}
}
}
# \033 - octal. equivalently \x1b in hex which is more common in documentation
# empty list [a=] should do reset - same for [a= nonexistant]
# explicit reset at beginning of parameter list for a= (as opposed to a+)
set t [linsert $t 0 0]
return "\x1b\[[join $t {;}]m"
}
}

6
src/modules/shellrun-0.1.1.tm

@ -279,8 +279,8 @@ namespace eval shellrun {
} else { } else {
set e $::shellrun::runerr set e $::shellrun::runerr
} }
#append chunk "[a+ red light]$e$RST\n" #append chunk "[a+ red normal]$e$RST\n"
append chunk "[a+ red light]$e$RST" append chunk "[a+ red normal]$e$RST"
} }
lappend chunklist [list stderr $chunk] lappend chunklist [list stderr $chunk]
@ -391,7 +391,7 @@ namespace eval shellrun {
} else { } else {
set o $::shellrun::runout set o $::shellrun::runout
} }
append chunk "[a+ white light]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not.
} }
lappend chunklist [list stdout $chunk] lappend chunklist [list stdout $chunk]

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

@ -3254,10 +3254,11 @@ namespace eval textblock {
set defaults [dict create\ set defaults [dict create\
-return "string"\ -return "string"\
-compact 1\ -compact 1\
-forcecolour 0\
] ]
dict for {k v} $args { dict for {k v} $args {
switch -- $k { switch -- $k {
-return - -compact {} -return - -compact - -forcecolour {}
default { default {
"textblock::periodic unknown option '$k'. Known options: [dict keys $defaults]" "textblock::periodic unknown option '$k'. Known options: [dict keys $defaults]"
} }
@ -3265,6 +3266,11 @@ namespace eval textblock {
} }
set opts [dict merge $defaults $args] set opts [dict merge $defaults $args]
set opt_return [dict get $opts -return] set opt_return [dict get $opts -return]
if {[dict get $opts -forcecolour]} {
set fc forcecolour
} else {
set fc ""
}
#examples ptable.com #examples ptable.com
set elements [list\ set elements [list\
@ -3285,61 +3291,61 @@ namespace eval textblock {
set ecat [dict create] set ecat [dict create]
set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra]
set ansi [a+ Web-gold web-black] set ansi [a+ {*}$fc Web-gold web-black]
foreach e $cat_alkaline_earth { foreach e $cat_alkaline_earth {
dict set ecat $e [list ansi $ansi cat alkaline_earth] dict set ecat $e [list ansi $ansi cat alkaline_earth]
} }
set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I]
set ansi [a+ Web-lightgreen web-black] set ansi [a+ {*}$fc Web-lightgreen web-black]
foreach e $cat_reactive_nonmetal { foreach e $cat_reactive_nonmetal {
dict set ecat $e [list ansi $ansi cat reactive_nonmetal] dict set ecat $e [list ansi $ansi cat reactive_nonmetal]
} }
set cat [list Li Na K Rb Cs Fr] set cat [list Li Na K Rb Cs Fr]
set ansi [a+ Web-Khaki web-black] set ansi [a+ {*}$fc Web-Khaki web-black]
foreach e $cat { foreach e $cat {
dict set ecat $e [list ansi $ansi cat alkali_metals] dict set ecat $e [list ansi $ansi cat alkali_metals]
} }
set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs]
set ansi [a+ Web-lightsalmon web-black] set ansi [a+ {*}$fc Web-lightsalmon web-black]
foreach e $cat { foreach e $cat {
dict set ecat $e [list ansi $ansi cat transition_metals] dict set ecat $e [list ansi $ansi cat transition_metals]
} }
set cat [list Al Ga In Sn Tl Pb Bi Po] set cat [list Al Ga In Sn Tl Pb Bi Po]
set ansi [a+ Web-lightskyblue web-black] set ansi [a+ {*}$fc Web-lightskyblue web-black]
foreach e $cat { foreach e $cat {
dict set ecat $e [list ansi $ansi cat post_transition_metals] dict set ecat $e [list ansi $ansi cat post_transition_metals]
} }
set cat [list B Si Ge As Sb Te At] set cat [list B Si Ge As Sb Te At]
set ansi [a+ Web-turquoise web-black] set ansi [a+ {*}$fc Web-turquoise web-black]
foreach e $cat { foreach e $cat {
dict set ecat $e [list ansi $ansi cat metalloids] dict set ecat $e [list ansi $ansi cat metalloids]
} }
set cat [list He Ne Ar Kr Xe Rn] set cat [list He Ne Ar Kr Xe Rn]
set ansi [a+ Web-orchid web-black] set ansi [a+ {*}$fc Web-orchid web-black]
foreach e $cat { foreach e $cat {
dict set ecat $e [list ansi $ansi cat noble_gases] dict set ecat $e [list ansi $ansi cat noble_gases]
} }
set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr]
set ansi [a+ Web-plum web-black] set ansi [a+ {*}$fc Web-plum web-black]
foreach e $cat { foreach e $cat {
dict set ecat $e [list ansi $ansi cat actinoids] dict set ecat $e [list ansi $ansi cat actinoids]
} }
set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu]
set ansi [a+ Web-tan web-black] set ansi [a+ {*}$fc Web-tan web-black]
foreach e $cat { foreach e $cat {
dict set ecat $e [list ansi $ansi cat lanthanoids] dict set ecat $e [list ansi $ansi cat lanthanoids]
} }
set cat [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] set cat [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og]
set ansi [a+ Web-whitesmoke web-black] set ansi [a+ {*}$fc Web-whitesmoke web-black]
foreach e $cat { foreach e $cat {
dict set ecat $e [list ansi $ansi cat other] dict set ecat $e [list ansi $ansi cat other]
} }
@ -3379,14 +3385,14 @@ namespace eval textblock {
if {$opt_return eq "string"} { if {$opt_return eq "string"} {
$t configure -frametype_header light $t configure -frametype_header light
$t configure -ansiborder_header [a+ web-white] $t configure -ansiborder_header [a+ {*}$fc web-white]
$t configure -ansibase_header [a+ Web-black] $t configure -ansibase_header [a+ {*}$fc Web-black]
$t configure -ansibase_body [a+ Web-black] $t configure -ansibase_body [a+ {*}$fc Web-black]
$t configure -ansiborder_body [a+ web-black] $t configure -ansiborder_body [a+ {*}$fc web-black]
$t configure -frametype block $t configure -frametype block
set output [textblock::frame -ansiborder [a+ Web-black web-cornflowerblue] -type heavy -title "[a+ Web-black] Periodic Table " [$t print]] set output [textblock::frame -ansiborder [a+ {*}$fc Web-black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Web-black] Periodic Table " [$t print]]
return $output return $output
} }
return $t return $t
@ -4247,14 +4253,31 @@ namespace eval textblock {
# >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {|
# >} punk::lib::list_as_lines <lhs/0,rhs/1| # >} punk::lib::list_as_lines <lhs/0,rhs/1|
proc example {} { proc example {args} {
set defaults {-forcecolour 0}
foreach {k v} $args {
switch -- $k {
-forcecolour {}
default {
error "textblock::example unrecognised option '$k'. Known-options: [dict keys $defaults]"
}
}
}
set opts [dict merge $defaults $args]
set opt_forcecolour 0
if {[dict get $opts -forcecolour]} {
set fc forcecolour
set opt_forcecolour 1
} else {
set fc ""
}
set pleft [>punk . rhs] set pleft [>punk . rhs]
set pright [>punk . lhs] set pright [>punk . lhs]
set prightair [>punk . lhs_air] set prightair [>punk . lhs_air]
set red [a+ red]; set redb [a+ red bold] set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold]
set green [a+ green]; set greenb [a+ green bold] set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold]
set cyan [a+ cyan];set cyanb [a+ cyan bold] set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold]
set blue [a+ blue];set blueb [a+ blue bold] set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold]
set RST [a] set RST [a]
set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz]
set punks [textblock::join $pleft $pright] set punks [textblock::join $pleft $pright]
@ -4274,7 +4297,7 @@ namespace eval textblock {
set spantable [[spantest] print] set spantable [[spantest] print]
append out [textblock::join $fancy " " $spantable] \n append out [textblock::join $fancy " " $spantable] \n
#append out [textblock::frame -title gr $gr0] #append out [textblock::frame -title gr $gr0]
append out [textblock::periodic] append out [textblock::periodic -forcecolour $opt_forcecolour]
return $out return $out
} }

39
src/modules/winlibreoffice-999999.0a1.0.tm

@ -18,6 +18,7 @@
## Requirements ## Requirements
##e.g package require frobz ##e.g package require frobz
package require uri ;#tcllib package require uri ;#tcllib
package require punk::lib
#windows? REVIEW - can we provide a common api for other platforms with only script? tcluno instead? #windows? REVIEW - can we provide a common api for other platforms with only script? tcluno instead?
@ -90,7 +91,7 @@ namespace eval winlibreoffice {
return $fpath return $fpath
} }
#this #
proc convertFromUrl {fileuri} { proc convertFromUrl {fileuri} {
if {[string match "file:/*" $fileuri]} { if {[string match "file:/*" $fileuri]} {
set finfo [uri::split $fileuri] set finfo [uri::split $fileuri]
@ -136,6 +137,7 @@ namespace eval winlibreoffice {
set dt [get_desktop] set dt [get_desktop]
set doc [$dt loadComponentFromUrl "private:factory/$type" "_blank" 0 ""] ;#doesn't work without final param - empty string seems to work set doc [$dt loadComponentFromUrl "private:factory/$type" "_blank" 0 ""] ;#doesn't work without final param - empty string seems to work
puts "doc title: [$doc Title]" puts "doc title: [$doc Title]"
#title can be set with [$doc settitle "titletext"]
return $doc return $doc
} }
@ -160,6 +162,7 @@ namespace eval winlibreoffice {
set sheets [$doc getSheets] set sheets [$doc getSheets]
set s [$sheets getByIndex $idx] set s [$sheets getByIndex $idx]
puts stdout "Sheet: [$s getName]" puts stdout "Sheet: [$s getName]"
#set name with [$s setName "xxx"]
return $s return $s
} }
proc calcsheet_cell_range_by_name {sheet rangename} { proc calcsheet_cell_range_by_name {sheet rangename} {
@ -175,8 +178,42 @@ namespace eval winlibreoffice {
$cell setPropertyValue {*}$propset $cell setPropertyValue {*}$propset
#e.g "NumberFormat" 49 #e.g "NumberFormat" 49
# YYYY-MM-DD # YYYY-MM-DD
#can also use in this case [$cell NumberFormat]
}
proc calccell_setCellBackColorRGB {cell rgb} {
set rgb [string trim $rgb #]
set dec [punk::lib::hex2dec $rgb]
$cell setPropertyValue "CellBackColor" [expr {$dec}] ;#colour value must be integer - will fail if string
}
proc calccell_setCharColorRGB {cell rgb} {
set rgb [string trim $rgb #]
set dec [punk::lib::hex2dec $rgb]
$cell setPropertyValue "CharColor" [expr {$dec}]
} }
#cell charFontName
#cell charWeight
#com.sun.star.awt.FontWeight
#https://api.libreoffice.org/docs/idl/ref/FontWeight_8idl.html
# values are listed with 6 DPs - but one seems to work
# only setting to normal and bold seem to result in a value (regular & bold) in the format->font style dialog for the cell.
#DONTKNOW 0.0
#THIN 50.0
#ULTRALIGHT 60.0
#LIGHT 75.0
#SEMILIGHT 90.0
#NORMAL 100.0
#SEMIBOLD 110.0
#BOLD 150.0
#ULTRABOLD 175.0
#BLACK 200.0
#a hack #a hack
#return libreoffice date in days since 1899.. #return libreoffice date in days since 1899..
proc date_from_clockseconds_approx {cs} { proc date_from_clockseconds_approx {cs} {

2
src/punk86.vfs/lib/app-punk/repl.tcl

@ -134,7 +134,7 @@ foreach pkg $required {
} }
package require punk::repl package require punk::repl
repl::start stdin repl::start stdin -title app-punk

4
src/punk86.vfs/main.tcl

@ -18,6 +18,8 @@ if {[llength $::argv]} {
package require app-shellspy package require app-shellspy
} else { } else {
package require app-punk package require app-punk
repl::start stdin
#app-punk starts repl
#repl::start stdin -title "main.tcl"
} }

Loading…
Cancel
Save