Browse Source

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

master
Julian Noble 4 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. 2262
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  4. 20
      src/bootsupport/modules/punk/char-0.1.0.tm
  5. 112
      src/bootsupport/modules/punk/console-0.1.1.tm
  6. 173
      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. 2574
      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. 72
      src/modules/punk/console-999999.0a1.0.tm
  13. 8
      src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd
  14. 473
      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

2262
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
#cannot contain ansi or newlines
#(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
if {[dict exists $grapheme_widths $ch]} {
return [dict get $grapheme_widths $ch]
#if key eq "*" - we won't be able to clear that cache individually. Perhaps that's ok
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)
dict set grapheme_widths $ch $width
dict set grapheme_widths $key $ch $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
proc grapheme_width {char} {
error "grapheme_width unimplemented - use ansifreestring_width"

112
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
#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} {
#stdout
variable colour_disabled
variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} {
if {$ansi_wanted <= 0} {
puts -nonewline [punk::ansi::stripansi [::punk::ansi::a?]]
} else {
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} {
variable colour_disabled
variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} {
if {$ansi_wanted <= 0} {
return
}
tailcall punk::ansi::a {*}$args
#tailcall punk::ansi::a {*}$args
::punk::ansi::a {*}$args
}
proc code_a? {args} {
variable colour_disabled
variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} {
if {$ansi_wanted <= 0} {
return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]]
} else {
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 {}}} {
variable ansi_wanted
if {[string length $onoff]} {
@ -846,6 +832,7 @@ namespace eval punk::console {
false -
no {
set ansi_wanted 0
punk::ansi::sgr_cache clear
}
default {
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}]
}
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
if {[string length $onoff]} {
set onoff [string tolower $onoff]
if {$on ne ""} {
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
if {$onoff in [list 1 on true yes]} {
interp alias "" a+ "" punk::console::code_a+
set colour_disabled 0
} elseif {$onoff in [list 0 off false no]} {
interp alias "" a+ "" control::no-op
set colour_disabled 1
if {$on} {
if {$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
catch {punk::repl::reset_prompt}
set colour_disabled 0
}
} 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}]
}
@ -1197,6 +1195,9 @@ namespace eval punk::console {
namespace import ansi::cursor_on
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 {
proc titleset {windowtitle} {
if {"windows" eq $::tcl_platform(platform)} {
@ -1243,17 +1244,21 @@ namespace eval punk::console {
return [local::titleget]
}
proc infocmp_test {} {
proc infocmp {} {
set cmd1 [auto_execok infocmp]
if {[string length $cmd1]} {
puts stderr "infocmp seems to be available"
puts stderr ""
return [exec {*}$cmd1]
} 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]
if {[string length $tcmd]} {
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 ";"]
}
#channel?
namespace eval ansi {
proc move {row col} {
puts -nonewline stdout [punk::ansi::move $row $col]
@ -1320,6 +1326,12 @@ namespace eval punk::console {
proc 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.
#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_save_dec
namespace import ansi::cursor_restore_dec
namespace import ansi::scroll_down
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::delete_characters
namespace import ansi::erase_characters

173
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
#[list_end] [comment {--- end definitions namespace punk::lib::compat ---}]
@ -196,6 +244,99 @@ namespace eval punk::lib {
#[para] Core API functions for punk::lib
#[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} {
if {[llength $args] < 1} {
@ -970,11 +1111,12 @@ namespace eval punk::lib {
-block {trimhead1 trimtail1}\
-line {}\
-commandprefix ""\
-ansiresets 0\
-ansiresets auto\
-ansireplays 0\
]
dict for {o v} $arglist {
switch -- $o {
-block - -line - -commandprefix - -ansiresets {}
-block - -line - -commandprefix - -ansiresets - -ansireplays {}
default {
error "linelist: Unrecognized option '$o' usage:$usage"
}
@ -1033,6 +1175,17 @@ namespace eval punk::lib {
# -- --- --- --- --- ---
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 nlsplit [split $text \n]
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
#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?
if {$opt_ansiresets} {
if {$opt_ansireplays} {
package require punk::ansi
set RST [punk::ansi::a]
if {$opt_ansiresets} {
set RST [punk::ansi::a]
} else {
set RST ""
}
set replaycodes $RST ;#todo - default?
set transformed [list]
#shortcircuit common case of no ansi
if {![punk::ansi::ta::detect $linelist]} {
foreach ln $linelist {
lappend transformed $RST$ln$RST
if {$opt_ansiresets} {
foreach ln $linelist {
lappend transformed $RST$ln$RST
}
set linelist $transformed
}
set linelist $transformed
} else {
#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 @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
@ECHO selected_shelltype_trimmed %selected_shelltype_trimmed%
@REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed%
@SET "selected_shellpath=%nextshellpath[win32___________]%"
@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed
@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%" (
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
%selected_shellpath_trimmed% "%~dp0%fname%" %arglist%
SET task_exitcode=!errorlevel!
REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode
%selected_shellpath_trimmed% "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call;
) ELSE (
ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes%
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
set capture [namespace eval $ns {
apply { varnames {
while {"prev_args_[incr n]" in $varnames} {}
while {"prev_args[incr n]" in $varnames} {}
set capturevars [dict create]
set capturearrs [dict create]
foreach fullv $varnames {

2574
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 {} 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
@ -7237,7 +7232,18 @@ namespace eval punk {
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 plum 221-160-221 ;# #DDA0DD
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
variable WEB_colour_map_blue
@ -1422,33 +1422,66 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
return $SGR_map
}
proc colourmap1 {{bgname White}} {
package require textblock
proc colourmap1 {args} {
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 RST [a]
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"]
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
set bg [textblock::block 39 3 "[a+ $bgname] [a]"]
set bg [textblock::block 39 3 "[a+ {*}$fc $bgname] [a]"]
set colourmap ""
set RST [a]
for {set i 8} {$i <= 15} {incr i} {
if {$i == 8} {
set fg "bold white"
} else {
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"]
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
set clist [list]
set fg "black"
@ -1460,7 +1493,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
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]
@ -1470,7 +1503,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#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 fg "bold white"
for {set i 0} {$i <= 15} {incr i} {
@ -1478,11 +1517,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
if {$i > 8} {
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]
}
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
set rows [list]
set row [list]
@ -1500,8 +1545,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} elseif {$i > 6} {
set fg "web-black"
}
#lappend row "[a+ {*}$fg Term-$cname][format %3s $i] $cname "
lappend row "[a+ {*}$fg Term-$i][format %3s $i] $cname "
#lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname "
lappend row "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] $cname "
}
lappend rows $row
foreach r $rows {
@ -1514,7 +1559,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
}
#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 fg "web-black"
for {set i 16} {$i <=231} {incr i} {
@ -1528,14 +1579,22 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} else {
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]
return [string trimleft $out \n]
}
#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 ""
#use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names
variable TERM_colour_map_reverse
@ -1557,7 +1616,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
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
foreach r $rows {
@ -1568,7 +1627,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append out [a]
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 rows [list]
#see https://www.hackitu.de/termcolor256/
@ -1597,7 +1662,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
foreach r $rows {
set rowcells [list]
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
}
@ -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 p8 ""
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 out \n $p8
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 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]
@ -1666,7 +1737,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} else {
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
}
@ -1675,19 +1746,33 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
return $out
}
#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 fg "bold white"
for {set i 232} {$i <= 255} {incr i} {
if {$i > 243} {
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]
}
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
set rows [list]
set row [list]
@ -1703,7 +1788,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
if {$i > 243} {
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
foreach r $rows {
@ -1729,7 +1814,23 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
# $WEB_colour_map_white\
# $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 brown yellow red pink orange purple blue cyan green white gray]
switch -- $groups {
@ -1772,13 +1873,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
} else {
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+ $fg Web-$cname]
#$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec]
$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname]
}
$t configure -frametype {}
$t configure_column 0 -headers [list "[string totitle $g] colours"]
$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]
$t destroy
}
@ -1794,17 +1895,22 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
variable X11_colour_map_diff
variable WEB_colour_map
set defaults [dict create\
-forcecolour 0\
-return "string"\
]
dict for {k v} $args {
switch -- $k {
-return {}
-return - -forcecolour {}
default {
error "colourtable_x11diff 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 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] {
$t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec]
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_column 0 -headers [list "X11"]
$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]
$t destroy
# -- --- ---
@ -1835,12 +1941,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
dict for {cname cdec} [set WEB_map_subset] {
$t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec]
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_column 0 -headers [list "Web"]
$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]
$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
variable SGR_setting_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]} {
set out ""
set indent " "
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 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"
@ -1876,8 +1990,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
append out "${indent}$underdashed" \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}punk::ansi tries to keep them in separate escape sequences even during merge operations to avoid this" \n
append out "[a+ web-white]Standard SGR colours and attributes $RST" \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 "${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 strmap [list]
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 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
set bgname "White"
set map1 [colourmap1 $bgname]
set map1 [overtype::centre -transparent 1 $map1 "[a black $bgname]Standard colours[a]"]
set map2 [colourmap2 $bgname]
set map2 [overtype::centre -transparent 1 $map2 "[a black $bgname]High-intensity colours[a]"]
set bgname "Web-white"
set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour]
set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"]
set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour]
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 "[a+ 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 "[a+ web-white]24 Greyscale colours[a]" \n
append out [textblock::join $indent [colourblock_24]] \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 -forcecolour $opt_forcecolour]] \n
append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n
append out [textblock::join $indent [colourblock_24 -forcecolour $opt_forcecolour]] \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-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+ term-lightsteelblue Term-gold1]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+ {*}$fc 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 "[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
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#C71585\]text\[a] -> [a+ Rgb#C71585]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+ {*}$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 \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 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 \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 "[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
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} {
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"
append out [colourtable_16_names] \n
append out [colourtable_16_names -forcecolour $opt_forcecolour] \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 [colourtable_24_names]
append out [colourtable_24_names -forcecolour $opt_forcecolour]
foreach ta $termargs {
switch -- $ta {
pastel {
append out \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 {
append out \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
}
web {
return [colourtable_web [lrange $args 1 end]]
return [colourtable_web -forcecolour $opt_forcecolour -groups [lrange $args 1 end]]
}
x11 {
set out ""
append out " Mostly same as web - known differences displayed" \n
append out [colourtable_x11diff]
append out [colourtable_x11diff -forcecolour $opt_forcecolour]
return $out
}
}
@ -1997,7 +2121,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
set resultlist [list]
foreach i $args {
set f4 [string range $i 0 3]
set s [a+ $i]sample
set s [a+ {*}$fc $i]sample
switch -- $f4 {
web- - Web- - WEB- {
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 {
$t add_row [list $i extended $s [ansistring VIEW $s]]
}
underline {
$t add_row [list $i "SGR 4" $s [ansistring VIEW $s]]
}
default {
$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 merged [punk::ansi::codetype::sgr_merge_singles [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)
variable sgr_cache
if {[dict exists $sgr_cache a+$args]} {
return [dict get $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
if {[dict exists $sgr_cache $cache_key]} {
return [dict get $sgr_cache $cache_key]
}
#don't disable ansi here.
@ -2196,6 +2324,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
variable WEB_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 e [list] ;#extended codes needing to go in own escape sequence
foreach i $args {
@ -2250,6 +2392,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
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 {
lappend e 4:1
}
@ -2265,10 +2412,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
underdashed {
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}
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}
nost {lappend t 29 ;#nostrike}
ital {lappend t 3 ;#italic}
@ -2451,6 +2605,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
default {
if {[string is integer -strict $i] || [string first ";" $i] > 0} {
lappend t $i
} elseif {[string first : $i] > 0} {
lappend e $i
} else {
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
if {![llength $t]} {
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"
}
}
dict set sgr_cache a+$args $result
dict set sgr_cache $cache_key $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
variable sgr_cache
if {[dict exists $sgr_cache a_$args]} {
return [dict get $sgr_cache a_$args]
set cache_key a_$args
if {[dict exists $sgr_cache $cache_key]} {
return [dict get $sgr_cache $cache_key]
}
#don't disable ansi here.
@ -2498,6 +2681,19 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
variable WEB_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 e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence
foreach i $args {
@ -2549,6 +2745,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
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 {
lappend e 4:1
}
@ -2564,10 +2765,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
underdashed {
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}
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}
nost {lappend t 29 ;#nostrike}
ital {lappend t 3 ;#italic}
@ -2750,6 +2958,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
default {
if {[string is integer -strict $i] || [string first ";" $i] > 0} {
lappend t $i
} elseif {[string first : $i] > 0} {
lappend e $i
} else {
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
# 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[unset t] 0 0]
if {[![llength $e]]} {
if {![llength $e]} {
set result "\x1b\[[join $t {;}]m"
} else {
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
}
@ -3400,10 +3632,15 @@ namespace eval punk::ansi {
dict set codestate_empty italic "" ;#3 on 23 off
dict set codestate_empty underline "" ;#4 on 24 off
#nonstandard 4:3,4:4,4:5
dict set codestate_empty curlyunderline ""
dict set codestate_empty dottedunderline ""
dict set codestate_empty dashedunderline ""
#nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5
#4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions
#The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines
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 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 font "" ;#10, 11-19 10 being primary
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 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_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)
# -- mintty?
@ -3556,26 +3793,24 @@ namespace eval punk::ansi {
} else {
switch -- [lindex $paramsplit 1] {
0 {
#no underline
dict set codestate underline 24
dict set codestate curlyunderline ""
dict set codestate dottedunderline ""
dict set codestate dashedunderline ""
#no *extended* underline
#dict set codestate underline 24
dict set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended
}
1 {
dict set codestate underline 4 ;#straight underline
dict set codestate underextended 4:1
}
2 {
dict set codestate doubleunderline 21
dict set codestate underextended 4:2
}
3 {
dict set codestate curlyunderline "4:3"
dict set codestate underextended "4:3"
}
4 {
dict set codestate dottedunderline "4:4"
dict set codestate underextended "4:4"
}
5 {
dict set codestate dashedunderline "4:5"
dict set codestate underextended "4:5"
}
}
@ -3614,9 +3849,7 @@ namespace eval punk::ansi {
}
24 {
dict set codestate underline 24 ;#off
dict set codestate curlyunderline ""
dict set codestate dottedunderline ""
dict set codestate dashedunderline ""
dict set codestate underextended "4:0" ;#review
}
25 {
dict set codestate blink 25 ;#off
@ -3806,7 +4039,7 @@ namespace eval punk::ansi {
append codemerge "${v}\;"
}
}
underlinecolour - curlyunderline - dashedunderline - dottedunderline {
underlinecolour - underextended {
append unmergeable "${v}\;"
}
default {
@ -3822,7 +4055,7 @@ namespace eval punk::ansi {
"" {}
default {
switch -- $k {
underlinecolour - curlyunderline - dashedunderline - dottedunderline {
underlinecolour - underextended {
append unmergeable "${v}\;"
}
default {

72
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
#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} {
#stdout
variable colour_disabled
variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} {
if {$ansi_wanted <= 0} {
puts -nonewline [punk::ansi::stripansi [::punk::ansi::a?]]
} else {
tailcall ansi::a? {*}$args
@ -805,9 +786,8 @@ namespace eval punk::console {
}
proc code_a+ {args} {
variable colour_disabled
variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} {
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
@ -815,24 +795,27 @@ namespace eval punk::console {
::punk::ansi::a+ {*}$args
}
proc code_a {args} {
variable colour_disabled
variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} {
if {$ansi_wanted <= 0} {
return
}
#tailcall punk::ansi::a {*}$args
::punk::ansi::a {*}$args
}
proc code_a? {args} {
variable colour_disabled
variable ansi_wanted
if {$colour_disabled || $ansi_wanted <= 0} {
if {$ansi_wanted <= 0} {
return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]]
} else {
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 {}}} {
variable ansi_wanted
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}]
}
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
if {[string length $onoff]} {
set onoff [string tolower $onoff]
if {$on ne ""} {
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
if {$onoff in [list 1 on true yes]} {
interp alias "" a+ "" punk::console::code_a+
set colour_disabled 0
} elseif {$onoff in [list 0 off false no]} {
interp alias "" a+ "" control::no-op
set colour_disabled 1
if {$on} {
if {$colour_disabled} {
#change of state
punk::ansi::sgr_cache clear
catch {punk::repl::reset_prompt}
set colour_disabled 0
}
} 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}]
}
@ -1253,7 +1247,7 @@ namespace eval punk::console {
proc infocmp {} {
set cmd1 [auto_execok infocmp]
if {[string length $cmd1]} {
puts stderr "Using infocmp executable"
puts stderr ""
return [exec {*}$cmd1]
} else {
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 @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
@ECHO selected_shelltype_trimmed %selected_shelltype_trimmed%
@REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed%
@SET "selected_shellpath=%nextshellpath[win32___________]%"
@CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed
@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%" (
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
%selected_shellpath_trimmed% "%~dp0%fname%" %arglist%
SET task_exitcode=!errorlevel!
REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode
%selected_shellpath_trimmed% "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call;
) ELSE (
ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes%
SET task_exitcode=66

473
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 {
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]
@ -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
#(this is an example of a deaddrop)
variable post_script
variable signal_control_c 0
}
namespace eval punk::repl {
variable debug_repl 0
variable signal_control_c 0
variable signal_control_c_msg ""
proc todo {} {
puts "tcl History"
@ -100,7 +101,7 @@ namespace eval punk::repl {
#todo - make optional/configurable?
proc bgerror2 {args} {
puts stderr "===================="
puts stderr "repl::bgerror"
puts stderr "punk::repl::bgerror"
puts stderr "===================="
puts stderr "[lindex $args 0]"
puts stderr "-------------------"
@ -124,79 +125,107 @@ namespace eval punk::repl {
}
if {![llength [info commands ::bgerror]]} {
#interp alias {} bgerror {} ::repl::bgerror
#interp alias {} bgerror {} ::punk::repl::bgerror
}
interp bgerror "" ::punk::repl::bgerror
}
namespace eval repl {
}
namespace eval ::repl::term {
}
package require term::ansi::code::ctrl
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==========="
#zzzload::pkg_wait twapi
if {![catch {package require twapi}]} {
#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.
#This is done from within the launching batch file
proc ::punk::repl::handler_console_control {args} {
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"
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
#puts stderr "signal ctrl-c while in raw mode"
#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
punk::mode line
return 0
}
if {![catch {package require twapi}]} {
return 1
#after 200 {exit 42} ;#temp
#return 42
}
}
proc ::repl::term::handler_console_control {args} {
#puts -nonewline stdout .
#flush stdout
incr ::repl::signal_control_c
#rputs stderr "* console_control: $args"
if {$::punk::console::is_raw} {
#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"
after 200 {exit 42} ;#temp
flush stderr
return 42
}
#note - returning 0 means pass event to other handlers including OS default handler
if {$::repl::signal_control_c <= 2} {
set remaining [expr {3 - $::repl::signal_control_c}]
puts stderr "signal ctrl-c (perform $remaining more to quit, enter to return to repl)"
flush stderr
return 1
} elseif {$::repl::signal_control_c == 3} {
puts stderr "signal ctrl-c x3 received - quitting"
flush stderr
after 25
quit
return 1
} elseif {$::repl::signal_control_c == 4} {
puts stderr "signal ctrl-c x4 received - one more to hard exit"
flush stderr
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
}
#note - returning 0 means pass event to other handlers including OS default handler
if {$signal_control_c <= 2} {
set remaining [expr {3 - $signal_control_c}]
puts stderr "signal ctrl-c (perform $remaining more to quit, enter to return to repl)"
flush stderr
return 1
} elseif {$signal_control_c == 3} {
puts stderr "signal ctrl-c x3 received - quitting."
flush stderr
after 25
quit
return 1
} elseif {$signal_control_c == 4} {
puts stderr "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
puts stderr "signal ctrl-c x5 received - hard exit"
flush stderr
after 25
exit 499 ;# HTTP 'client closed request' - just for the hell of it.
} else {
puts stderr "signal ctrl-c $signal_control_c received"
flush stderr
#return 0 to fall through to default handler
return 0
}
}
default {
puts stderr "unhandled console signal $args"
return 1
} elseif {$::repl::signal_control_c >= 5} {
#a script that allows events to be processed could still be running
puts stderr "signal ctrl-c x5 received - hard exit"
flush stderr
after 25
exit 499 ;# HTTP 'client closed request' - just for the hell of it.
} else {
puts stderr "signal ctrl-c $::repl::signal_control_c received"
flush stderr
#return 0 to fall through to default handler
return 0
}
}
twapi::set_console_control_handler ::repl::term::handler_console_control
#we can't yet emit from an event with proper prompt handling -
#repl::rputs stdout "twapi loaded"
} else {
#repl::rputs stderr " Failed to load twapi"
}
}]
twapi::set_console_control_handler ::punk::repl::handler_console_control
#we can't yet emit from an event with proper prompt handling -
#repl::rputs stdout "twapi loaded"
} else {
#repl::rputs stderr " Failed to load twapi"
}
} else {
#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}
#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
@ -379,90 +408,24 @@ proc ::unknown args {
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 ] \
# -- --- --- --- ---
set idlist_stdout [list]
set idlist_stderr [list]
set shellrun::runout ""
#when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}]
#lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}]
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 \
[list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -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"
@ -472,57 +435,37 @@ proc ::unknown args {
set ::tcl::UnknownResult ""
}
} else {
set idlist_stdout [list]
set idlist_stderr [list]
set shellrun::runout ""
#when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks
#lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}]
#lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}]
if {![dict get $::punk::config::running exec_unknown]} {
uplevel 1 [list ::catch \
[list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle punk -inbuffering line -outbuffering none ] \
::tcl::UnknownResult ::tcl::UnknownOptions]
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 ""
}
set ::punk::last_run_display [list]
set redir ">&@stdout <@stdin"
uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions]
#we can't detect stdout/stderr output from the exec
#for now emit an extra \n on stderr
#todo - there is probably no way around this but to somehow exec in the context of a completely separate console
#This is probably a tricky problem - especially to do cross-platform
#
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit
if {[dict get $::tcl::UnknownOptions -code] == 0} {
set c green
set m "ok"
} else {
set ::punk::last_run_display [list]
set redir ">&@stdout <@stdin"
uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions]
#we can't detect stdout/stderr output from the exec
#for now emit an extra \n on stderr
#todo - use console apis (twapi on windows) to detect cursor posn?
#
# - use [dict get $::tcl::UnknownOptions -code] (0|1) exit
if {[dict get $::tcl::UnknownOptions -code] == 0} {
set c green
set m "ok"
} else {
set c yellow
set m "errorCode $::errorCode"
}
set chunklist [list]
lappend chunklist [list "info" "[a $c]$m[a] " ]
set ::punk::last_run_display $chunklist
set c yellow
set m "errorCode $::errorCode"
}
set chunklist [list]
lappend chunklist [list "info" "[a $c]$m[a] " ]
set ::punk::last_run_display $chunklist
foreach id $idlist_stdout {
shellfilter::stack::remove stdout $id
}
foreach id $idlist_stderr {
shellfilter::stack::remove stderr $id
}
}
foreach id $idlist_stdout {
shellfilter::stack::remove stdout $id
}
foreach id $idlist_stderr {
shellfilter::stack::remove stderr $id
}
# -- --- --- --- ---
#uplevel 1 [list ::catch \
# [concat exec $redir $new [lrange $args 1 end]] \
@ -573,6 +516,7 @@ proc ::unknown args {
}
}
}
#punk - disable prefix match search
set default_cmd_search 0
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
set prompt_reset_flag 1
}
#todo - review
proc repl::term::reset {} {
#aliases c and clear to this by ::punk
proc punk::repl::reset_terminal {} {
set prompt_reset_flag 1
#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 {} {
@ -630,6 +574,7 @@ proc repl::get_prompt_config {} {
return [list resultprompt $resultprompt nlprompt $nlprompt infoprompt $infoprompt debugprompt $debugprompt]
}
proc repl::start {inchan args} {
#puts stderr "-->repl::start $inchan $args"
variable commandstr
variable readingchunk
@ -647,6 +592,7 @@ proc repl::start {inchan args} {
variable startinstance
variable loopinstance
if {[namespace exists ::punkapp]} {
#review - document ?
if {[dict exists $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]
}
vwait [namespace current]::done
#puts stderr "-->start done = $::repl::done"
#todo - override exit?
#after 0 ::repl::post_operations
after idle ::repl::post_operations
vwait repl::post_operations_done
#puts stderr "-->start post_operations_done = $::repl::post_operations_done"
if {[namespace exists ::punkapp]} {
#todo check and get punkapp::result array - but what key?
if {[info exists ::punkapp::result(shell)]} {
@ -696,6 +644,7 @@ proc repl::start {inchan args} {
return $temp
}
}
punk::mode line
return 0
}
proc repl::post_operations {} {
@ -730,18 +679,21 @@ proc repl::reopen_stdin {} {
twapi::SetStdHandle -10 $h
}
puts stderr "restarting repl on inputchannel:$s"
return [repl::start $s]
return [repl::start $s -title "reopen_stdin a"]
} else {
#/dev/tty - reference to the controlling terminal for a process
#review/test
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 {} {
set ::repl::done "quit"
#puts stderr "quit called"
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"} {
#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 ::repl::signal_control_c 0
set preverr [string map [list "child killed" "child_killed"] $::errorInfo]
catch {error $preverr} ;#for errorInfo display
} else {
set ::repl::signal_control_c 0
fileevent $inputchan readable {}
set reading 0
set running 0
proc ::punk::repl::repl_handler_checkchannel {inputchan} {
if {[catch {chan eof $inputchan} is_eof]} {
::repl::rputs stderr "\n|repl> repl_handler_checkchannel error on $inputchan. (closed?) msg:$is_eof"
} else {
if {$is_eof} {
if {$::tcl_interactive} {
::repl::rputs stderr "\n|repl> repl_handler_checkchannel EOF on $inputchan."
}
}
}
}
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} {
rputs stderr "\n|repl> EOF on $inputchan."
puts stderr "rawmode signal ctrl-c x3 received - quitting"
flush stderr
}
set [namespace current]::done 1
after 1 [list repl::reopen_stdin]
#tailcall repl::reopen_stdin
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} {
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?
@ -1502,8 +1502,16 @@ proc repl::repl_handler_restorechannel {inputchan previous_input_state} {
return [chan conf $inputchan]
}
proc repl::repl_handler {inputchan prompt_config} {
# -- review
variable in_repl_handler
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 {}
upvar ::punk::console::input_chunks_waiting input_chunks_waiting
@ -1593,7 +1601,8 @@ proc repl::repl_handler {inputchan prompt_config} {
}
} else {
repl_handler_checkchannel $inputchan
punk::repl::repl_handler_checkchannel $inputchan
punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan
# -- --- ---
#set chunksize [gets $inputchan chunk]
# -- --- ---
@ -1628,7 +1637,9 @@ proc repl::repl_handler {inputchan prompt_config} {
} 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"} {
chan configure $inputchan -blocking 0
chan configure $inputchan -translation lf
@ -1663,21 +1674,30 @@ proc repl::repl_handler {inputchan prompt_config} {
}
####################################################
} 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]
}
proc repl::editbuf {index args} {
variable editbuf_list
set editbuf [lindex $editbuf_list $index]
proc punk::repl::editbuf {index args} {
set editbuf [lindex $::repl::editbuf_list $index]
if {$editbuf ne ""} {
$editbuf {*}$args
} else {
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} {
variable loopinstance
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
#ctrl-c
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"
}
#for now - exit with small delay for tidyup
#ctrl-z
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
after 1000 exit
return
@ -2483,8 +2503,8 @@ proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} {
} else {
#append commandstr \n
if {$::repl::signal_control_c} {
set ::repl::signal_control_c 0
if {$::punk::repl::signal_control_c} {
set ::punk::repl::signal_control_c 0
fileevent $inputchan readable {}
rputs stderr "* console_control: control-c"
flush stderr
@ -2579,8 +2599,7 @@ package provide punk::repl [namespace eval punk::repl {
set version 0.1
}]
#repl::start stdin
#exit 0
#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 {
set e $::shellrun::runerr
}
#append chunk "[a+ red light]$e$RST\n"
append chunk "[a+ red light]$e$RST"
#append chunk "[a+ red normal]$e$RST\n"
append chunk "[a+ red normal]$e$RST"
}
lappend chunklist [list stderr $chunk]
@ -391,7 +391,7 @@ namespace eval shellrun {
} else {
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]

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

@ -3254,10 +3254,11 @@ namespace eval textblock {
set defaults [dict create\
-return "string"\
-compact 1\
-forcecolour 0\
]
dict for {k v} $args {
switch -- $k {
-return - -compact {}
-return - -compact - -forcecolour {}
default {
"textblock::periodic unknown option '$k'. Known options: [dict keys $defaults]"
}
@ -3265,6 +3266,11 @@ namespace eval textblock {
}
set opts [dict merge $defaults $args]
set opt_return [dict get $opts -return]
if {[dict get $opts -forcecolour]} {
set fc forcecolour
} else {
set fc ""
}
#examples ptable.com
set elements [list\
@ -3285,61 +3291,61 @@ namespace eval textblock {
set ecat [dict create]
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 {
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 ansi [a+ Web-lightgreen web-black]
set ansi [a+ {*}$fc Web-lightgreen web-black]
foreach e $cat_reactive_nonmetal {
dict set ecat $e [list ansi $ansi cat reactive_nonmetal]
}
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 {
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 ansi [a+ Web-lightsalmon web-black]
set ansi [a+ {*}$fc Web-lightsalmon web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat transition_metals]
}
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 {
dict set ecat $e [list ansi $ansi cat post_transition_metals]
}
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 {
dict set ecat $e [list ansi $ansi cat metalloids]
}
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 {
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 ansi [a+ Web-plum web-black]
set ansi [a+ {*}$fc Web-plum web-black]
foreach e $cat {
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 ansi [a+ Web-tan web-black]
set ansi [a+ {*}$fc Web-tan web-black]
foreach e $cat {
dict set ecat $e [list ansi $ansi cat lanthanoids]
}
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 {
dict set ecat $e [list ansi $ansi cat other]
}
@ -3379,14 +3385,14 @@ namespace eval textblock {
if {$opt_return eq "string"} {
$t configure -frametype_header light
$t configure -ansiborder_header [a+ web-white]
$t configure -ansibase_header [a+ Web-black]
$t configure -ansibase_body [a+ Web-black]
$t configure -ansiborder_body [a+ web-black]
$t configure -ansiborder_header [a+ {*}$fc web-white]
$t configure -ansibase_header [a+ {*}$fc Web-black]
$t configure -ansibase_body [a+ {*}$fc Web-black]
$t configure -ansiborder_body [a+ {*}$fc web-black]
$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 $t
@ -4247,14 +4253,31 @@ namespace eval textblock {
# >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {|
# >} 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 pright [>punk . lhs]
set prightair [>punk . lhs_air]
set red [a+ red]; set redb [a+ red bold]
set green [a+ green]; set greenb [a+ green bold]
set cyan [a+ cyan];set cyanb [a+ cyan bold]
set blue [a+ blue];set blueb [a+ blue bold]
set red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold]
set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold]
set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold]
set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold]
set RST [a]
set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz]
set punks [textblock::join $pleft $pright]
@ -4274,7 +4297,7 @@ namespace eval textblock {
set spantable [[spantest] print]
append out [textblock::join $fancy " " $spantable] \n
#append out [textblock::frame -title gr $gr0]
append out [textblock::periodic]
append out [textblock::periodic -forcecolour $opt_forcecolour]
return $out
}

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

@ -18,6 +18,7 @@
## Requirements
##e.g package require frobz
package require uri ;#tcllib
package require punk::lib
#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
}
#this
#
proc convertFromUrl {fileuri} {
if {[string match "file:/*" $fileuri]} {
set finfo [uri::split $fileuri]
@ -136,6 +137,7 @@ namespace eval winlibreoffice {
set dt [get_desktop]
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]"
#title can be set with [$doc settitle "titletext"]
return $doc
}
@ -160,6 +162,7 @@ namespace eval winlibreoffice {
set sheets [$doc getSheets]
set s [$sheets getByIndex $idx]
puts stdout "Sheet: [$s getName]"
#set name with [$s setName "xxx"]
return $s
}
proc calcsheet_cell_range_by_name {sheet rangename} {
@ -175,8 +178,42 @@ namespace eval winlibreoffice {
$cell setPropertyValue {*}$propset
#e.g "NumberFormat" 49
# 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
#return libreoffice date in days since 1899..
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
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
} else {
package require app-punk
repl::start stdin
#app-punk starts repl
#repl::start stdin -title "main.tcl"
}

Loading…
Cancel
Save