You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
1915 lines
84 KiB
1915 lines
84 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::console 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::console 0 999999.0a1.0] |
|
#[copyright "2024"] |
|
#[titledesc {punk console}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {punk console}] [comment {-- Description at end of page heading --}] |
|
#[require punk::console] |
|
#[keywords module console terminal] |
|
#[description] |
|
#[para] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::console |
|
#[subsection Concepts] |
|
#[para] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::console |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
package require punk::ansi |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6-}] |
|
#[item] [package {punk::ansi}] |
|
|
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
|
|
|
|
#if {"windows" eq $::tcl_platform(platform)} { |
|
# #package require zzzload |
|
# #zzzload::pkg_require twapi |
|
#} |
|
|
|
#see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt |
|
#https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval punk::console { |
|
#*** !doctools |
|
#[subsection {Namespace punk::console}] |
|
#[para] |
|
|
|
#*** !doctools |
|
#[list_begin definitions] |
|
|
|
variable tabwidth 8 ;#default only - will attempt to detect and set to that configured in terminal |
|
#Note that windows terminal cooked mode seems to use 8 for interactive use even if set differently |
|
#e.g typing tab characters may still be echoed 8-spaced while writing to stdout my obey the terminal's tab stops. |
|
variable has_twapi 0 |
|
variable previous_stty_state_stdin "" |
|
variable previous_stty_state_stdout "" |
|
variable previous_stty_state_stderr "" |
|
variable is_raw 0 |
|
variable input_chunks_waiting |
|
if {![info exists input_chunks_waiting(stdin)]} { |
|
set input_chunks_waiting(stdin) [list] |
|
} |
|
variable ansi_response_chunk ;#array keyed on callid |
|
variable ansi_response_wait ;#array keyed on callid |
|
variable ansi_response_queue ;#list of callids |
|
variable ansi_response_queuedata ;#dict keyed on callid - with function params |
|
|
|
# -- |
|
variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run. |
|
#-1 still evaluates to true - as the modern assumption for ansi availability is true |
|
#only false if ansi_available has been set 0 by test_can_ansi |
|
#support ansistrip for legacy windows terminals |
|
# -- |
|
|
|
variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset |
|
|
|
#punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace |
|
#directly acting means they write to stdout to cause the console to peform the action, or they perform the action immediately via other means. |
|
#punk::console::ansi contains a subset of punk::ansi, but with emission to stdout as opposed to simply returning the ansi sequence. |
|
#punk::console::local functions are used by punk::console commands when there is no ansi equivalent |
|
#ansi escape sequences are possibly preferable esp if terminal is remote to process running punk::console |
|
# punk::local commands may be more performant in some circumstances where console is directly attached, but it shouldn't be assumed. e.g ansi::titleset outperforms local::titleset on windows with twapi. |
|
|
|
namespace eval ansi { |
|
#ansi escape sequence based terminal/console control functions |
|
namespace export * |
|
} |
|
namespace eval local { |
|
#non-ansi terminal/console control functions |
|
#e.g external utils system API's. |
|
namespace export * |
|
} |
|
|
|
if {"windows" eq $::tcl_platform(platform)} { |
|
#accept args for all dummy/load functions so we don't have to match/update argument signatures here |
|
|
|
proc enableAnsi {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall enableAnsi {*}$args |
|
} |
|
#review what raw mode means with regard to a specific channel vs terminal as a whole |
|
proc enableRaw {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall enableRaw {*}$args |
|
} |
|
proc disableRaw {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall disableRaw {*}$args |
|
} |
|
proc enableVirtualTerminal {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall enableVirtualTerminal {*}$args |
|
} |
|
proc disableVirtualTerminal {args} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall disableVirtualTerminal {*}$args |
|
} |
|
set funcs [list disableAnsi enableProcessedInput disableProcessedInput] |
|
foreach f $funcs { |
|
proc $f {args} [string map [list %f% $f] { |
|
set mybody [info body %f%] |
|
internal::define_windows_procs |
|
set newbody [info body %f%] |
|
if {$newbody ne $mybody} { |
|
tailcall %f% {*}$args |
|
} else { |
|
#error vs noop? |
|
puts stderr "Unable to set implementation for %f% - check twapi?" |
|
} |
|
}] |
|
} |
|
|
|
} else { |
|
proc enableAnsi {} { |
|
#todo? |
|
} |
|
proc disableAnsi {} { |
|
|
|
} |
|
|
|
#todo - something better - the 'channel' concept may not really apply on unix, as raw mode is for input and output modes |
|
proc enableRaw {{channel stdin}} { |
|
variable is_raw |
|
variable previous_stty_state_$channel |
|
set sttycmd [auto_execok stty] |
|
if {[set previous_stty_state_$channel] eq ""} { |
|
if {[catch {{*}$sttycmd -g <@$channel} previous_stty_state_$channel]} { |
|
set previous_stty_state_$channel "" |
|
} |
|
} |
|
|
|
exec {*}$sttycmd raw -echo <@$channel |
|
set is_raw 1 |
|
return [dict create previous [set previous_stty_state_$channel]] |
|
} |
|
proc disableRaw {{channel stdin}} { |
|
variable is_raw |
|
variable previous_stty_state_$channel |
|
set sttycmd [auto_execok stty] |
|
if {[set previous_stty_state_$channel] ne ""} { |
|
exec {*}$sttycmd [set previous_stty_state_$channel] |
|
set previous_stty_state_$channel "" |
|
set is_raw 0 |
|
return restored |
|
} |
|
exec {*}$sttycmd -raw echo <@$channel |
|
set is_raw 0 |
|
return done |
|
} |
|
proc enableVirtualTerminal {{channels {input output}}} { |
|
|
|
} |
|
proc disableVirtualTerminal {args} { |
|
|
|
} |
|
} |
|
|
|
#review - document and decide granularity required. should we enable/disable more than one at once? |
|
proc enable_mouse {} { |
|
puts -nonewline stdout \x1b\[?1000h |
|
puts -nonewline stdout \x1b\[?1003h |
|
puts -nonewline stdout \x1b\[?1015h |
|
puts -nonewline stdout \x1b\[?1006h |
|
flush stdout |
|
} |
|
proc disable_mouse {} { |
|
puts -nonewline stdout \x1b\[?1000l |
|
puts -nonewline stdout \x1b\[?1003l |
|
puts -nonewline stdout \x1b\[?1015l |
|
puts -nonewline stdout \x1b\[?1006l |
|
flush stdout |
|
} |
|
proc enable_bracketed_paste {} { |
|
puts -nonewline stdout \x1b\[?2004h |
|
} |
|
proc disable_bracketed_paste {} { |
|
puts -nonewline stdout \x1b\[?2004l |
|
} |
|
proc start_application_mode {} { |
|
#need loop to read events? |
|
puts -nonewline stdout \x1b\[?1049h ;#alt screen |
|
enable_mouse |
|
#puts -nonewline stdout \x1b\[?25l ;#hide cursor |
|
puts -nonewline stdout \x1b\[?1003h\n |
|
enable_bracketed_paste |
|
|
|
} |
|
proc mode {{raw_or_line query}} { |
|
variable is_raw |
|
variable ansi_available |
|
set raw_or_line [string tolower $raw_or_line] |
|
if {$raw_or_line eq "query"} { |
|
if {$is_raw} { |
|
return "raw" |
|
} else { |
|
return "line" |
|
} |
|
} elseif {$raw_or_line eq "raw"} { |
|
if {[catch { |
|
punk::console::enableRaw |
|
} errM]} { |
|
puts stderr "Warning punk::console::enableRaw failed - $errM" |
|
} |
|
if {[can_ansi]} { |
|
punk::console::enableVirtualTerminal both |
|
} |
|
} elseif {$raw_or_line eq "line"} { |
|
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) |
|
if {[catch { |
|
punk::console::disableRaw |
|
} errM]} { |
|
puts stderr "Warning punk::console::disableRaw failed - $errM" |
|
} |
|
if {[can_ansi]} { |
|
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc |
|
punk::console::enableVirtualTerminal output ;#display/use ansi codes |
|
} |
|
} else { |
|
error "punk::console::mode expected 'raw' or 'line' or default value 'query'" |
|
} |
|
} |
|
|
|
namespace eval internal { |
|
proc abort_if_loop {{failmsg ""}} { |
|
#puts "il1 [info level 1]" |
|
#puts "thisproc: [lindex [info level 0] 0]" |
|
set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}] |
|
#puts "would_loop: $would_loop" |
|
if {$would_loop} { |
|
set procname [uplevel 1 {namespace tail [lindex [info level 0] 0]}] |
|
if {$failmsg eq ""} { |
|
set errmsg "[namespace current] Failed to redefine procedure $procname" |
|
} else { |
|
set errmsg $failmsg |
|
} |
|
error $errmsg |
|
} |
|
} |
|
proc define_windows_procs {} { |
|
package require zzzload |
|
set loadstate [zzzload::pkg_require twapi] |
|
|
|
#loadstate could also be stuck on loading? - review - zzzload not very ripe |
|
#Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues. |
|
if {$loadstate ni [list failed]} { |
|
#possibly still 'loading' |
|
#review zzzload usage |
|
#puts stdout "=========== console loading twapi =============" |
|
set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait |
|
} |
|
|
|
if {$loadstate ni [list failed]} { |
|
package require twapi ;#should be fast once twapi dll loaded in zzzload thread |
|
set ::punk::console::has_twapi 1 |
|
|
|
#todo - move some of these to the punk::console::local sub-namespace - as they use APIs rather than in-band ANSI to do their work. |
|
#enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't. |
|
#Find a compromise to organise things somewhat sensibly.. |
|
|
|
#this is really enableAnsi *processing* |
|
proc [namespace parent]::enableAnsi {} { |
|
#output handle modes |
|
#Enable virtual terminal processing (sometimes off in older windows terminals) |
|
#ENABLE_PROCESSED_OUTPUT = 0x0001 |
|
#ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002 |
|
#ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 |
|
#DISABLE_NEWLINE_AUTO_RETURN = 0x0008 |
|
set h_out [twapi::get_console_handle stdout] |
|
set oldmode_out [twapi::GetConsoleMode $h_out] |
|
set newmode_out [expr {$oldmode_out | 4}] ;#don't enable processed output too, even though it's required. keep symmetrical with disableAnsi? |
|
|
|
twapi::SetConsoleMode $h_out $newmode_out |
|
|
|
#what does window_input have to do with it?? |
|
#input handle modes |
|
#ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal |
|
#ENABLE_LINE_INPUT 0x0002 |
|
#ENABLE_ECHO_INPUT 0x0004 |
|
#ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) |
|
#ENABLE_MOUSE_INPUT 0x0010 |
|
#ENABLE_INSERT_MODE 0X0020 |
|
#ENABLE_QUICK_EDIT_MODE 0x0040 |
|
#ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512) |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in | 8}] |
|
#set newmode_in [expr {$oldmode_in | 0x208}] |
|
|
|
twapi::SetConsoleMode $h_in $newmode_in |
|
|
|
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] |
|
} |
|
proc [namespace parent]::disableAnsi {} { |
|
set h_out [twapi::get_console_handle stdout] |
|
set oldmode_out [twapi::GetConsoleMode $h_out] |
|
set newmode_out [expr {$oldmode_out & ~4}] |
|
twapi::SetConsoleMode $h_out $newmode_out |
|
|
|
#??? review |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in & ~8}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
|
|
|
|
return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] |
|
} |
|
|
|
# |
|
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} { |
|
set ins [list in input stdin] |
|
set outs [list out output stdout stderr] |
|
set known [concat $ins $outs both] |
|
set directions [list] |
|
foreach v $channels { |
|
if {$v in $ins} { |
|
lappend directions input |
|
} elseif {$v in $outs} { |
|
lappend directions output |
|
} elseif {$v eq "both"} { |
|
lappend directions input output |
|
} |
|
if {$v ni $known} { |
|
error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" |
|
} |
|
} |
|
set channels $directions ;#don't worry about dups. |
|
if {"both" in $channels} { |
|
lappend channels input output |
|
} |
|
set result [dict create] |
|
if {"output" in $channels} { |
|
#note setting stdout makes stderr have the same settings - ie there is really only one output to configure |
|
set h_out [twapi::get_console_handle stdout] |
|
set oldmode [twapi::GetConsoleMode $h_out] |
|
set newmode [expr {$oldmode | 4}] |
|
twapi::SetConsoleMode $h_out $newmode |
|
dict set result output [list from $oldmode to $newmode] |
|
} |
|
|
|
if {"input" in $channels} { |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in | 0x200}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
dict set result input [list from $oldmode_in to $newmode_in] |
|
} |
|
|
|
return $result |
|
} |
|
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { |
|
set ins [list in input stdin] |
|
set outs [list out output stdout stderr] |
|
set known [concat $ins $outs both] |
|
set directions [list] |
|
foreach v $channels { |
|
if {$v in $ins} { |
|
lappend directions input |
|
} elseif {$v in $outs} { |
|
lappend directions output |
|
} elseif {$v eq "both"} { |
|
lappend directions input output |
|
} |
|
if {$v ni $known} { |
|
error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" |
|
} |
|
} |
|
set channels $directions ;#don't worry about dups. |
|
if {"both" in $channels} { |
|
lappend channels input output |
|
} |
|
set result [dict create] |
|
if {"output" in $channels} { |
|
#as above - configuring stdout does stderr too |
|
set h_out [twapi::get_console_handle stdout] |
|
set oldmode [twapi::GetConsoleMode $h_out] |
|
set newmode [expr {$oldmode & ~4}] |
|
twapi::SetConsoleMode $h_out $newmode |
|
dict set result output [list from $oldmode to $newmode] |
|
} |
|
if {"input" in $channels} { |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in & ~0x200}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
dict set result input [list from $oldmode_in to $newmode_in] |
|
} |
|
|
|
#return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] |
|
return $result |
|
} |
|
|
|
proc [namespace parent]::enableProcessedInput {} { |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in | 1}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
return [list stdin [list from $oldmode_in to $newmode_in]] |
|
} |
|
proc [namespace parent]::disableProcessedInput {} { |
|
set h_in [twapi::get_console_handle stdin] |
|
set oldmode_in [twapi::GetConsoleMode $h_in] |
|
set newmode_in [expr {$oldmode_in & ~1}] |
|
twapi::SetConsoleMode $h_in $newmode_in |
|
return [list stdin [list from $oldmode_in to $newmode_in]] |
|
} |
|
|
|
|
|
|
|
} else { |
|
|
|
puts stderr "punk::console falling back to stty because twapi load failed" |
|
proc [namespace parent]::enableAnsi {} { |
|
puts stderr "punk::console::enableAnsi todo" |
|
} |
|
proc [namespace parent]::disableAnsi {} { |
|
} |
|
#? |
|
proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} { |
|
} |
|
proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { |
|
} |
|
proc [namespace parent]::enableProcessedInput {args} { |
|
|
|
} |
|
proc [namespace parent]::disableProcessedInput {args} { |
|
|
|
} |
|
|
|
} |
|
|
|
proc [namespace parent]::enableRaw {{channel stdin}} { |
|
variable is_raw |
|
variable previous_stty_state_$channel |
|
|
|
if {[package provide twapi] ne ""} { |
|
set console_handle [twapi::get_console_handle stdin] |
|
#returns dictionary |
|
#e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0 |
|
set oldmode [twapi::get_console_input_mode] |
|
twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0 |
|
# Turn off the echo and line-editing bits |
|
#set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]] |
|
set newmode [twapi::get_console_input_mode] |
|
|
|
set is_raw 1 |
|
#don't disable handler - it will detect is_raw |
|
### twapi::set_console_control_handler {} |
|
return [list stdin [list from $oldmode to $newmode]] |
|
} elseif {[set sttycmd [auto_execok stty]] ne ""} { |
|
if {[set previous_stty_state_$channel] eq ""} { |
|
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] |
|
} |
|
|
|
exec {*}$sttycmd raw -echo <@$channel |
|
set is_raw 1 |
|
#review - inconsistent return dict |
|
return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] |
|
} else { |
|
error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" |
|
} |
|
} |
|
|
|
#note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?) |
|
#could be we were missing a step in reopening stdin and console configuration? |
|
|
|
proc [namespace parent]::disableRaw {{channel stdin}} { |
|
variable is_raw |
|
variable previous_stty_state_$channel |
|
|
|
if {[package provide twapi] ne ""} { |
|
set console_handle [twapi::get_console_handle stdin] |
|
set oldmode [twapi::get_console_input_mode] |
|
# Turn on the echo and line-editing bits |
|
twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1 |
|
set newmode [twapi::get_console_input_mode] |
|
set is_raw 0 |
|
return [list stdin [list from $oldmode to $newmode]] |
|
} elseif {[set sttycmd [auto_execok stty]] ne ""} { |
|
#stty can return info on windows - but doesn't seem to be able to set anything. |
|
#review - is returned info even valid? |
|
|
|
set sttycmd [auto_execok stty] |
|
if {[set previous_stty_state_$channel] ne ""} { |
|
exec {*}$sttycmd [set previous_stty_state_$channel] |
|
set previous_stty_state_$channel "" |
|
return restored |
|
} |
|
exec {*}$sttycmd -raw echo <@$channel |
|
set is_raw 0 |
|
#do we really want to exec stty yet again to show final 'to' state? |
|
#probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. |
|
return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] |
|
} else { |
|
error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting" |
|
} |
|
} |
|
|
|
|
|
} |
|
|
|
#capturingendregex should capture ANY prefix, whole escape match - and a subcapture of the data we're interested in and match at end of string. |
|
#ie {(.*)(ESC(info)end)$} |
|
#e.g {(.*)(\x1bP44!~([:alnum:])\x1b\\)$} |
|
#we expect 4 results from regexp -indices -inline (overallmatch, prefix, wholeescape,info) |
|
#todo - check capturingendregex value supplied has appropriate captures and tail-anchor |
|
proc get_ansi_response_payload {query capturingendregex {inoutchannels {stdin stdout}}} { |
|
lassign $inoutchannels input output |
|
|
|
#chunks from input that need to be handled by readers |
|
upvar ::punk::console::input_chunks_waiting input_chunks_waiting |
|
|
|
#we need to cooperate with other stdin/$input readers and put data here if we overconsume. |
|
#Main repl reader may be currently active - or may be inactive. |
|
#This call could come from within code called by the main reader - or from user code running while main read-loop is temporarily disabled |
|
#In other contexts there may not even be another input reader |
|
|
|
#REVIEW - what if there is existing data in input_chunks_waiting - is it for us? |
|
#temp - let's keep alert to it until we decide if it's legit/required.. |
|
if {[info exists input_chunks_waiting($input)] && [llength $input_chunks_waiting($input)]} { |
|
#puts stderr "[punk::ansi::a+ cyan bold]get_ansi_response_payload called while input_chunks_waiting($input) contained data: $input_chunks_waiting($input)[punk::ansi::a]" |
|
} |
|
if {!$::punk::console::ansi_available} { |
|
return "" |
|
} |
|
set callid [info cmdcount] ;#info cmdcount is almost as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context |
|
# |
|
|
|
upvar ::punk::console::ansi_response_chunk accumulator |
|
upvar ::punk::console::ansi_response_wait waitvar |
|
upvar ::punk::console::ansi_response_queue queue |
|
upvar ::punk::console::ansi_response_queuedata queuedata |
|
upvar ::punk::console::ansi_response_clock clock |
|
upvar ::punk::console::ansi_response_timeoutid timeoutid |
|
set accumulator($callid) "" |
|
set waitvar($callid) "" |
|
lappend queue $callid |
|
|
|
|
|
|
|
#todo - use a linked array and an accumulatorid and waitvar id? When can there be more than one terminal query in-flight? |
|
|
|
set existing_handler [fileevent $input readable] ;#review! |
|
set this_handler ::punk::console::internal::ansi_response_handler_regex |
|
if {[lindex $existing_handler 0] eq $this_handler} { |
|
puts stderr "[punk::ansi::a+ red]Warning for callid $callid get_ansi_response_payload called while existing ansi response handler in place[a]: $this_handler" |
|
puts stderr "queue state: $queue" |
|
flush stderr |
|
|
|
if {[lindex $queue 0] ne $callid} { |
|
} |
|
error "get_ansi_response_payload - re-entrancy unrecoverable" |
|
} |
|
|
|
fileevent $input readable {} |
|
|
|
set input_state [fconfigure $input] |
|
#todo - make timeout configurable? |
|
set waitvarname "::punk::console::ansi_response_wait($callid)" |
|
#500ms is generally plenty for a terminal to respond.. but not in some cases. e.g event loop busy with stdin keypress?? review |
|
set timeoutid($callid) [after 2000 [list set $waitvarname timedout]] |
|
|
|
#JMN |
|
# - stderr vs stdout |
|
#It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions |
|
#(presumably race conditions as to when data hits console?) |
|
#review - experiment changing this and calling functions to stderr and see if it works |
|
#review - Are there disadvantages to using stdout vs stderr? |
|
|
|
#puts stdout "sending console request [ansistring VIEW $query]" |
|
puts -nonewline $output $query;flush $output |
|
|
|
#todo - test and save rawstate so we don't disableRaw if console was already raw |
|
if {!$::punk::console::is_raw} { |
|
set was_raw 0 |
|
punk::console::enableRaw |
|
} else { |
|
set was_raw 1 |
|
} |
|
fconfigure $input -blocking 0 |
|
# |
|
#in handler - its used for a boolean match (capturing aspect not used) |
|
set clock($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on |
|
|
|
#first shot without using filevent, call the stdin reader directly - maybe it's there already |
|
#This can be significantly faster than setting up a fileevent (2024 e.g 1.5ms vs 65ms) |
|
$this_handler $input $callid $capturingendregex |
|
if {$waitvar($callid) ne "ok"} { |
|
fileevent $input readable [list $this_handler $input $callid $capturingendregex] |
|
} |
|
|
|
#JMN |
|
|
|
#response from terminal |
|
#e.g for cursor position \033\[46;1R |
|
|
|
|
|
if {[set waitvar($callid)] eq ""} { |
|
vwait ::punk::console::ansi_response_wait($callid) |
|
#puts stderr ">>>> end vwait1 $waitvar($callid)<<<<" |
|
while {[string match extend-* $waitvar($callid)]} { |
|
set extension [lindex [split $waitvar($callid) -] 1] |
|
#puts stderr "get_ansi_response_payload Extending timeout by $extension" |
|
#after cancel $timeoutid($callid) |
|
set timeoutid($callid) [after $extension [list set $waitvarname timedout]] |
|
vwait ::punk::console::ansi_response_wait($callid) |
|
} |
|
} |
|
#response handler automatically removes it's own fileevent |
|
fileevent $input readable {} ;#explicit remove anyway - review |
|
|
|
if {$waitvar($callid) ne "timedout"} { |
|
after cancel $timeoutid($callid) |
|
} else { |
|
puts stderr "timeout in get_ansi_response_payload. callid $callid Ansi request was:[ansistring VIEW -lf 1 -vt 1 $query]" |
|
} |
|
|
|
if {$was_raw == 0} { |
|
punk::console::disableRaw |
|
} |
|
#restore $input state |
|
fconfigure $input -blocking [dict get $input_state -blocking] |
|
|
|
|
|
|
|
set response [set accumulator($callid)] |
|
|
|
if {$response ne ""} { |
|
set got_match [regexp -indices $capturingendregex $response _match_indices prefix_indices response_indices payload_indices] |
|
if {$got_match} { |
|
set responsedata [string range $response {*}$response_indices] |
|
set payload [string range $response {*}$payload_indices] |
|
set prefixdata [string range $response {*}$prefix_indices] |
|
if {$prefixdata ne ""} { |
|
#puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (response=[ansistring VIEW -lf 1 $responsedata])" |
|
lappend input_chunks_waiting($input) $prefixdata |
|
} |
|
} else { |
|
#timedout - or eof? |
|
puts stderr "get_ansi_response_payload callid:$callid regex match '$capturingendregex' to data '[ansistring VIEW -lf 1 -vt 1 $response]' not found" |
|
lappend input_chunks_waiting($input) $response |
|
set payload "" |
|
} |
|
} else { |
|
#timedout or eof? and nothing read |
|
set payload "" |
|
} |
|
|
|
#is there a way to know if existing_handler is input_chunks_waiting aware? |
|
if {[string length $existing_handler] && [lindex $existing_handler 0] ne $this_handler} { |
|
#puts "get_ansi_response_payload reinstalling ------>$existing_handler<------" |
|
fileevent $input readable $existing_handler |
|
#we may have consumed all pending input on $input - so there may be no trigger for the readable fileevent |
|
if {[llength $input_chunks_waiting($input)]} { |
|
#This is experimental If a handler is aware of input_chunks_waiting - there should be no need to schedule a trigger |
|
#If it isn't, but the handler can accept an existing chunk of data as a 'waiting' argument - we could trigger and pass it the waiting chunks - but there's no way to know its API. |
|
#we could look at info args - but that's not likely to tell us much in a robust way. |
|
#we could create a reflected channel for stdin? That is potentially an overreach..? |
|
#triggering it manually... as it was already listening - this should generally do no harm as it was the active reader anyway, but won't help with the missing data if it's input_chunks_waiting-unaware. |
|
set handler_args [info args [lindex $existing_handler 0]] |
|
if {[lindex $handler_args end] eq "waiting"} { |
|
#Looks like the existing handler is setup for punk repl cooperation. |
|
|
|
puts stdout "\n\n[punk::ansi::a+ yellow bold]-->punk::console::get_ansi_response_payload callid $callid triggering existing handler\n $existing_handler while over-read data is in punk::console::input_chunks_waiting($input) instead of channel[punk::ansi::a]" |
|
puts stdout "[punk::ansi::a+ yellow bold]-->waiting: [ansistring VIEW -lf 1 -vt 1 $input_chunks_waiting($input)][punk::ansi::a]" |
|
flush stdout |
|
|
|
#concat and supply to existing handler in single text block - review |
|
#Note will only |
|
set waitingdata [join $input_chunks_waiting($input) ""] |
|
set input_chunks_waiting($input) [list] |
|
#after idle [list after 0 [list {*}$existing_handler $waitingdata]] |
|
after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review |
|
unset waitingdata |
|
} else { |
|
#! todo? for now, emit a clue as to what's happening. |
|
puts stderr "[punk::ansi::a+ yellow bold]-->punk::console::get_ansi_response_payload cannot trigger existing handler $existing_handler while over-read data is in punk::console::input_chunks_waiting($input) instead of channel [ansistring VIEW $input_chunks_waiting($input)][punk::ansi::a]" |
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
|
if {[eof $input]} { |
|
puts stdout "restarting repl" |
|
repl::reopen_stdin |
|
} |
|
} |
|
} |
|
} |
|
#Note - we still may be in_repl_handler here (which disables its own reader while executing commandlines) |
|
#The input_chunks_waiting may really belong to the existing_handler we found - but if it doesn't consume them they will end up being read by the repl_handler when it eventually re-enables. |
|
#todo - some better structure than just a list of waiting chunks indexed by input channel, so repl/other handlers can determine the context in which these waiting chunks were generated? |
|
} elseif {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
|
if {[llength $input_chunks_waiting($input)]} { |
|
#don't trigger the repl handler manually - we will inevitably get things out of order - as it knows when to enable/disable itself based on whether chunks are waiting. |
|
#triggering it by putting it on the eventloop will potentially result in re-entrancy |
|
#The cooperating reader must be designed to consume waiting chunks and only reschedule it's channel read handler once all waiting chunks have been consumed. |
|
#puts stderr "[punk::ansi::a+ green bold]--> repl_handler has chunks to consume [ansistring VIEW $input_chunks_waiting($input)][punk::ansi::a]" |
|
} |
|
if {[eof $input]} { |
|
#test |
|
puts stdout "restarting repl" |
|
repl::reopen stdin |
|
} |
|
} |
|
|
|
catch { |
|
unset accumulator($callid) |
|
unset waitvar($callid) |
|
dict unset queuedata $callid |
|
} |
|
if {[llength $queue] > 1} { |
|
set next_callid [lindex $queue 1] |
|
set waitvar($callid) go_ahead |
|
} |
|
lpop queue 0 |
|
|
|
|
|
#set punk::console::chunk "" |
|
return $payload |
|
} |
|
|
|
|
|
#review - reading 1 byte at a time and repeatedly running the small capturing/completion regex seems a little inefficient... but we don't have a way to peek or put back chars (?) |
|
#review (we do have the punk::console::input_chunks_waiting($chan) array to cooperatively put back data - but this won't work for user scripts not aware of this) |
|
#review - timeout - what if terminal doesn't put data on stdin? error vs stderr report vs empty results |
|
#review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? |
|
#e.g what happens to mouse-events while user code is executing? |
|
#we may still need this handler if such a loop doesn't exist. |
|
proc ansi_response_handler_regex {chan callid endregex} { |
|
upvar ::punk::console::ansi_response_chunk chunks |
|
upvar ::punk::console::ansi_response_wait waits |
|
upvar ::punk::console::ansi_response_clock clock ;#initial time in millis was set when fileevent was created |
|
|
|
#endregex should explicitly have a trailing $ |
|
set status [catch {read $chan 1} bytes] |
|
if { $status != 0 } { |
|
# Error on the channel |
|
fileevent $chan readable {} |
|
puts "ansi_response_handler_regex error reading $chan: $bytes" |
|
set waits($callid) [list error_read status $status bytes $bytes] |
|
} elseif {$bytes ne ""} { |
|
# Successfully read the channel |
|
#puts "got: [string length $bytes]bytes" |
|
append chunks($callid) $bytes |
|
#puts stderr [ansistring VIEW $chunks($callid)] |
|
if {[regexp $endregex $chunks($callid)]} { |
|
fileevent $chan readable {} |
|
#puts stderr "matched - setting ansi_response_wait($callid) ok" |
|
set waits($callid) ok |
|
} else { |
|
if {[string length $chunks($callid)] % 10 == 0 || $clock($callid) - [clock millis] > 50} { |
|
after cancel $::punk::console::ansi_response_timeoutid($callid) |
|
set waits($callid) extend-1000 |
|
} |
|
} |
|
} elseif {[catch {eof $chan}] || [eof $chan]} { |
|
catch {fileevent $chan readable {}} |
|
# End of file on the channel |
|
#review |
|
puts stderr "ansi_response_handler_regex end of file on channel $chan" |
|
set waits($callid) eof |
|
} elseif {![catch {fblocked $chan}] && [fblocked $chan]} { |
|
# Read blocked. Just return |
|
# Caller should be using timeout on the wait variable |
|
} else { |
|
fileevent $chan readable {} |
|
# Something else |
|
puts stderr "ansi_response_handler_regex Situation shouldn't be possible. No error and no bytes read on channel $chan but chan is not fblocked or EOF" |
|
set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof |
|
} |
|
} |
|
} ;#end namespace eval internal |
|
|
|
variable colour_disabled 0 |
|
#todo - move to punk::config |
|
# https://no-color.org |
|
if {[info exists ::env(NO_COLOR)]} { |
|
if {$::env(NO_COLOR) ne ""} { |
|
set colour_disabled 1 |
|
} |
|
} |
|
|
|
#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} { |
|
#stdout |
|
variable ansi_wanted |
|
if {$ansi_wanted <= 0} { |
|
puts -nonewline [punk::ansi::ansistripraw [::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 ansi_wanted |
|
if {$ansi_wanted <= 0} { |
|
return |
|
} |
|
#tailcall punk::ansi::a {*}$args |
|
::punk::ansi::a {*}$args |
|
} |
|
proc code_a? {args} { |
|
variable ansi_wanted |
|
if {$ansi_wanted <= 0} { |
|
return [punk::ansi::ansistripraw [::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? |
|
#we already have colour on|off which disables SGR codes in a+ etc as well as stderr/stdout channel transforms |
|
proc ansi {{onoff {}}} { |
|
variable ansi_wanted |
|
if {[string length $onoff]} { |
|
set onoff [string tolower $onoff] |
|
switch -- $onoff { |
|
1 - |
|
on - |
|
true - |
|
yes { |
|
set ansi_wanted 1 |
|
} |
|
0 - |
|
off - |
|
false - |
|
no { |
|
set ansi_wanted 0 |
|
punk::ansi::sgr_cache -action clear |
|
} |
|
default { |
|
set ansi_wanted 2 |
|
} |
|
default { |
|
error "punk::console::ansi expected 0|1|on|off|true|false|yes|no|default" |
|
} |
|
} |
|
} |
|
catch {punk::repl::reset_prompt} |
|
puts stderr "::punk::console::ansi - use 'colour' command to turn SGR codes on/off" |
|
return [expr {$ansi_wanted}] |
|
} |
|
|
|
#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 {$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 {$on} { |
|
if {$colour_disabled} { |
|
#change of state |
|
punk::ansi::sgr_cache -action clear |
|
catch {punk::repl::reset_prompt} |
|
set colour_disabled 0 |
|
} |
|
} else { |
|
#we don't disable a/a+ entirely - they must still emit underlines/bold/reverse |
|
if {!$colour_disabled} { |
|
#change of state |
|
punk::ansi::sgr_cache -action clear |
|
catch {punk::repl::reset_prompt} |
|
set colour_disabled 1 |
|
} |
|
} |
|
} |
|
return [expr {!$colour_disabled}] |
|
} |
|
|
|
|
|
namespace eval ansi { |
|
proc a {args} { |
|
puts -nonewline [::punk::ansi::a {*}$args] |
|
} |
|
proc a? {args} { |
|
puts -nonewline stdout [::punk::ansi::a? {*}$args] |
|
} |
|
proc a+ {args} { |
|
puts -nonewline [::punk::ansi::a+ {*}$args] |
|
} |
|
proc clear {} { |
|
puts -nonewline stdout [punk::ansi::clear] |
|
} |
|
proc clear_above {} { |
|
puts -nonewline stdout [punk::ansi::clear_above] |
|
} |
|
proc clear_below {} { |
|
puts -nonewline stdout [punk::ansi::clear_below] |
|
} |
|
proc clear_all {} { |
|
puts -nonewline stdout [punk::ansi::clear_all] |
|
} |
|
proc reset {} { |
|
puts -nonewline stdout [punk::ansi::reset] |
|
} |
|
} |
|
namespace import ansi::clear |
|
namespace import ansi::clear_above |
|
namespace import ansi::clear_below |
|
namespace import ansi::clear_all |
|
namespace import ansi::reset |
|
|
|
namespace eval local { |
|
proc set_codepage_output {cpname} { |
|
#todo |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
twapi::set_console_output_codepage $cpname |
|
} else { |
|
error "set_codepage_output unimplemented on $::tcl_platform(platform)" |
|
} |
|
} |
|
proc set_codepage_input {cpname} { |
|
#todo |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
twapi::set_console_input_codepage $cpname |
|
} else { |
|
error "set_codepage_input unimplemented on $::tcl_platform(platform)" |
|
} |
|
} |
|
} |
|
namespace import local::set_codepage_output |
|
namespace import local::set_codepage_input |
|
|
|
# -- --- --- --- --- --- --- |
|
#get_ansi_response functions |
|
#review - can these functions sensibly be used on channels not attached to the local console? |
|
#ie can we default to {stdin stdout} but allow other channel pairs? |
|
# -- --- --- --- --- --- --- |
|
proc get_cursor_pos {{inoutchannels {stdin stdout}}} { |
|
#response from terminal |
|
#e.g \033\[46;1R |
|
set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} ;#must capture prefix,entire-response,response-payload |
|
|
|
set request "\033\[6n" |
|
set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] |
|
return $payload |
|
} |
|
proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} { |
|
#e.g \x1b\[P44!~E797\x1b\\ |
|
#re e.g {(.*)(\x1b\[P44!~([[:alnum:]])\x1b\[\\)$} |
|
set capturingregex [string map [list %id% $id] {(.*)(\x1bP%id%!~([[:alnum:]]+)\x1b\\)$}] |
|
set request "\x1b\[${id}\;${page}\;$t\;$l\;$b\;$r*y" |
|
set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] |
|
return $payload |
|
} |
|
proc get_device_status {{inoutchannels {stdin stdout}}} { |
|
set capturingregex {(.*)(\x1b\[([0-9]+)n)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[5n" |
|
set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] |
|
return $payload |
|
} |
|
proc get_tabstops {{inoutchannels {stdin stdout}}} { |
|
#DECTABSR \x1b\[2\$w |
|
#response example " ^[P2$u9/17/25/33/41/49/57/65/73/81^[\ " (where ^[ is \x1b) |
|
#set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} |
|
#set capturingregex {(.*)(\x1bP2$u((?:[0-9]+)*(?:\/[0-9]+)*)\x1b\\)$} |
|
set capturingregex {(.*)(\x1bP2\$u(.*)\x1b\\)$} |
|
set request "\x1b\[2\$w" |
|
set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] |
|
set tabstops [split $payload "/"] |
|
return $tabstops |
|
} |
|
|
|
#a simple estimation of tab-width under assumption console is set with even spacing. |
|
#It's known this isn't always the case - but things like textutil::untabify2 take only a single value |
|
#on some systems test_char_width is a similar speed to get_tabstop_apparent_width - but on some test_char_width is much slower |
|
#we will use test_char_width as a fallback |
|
proc get_tabstop_apparent_width {{inoutchannels {stdin stdout}}} { |
|
set tslist [get_tabstops $inoutchannels] |
|
if {![llength $tslist]} { |
|
#either terminal failed to report - or none set. |
|
set testw [test_char_width \t] |
|
if {[string is integer -strict $testw]} { |
|
return $testw |
|
} |
|
#We don't support none - default to 8 |
|
return 8 |
|
} |
|
#we generally expect to see a tabstop at column 1 - but it may not be set. |
|
if {[lindex $tslist 0] eq "1"} { |
|
if {[llength $tslist] == 1} { |
|
set testw [test_char_width \t] |
|
if {[string is integer -strict $testw]} { |
|
return $testw |
|
} |
|
return 8 |
|
} else { |
|
set next [lindex $tslist 1] |
|
return [expr {$next - 1}] |
|
} |
|
} else { |
|
#simplistic guess at width - review - do we need to consider leftmost tabstops as more likely to be non-representative and look further into the list? |
|
if {[llength $tslist] == 1} { |
|
return [lindex $tslist 0] |
|
} else { |
|
return [expr {[lindex $tslist 1] - [lindex $tslist 0]}] |
|
} |
|
} |
|
} |
|
#default to 8 just because it seems to be most common default in terminals |
|
proc set_tabstop_width {{w 8}} { |
|
set tsize [get_size] |
|
set width [dict get $tsize columns] |
|
set mod [expr {$width % $w}] |
|
set max [expr {$width - $mod}] |
|
set tstops "" |
|
set c 1 |
|
while {$c <= $max} { |
|
append tstops [string repeat " " $w][punk::ansi::set_tabstop] |
|
incr c $w |
|
} |
|
set punk::console::tabwidth $w ;#we also attempt to read terminal's tabstops and set tabwidth to the apparent spacing of first non-1 value in tabstops list. |
|
catch {textutil::tabify::untabify2 "" $w} ;#textutil tabify can end up uninitialised and raise errors like "can't read Spaces(<n>).." after a tabstop change This call seems to keep tabify happy - review. |
|
puts -nonewline "[punk::ansi::clear_all_tabstops]\n[punk::ansi::set_tabstop]$tstops" |
|
} |
|
|
|
|
|
proc get_cursor_pos_list {{inoutchannels {stdin stdout}}} { |
|
return [split [get_cursor_pos $inoutchannels] ";"] |
|
} |
|
|
|
#todo - determine cursor on/off state before the call to restore properly. |
|
proc get_size {{inoutchannels {stdin stdout}}} { |
|
lassign $inoutchannels in out |
|
#we can't reliably use [chan names] for stdin,stdout. There could be stacked channels and they may have a names such as file22fb27fe810 |
|
#chan eof is faster whether chan exists or not than |
|
if {[catch {chan eof $out} is_eof]} { |
|
error "punk::console::get_size output channel $out seems to be closed ([info level 1])" |
|
} else { |
|
if {$is_eof} { |
|
error "punk::console::get_size eof on output channel $out ([info level 1])" |
|
} |
|
} |
|
#we don't need to care about the input channel if chan configure on the output can give us the info. |
|
#short circuit ansi cursor movement method if chan configure supports the -winsize value |
|
set outconf [chan configure $out] |
|
if {[dict exists $outconf -winsize]} { |
|
#this mechanism is much faster than ansi cursor movements |
|
#REVIEW check if any x-platform anomalies with this method? |
|
#can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least |
|
lassign [dict get $outconf -winsize] cols lines |
|
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
|
return [list columns $cols rows $lines] |
|
} |
|
#continue on to ansi mechanism if we didn't get 2 ints |
|
} |
|
|
|
if {[catch {chan eof $in} is_eof]} { |
|
error "punk::console::get_size input channel $in seems to be closed ([info level 1])" |
|
} else { |
|
if {$is_eof} { |
|
error "punk::console::get_size eof on input channel $in ([info level 1])" |
|
} |
|
} |
|
|
|
#keep out of catch - no point in even trying a restore move if we can't get start position - just fail here. |
|
lassign [get_cursor_pos_list $inoutchannels] start_row start_col |
|
|
|
if {[catch { |
|
#some terminals (conemu on windows) scroll the viewport when we make a big move down like this - a move to 1 1 immediately after cursor_save doesn't seem to fix that. |
|
#This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. |
|
puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::move 2000 2000] |
|
lassign [get_cursor_pos_list $inoutchannels] lines cols |
|
puts -nonewline $out [punk::ansi::move $start_row $start_col][punk::console::cursor_on];flush stdout |
|
set result [list columns $cols rows $lines] |
|
} errM]} { |
|
puts -nonewline $out [punk::ansi::move $start_row $start_col] |
|
puts -nonewline $out [punk::ansi::cursor_on] |
|
error "$errM" |
|
} else { |
|
return $result |
|
} |
|
} |
|
|
|
#faster than get_size when it is using ansi mechanism - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore |
|
proc get_size_cursorrestore {{inoutchannels {stdin stdout}}} { |
|
lassign $inoutchannels in out |
|
#we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly |
|
set outconf [chan configure $out] |
|
if {[dict exists $outconf -winsize]} { |
|
lassign [dict get $outconf -winsize] cols lines |
|
if {[string is integer -strict $cols] && [string is integer -strict $lines]} { |
|
return [list columns $cols rows $lines] |
|
} |
|
} |
|
|
|
if {[catch { |
|
#some terminals (conemu on windows) scroll the viewport when we make a big move down like this - a move to 1 1 immediately after cursor_save doesn't seem to fix that. |
|
#This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. |
|
puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::cursor_save_dec][punk::ansi::move 2000 2000] |
|
lassign [get_cursor_pos_list $inoutchannels] lines cols |
|
puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out |
|
set result [list columns $cols rows $lines] |
|
} errM]} { |
|
puts -nonewline $out [punk::ansi::cursor_restore_dec] |
|
puts -nonewline $out [punk::ansi::cursor_on] |
|
error "$errM" |
|
} else { |
|
return $result |
|
} |
|
} |
|
proc get_dimensions {{inoutchannels {stdin stdout}}} { |
|
lassign [get_size $inoutchannels] _c cols _l lines |
|
return "${cols}x${lines}" |
|
} |
|
#the (xterm?) CSI 18t query is supported by *some* terminals |
|
proc get_xterm_size {{inoutchannels {stdin stdout}}} { |
|
set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[18t" |
|
set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] |
|
lassign [split $payload {;}] rows cols |
|
return [list columns $cols rows $rows] |
|
} |
|
proc get_mode_line_wrap {{inoutchannels {stdin stdout}}} { |
|
set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[?7\$p" |
|
set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] |
|
return $payload |
|
} |
|
|
|
#Terminals generally default to LNM being reset (off) ie enter key sends a lone <cr> |
|
#Terminals tested on windows either don't respond to this query, or respond with 0 (meaning mode not understood) |
|
#I presume from this that almost nobody is using LNM 1 (which sends both <cr> and <lf>) |
|
proc get_mode_LNM {{inoutchannels {stdin stdout}}} { |
|
set capturingregex {(.*)(\x1b\[\?20;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload |
|
set request "\x1b\[?20\$p" |
|
set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] |
|
return $payload |
|
} |
|
|
|
#terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate. |
|
#todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position. |
|
#todo - determine if these anomalies are independent of font |
|
#punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. |
|
proc test_char_width {char_or_string {emit 0}} { |
|
#return 1 |
|
#JMN |
|
#puts stderr "cwtest" |
|
variable ansi_available |
|
if {!$ansi_available} { |
|
puts stderr "No ansi - cannot test char_width of '$char_or_string' returning [string length $char_or_string]" |
|
return [string length $char_or_string] |
|
} |
|
|
|
if {!$emit} { |
|
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line, 1G cursor at col1 |
|
} |
|
set response "" |
|
if {[catch { |
|
set response [punk::console::get_cursor_pos] |
|
} errM]} { |
|
puts stderr "Cannot test_char_width for '[punk::ansi::ansistring VIEW $char_or_string]' - may be no console? Error message from get_cursor_pos: $errM" |
|
return |
|
} |
|
lassign [split $response ";"] _row1 col1 |
|
if {![string length $response] || ![string is integer -strict $col1]} { |
|
puts stderr "test_char_width Could not interpret response from get_cursor_pos for initial cursor pos. Response: '[punk::ansi::ansistring VIEW $response]'" |
|
flush stderr |
|
return |
|
} |
|
|
|
puts -nonewline stdout $char_or_string |
|
set response [punk::console::get_cursor_pos] |
|
lassign [split $response ";"] _row2 col2 |
|
if {![string is integer -strict $col2]} { |
|
puts stderr "test_char_width could not interpret response from get_cursor_pos for post-emit cursor pos. Response:'[punk::ansi::ansistring VIEW $response]'" |
|
flush stderr |
|
return |
|
} |
|
|
|
if {!$emit} { |
|
puts -nonewline stdout \033\[2K\033\[1G |
|
} |
|
flush stdout;#if we don't flush - a subsequent stderr write could move the cursor to a newline and interfere with our 2K1G erasure and cursor repositioning. |
|
return [expr {$col2 - $col1}] |
|
} |
|
|
|
#todo! - improve ideally we want to use VT sequences to determine - and make a separate utility for testing via systemcalls/os api |
|
proc test_can_ansi {} { |
|
#don't set ansi_avaliable here - we want to be able to change things, retest etc. |
|
if {"windows" eq "$::tcl_platform(platform)"} { |
|
if {[package provide twapi] ne ""} { |
|
set h_out [twapi::get_console_handle stdout] |
|
set existing_mode [twapi::GetConsoleMode $h_out] |
|
if {[expr {$existing_mode & 4}]} { |
|
#virtual terminal processing happens to be enabled - so it's supported |
|
return 1 |
|
} |
|
#output mode |
|
#ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 |
|
|
|
#try temporarily setting it - if we get an error - ansi not supported |
|
if {[catch { |
|
twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] |
|
} errM]} { |
|
return 0 |
|
} |
|
#restore |
|
twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] |
|
return 1 |
|
} else { |
|
#todo - try a cursorpos query and read stdin to see if we got a response? |
|
puts stderr "Unable to verify terminal ansi support - assuming modern default of true" |
|
puts stderr "to force disable, use command: ansi off" |
|
return 1 |
|
} |
|
} else { |
|
return 1 |
|
} |
|
} |
|
|
|
#review |
|
proc can_ansi {} { |
|
variable ansi_available |
|
if {!$ansi_available} { |
|
return 0 |
|
} |
|
set ansi_available [test_can_ansi] |
|
return [expr {$ansi_available}] |
|
} |
|
|
|
namespace eval ansi { |
|
proc cursor_on {} { |
|
puts -nonewline stdout [punk::ansi::cursor_on] |
|
} |
|
proc cursor_off {} { |
|
puts -nonewline stdout [punk::ansi::cursor_off] |
|
} |
|
} |
|
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)} { |
|
if {![catch {twapi::set_console_title $windowtitle} result]} { |
|
return $windowtitle |
|
} else { |
|
error "punk::console::local::titleset failed to set title - try punk::console::ansi::titleset" |
|
} |
|
} else { |
|
error "punk::console::local::titleset has no local mechanism to set the window title on this platform. try punk::console::ansi::titleset" |
|
} |
|
} |
|
proc titleget {} { |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
if {![catch {twapi::get_console_title} result]} { |
|
return $result |
|
} else { |
|
error "punk::console::local::titleset failed to set title - ensure twapi is available" |
|
} |
|
} else { |
|
#titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title |
|
# won't work on all platforms/terminals - but may be worth implementing (for overtype::renderspace / frames etc) |
|
error "punk::console::local::titleget has no local mechanism to get the window title on this platform." |
|
} |
|
} |
|
} |
|
|
|
namespace eval ansi { |
|
proc titleset {windowtitle} { |
|
puts -nonewline stdout [punk::ansi::titleset $windowtitle] |
|
} |
|
} |
|
#namespace import ansi::titleset |
|
proc titleset {windowtitle} { |
|
variable ansi_wanted |
|
if { $ansi_wanted <= 0} { |
|
punk::console::local::titleset $windowtitle |
|
} else { |
|
ansi::titleset $windowtitle |
|
} |
|
} |
|
#no known pure-ansi solution |
|
proc titleget {} { |
|
return [local::titleget] |
|
} |
|
|
|
proc infocmp {} { |
|
set cmd1 [auto_execok infocmp] |
|
if {[string length $cmd1]} { |
|
puts stderr "" |
|
return [exec {*}$cmd1] |
|
} else { |
|
puts stderr "infocmp doesn't seem to be present" |
|
if {$::tcl_platform(platform) 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? |
|
} |
|
} |
|
|
|
|
|
#todo - compare speed with get_cursor_pos - work out why the big difference |
|
proc test_cursor_pos {} { |
|
if {!$::punk::console::is_raw} { |
|
set was_raw 0 |
|
enableRaw |
|
} else { |
|
set was_raw 1 |
|
} |
|
puts -nonewline stdout \033\[6n ;flush stdout |
|
fconfigure stdin -blocking 0 |
|
set info [read stdin 20] ;# |
|
after 1 |
|
if {[string first "R" $info] <=0} { |
|
append info [read stdin 20] |
|
} |
|
if {!$was_raw} { |
|
disableRaw |
|
} |
|
set data [string range [string trim $info] 2 end-1] |
|
return [split $data ";"] |
|
} |
|
|
|
#channel? |
|
namespace eval ansi { |
|
proc move {row col} { |
|
puts -nonewline stdout [punk::ansi::move $row $col] |
|
} |
|
proc move_forward {n} { |
|
puts -nonewline stdout [punk::ansi::move_forward $n] |
|
} |
|
proc move_back {n} { |
|
puts -nonewline stdout [punk::ansi::move_back $n] |
|
} |
|
proc move_up {n} { |
|
puts -nonewline stdout [punk::ansi::move_up $n] |
|
} |
|
proc move_down {n} { |
|
puts -nonewline stdout [punk::ansi::move_down $n] |
|
} |
|
proc move_column {col} { |
|
puts -nonewline stdout [punk::ansi::move_column $col] |
|
} |
|
proc move_row {row} { |
|
puts -nonewline stdout [punk::ansi::move_row $col] |
|
} |
|
proc move_emit {row col data args} { |
|
puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] |
|
} |
|
proc move_emit_return {row col data args} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
set out "" |
|
append out [punk::ansi::move_emit $row $col $data {*}$args] |
|
if {!$is_in_raw} { |
|
incr orig_row -1 |
|
} |
|
move $orig_row $orig_col |
|
} |
|
proc scroll_up {n} { |
|
puts -nonewline stdout [punk::ansi::scroll_up $n] |
|
} |
|
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 |
|
proc cursor_save {} { |
|
#*** !doctools |
|
#[call [fun cursor_save]] |
|
puts -nonewline stdout \x1b\[s |
|
} |
|
proc cursor_restore {} { |
|
#*** !doctools |
|
#[call [fun cursor_restore]] |
|
puts -nonewline stdout \x1b\[u |
|
} |
|
#DEC equivalents of cursor_save/cursor_restore - perhaps more widely supported? |
|
proc cursor_save_dec {} { |
|
#*** !doctools |
|
#[call [fun cursor_save_dec]] |
|
puts -nonewline \x1b7 |
|
} |
|
proc cursor_restore_dec {} { |
|
#*** !doctools |
|
#[call [fun cursor_restore_dec]] |
|
puts -nonewline \x1b8 |
|
} |
|
|
|
proc insert_spaces {count} { |
|
puts -nonewline stdout \x1b\[${count}@ |
|
} |
|
proc delete_characters {count} { |
|
puts -nonewline \x1b\[${count}P |
|
} |
|
proc erase_characters {count} { |
|
puts -nonewline \x1b\[${count}X |
|
} |
|
proc insert_lines {count} { |
|
puts -nonewline \x1b\[${count}L |
|
} |
|
proc delete_lines {count} { |
|
puts -nonewline \x1b\[${count}M |
|
} |
|
} |
|
namespace import ansi::move |
|
namespace import ansi::move_emit |
|
namespace import ansi::move_forward |
|
namespace import ansi::move_back |
|
namespace import ansi::move_up |
|
namespace import ansi::move_down |
|
namespace import ansi::move_column |
|
namespace import ansi::move_row |
|
namespace import ansi::cursor_save |
|
namespace import ansi::cursor_restore |
|
namespace import ansi::cursor_save_dec |
|
namespace import ansi::cursor_restore_dec |
|
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 |
|
namespace import ansi::insert_lines |
|
namespace import ansi::delete_lines |
|
|
|
|
|
#experimental |
|
proc rhs_prompt {col text} { |
|
package require textblock |
|
lassign [textblock::size $text] _w tw _h th |
|
if {$th > 1} { |
|
#move up first.. need to know current line? |
|
} |
|
#set blanks [string repeat " " [expr {$col + $tw}]] |
|
#puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text |
|
#puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] |
|
cursor_save_dec |
|
#move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text |
|
#puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text |
|
puts -nonewline [punk::ansi::erase_eol][punk::ansi::move_column $col]$text |
|
cursor_restore |
|
} |
|
proc move_emit_return {row col data args} { |
|
#todo detect if in raw mode or not? |
|
set is_in_raw 0 |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
|
|
set commands "" |
|
append commands [punk::ansi::move_emit $row $col $data] |
|
foreach {row col data} $args { |
|
append commands [punk::ansi::move_emit $row $col $data] |
|
} |
|
if {!$is_in_raw} { |
|
incr orig_row -1 |
|
} |
|
append commands [punk::ansi::move $orig_row $orig_col] |
|
puts -nonewline stdout $commands |
|
return "" |
|
} |
|
#we can be (slightly?) faster and more efficient if we use the consoles cursor_save_dec command - but each savecursor overrides any previous one. |
|
#leave cursor_off/cursor_on to caller who can wrap more efficiently.. |
|
proc cursorsave_move_emit_return {row col data args} { |
|
set commands "" |
|
append commands [punk::ansi::cursor_save_dec] |
|
append commands [punk::ansi::move_emit $row $col $data] |
|
foreach {row col data} $args { |
|
append commands [punk::ansi::move_emit $row $col $data] |
|
} |
|
append commands [punk::ansi::cursor_restore_dec] |
|
puts -nonewline stdout $commands; flush stdout |
|
} |
|
proc move_emitblock_return {row col textblock} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
|
|
set commands "" |
|
foreach ln [split $textblock \n] { |
|
append commands [punk::ansi::move_emit $row $col $ln] |
|
incr row |
|
} |
|
append commands [punk::ansi::move $orig_row $orig_col] |
|
puts -nonewline $commands |
|
return |
|
} |
|
proc cursorsave_move_emitblock_return {row col textblock} { |
|
set commands "" |
|
append commands [punk::ansi::cursor_save_dec] |
|
foreach ln [split $textblock \n] { |
|
append commands [punk::ansi::move_emit $row $col $ln] |
|
incr row |
|
} |
|
append commands [punk::ansi::cursor_restore_dec] |
|
puts -nonewline stdout $commands;flush stdout |
|
return |
|
} |
|
proc move_call_return {row col script} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
move $row $col |
|
uplevel 1 $script |
|
move $orig_row $orig_col |
|
} |
|
|
|
#this doesn't work - we would need an internal virtual screen structure to pick up cursor attributes from arbitrary locations? |
|
# ncurses and its ilk may have something like that - but we specifically want to avoid curses libraries |
|
proc pick {row col} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
set test "" |
|
#set test [a green Yellow] |
|
move_emit $row $col $test\0337 |
|
puts -nonewline \0338\033\[${orig_row}\;${orig_col}H |
|
} |
|
proc pick_emit {row col data} { |
|
set test "" |
|
#set test [a green Purple] |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
move_emit $row $col $test\0337 |
|
puts -nonewline \0338\033\[${orig_row}\;${orig_col}H$data |
|
} |
|
|
|
# -- --- --- --- --- --- |
|
namespace eval ansi { |
|
proc test_decaln {} { |
|
puts -nonewline stdout [punk::ansi::test_decaln] |
|
} |
|
} |
|
namespace import ansi::test_decaln |
|
|
|
namespace eval clock { |
|
|
|
#map chars of chars "0" to "?"" ie 0x30 to x3f |
|
variable fontmap1 { |
|
7C CE DE F6 E6 C6 7C 00 |
|
30 70 30 30 30 30 FC 00 |
|
78 CC 0C 38 60 CC FC 00 |
|
78 CC 0C 38 0C CC 78 00 |
|
1C 3C 6C CC FE 0C 1E 00 |
|
FC C0 F8 0C 0C CC 78 00 |
|
38 60 C0 F8 CC CC 78 00 |
|
FC CC 0C 18 30 30 30 00 |
|
78 CC CC 78 CC CC 78 00 |
|
78 CC CC 7C 0C 18 70 00 |
|
00 18 18 00 00 18 18 00 |
|
00 18 18 00 00 18 18 30 |
|
18 30 60 C0 60 30 18 00 |
|
00 00 7E 00 7E 00 00 00 |
|
60 30 18 0C 18 30 60 00 |
|
3C 66 0C 18 18 00 18 00 |
|
} |
|
#libungif extras |
|
append fontmap1 { |
|
7c 82 9a aa aa 9e 7c 00 |
|
38 6c c6 c6 fe c6 c6 00 |
|
fc c6 c6 fc c6 c6 fc 00 |
|
} |
|
|
|
#https://github.com/Distrotech/libungif/blob/master/lib/gif_font.c |
|
variable fontmap { |
|
} |
|
#ascii row 0x00 to 0x1F control chars |
|
#(cp437 glyphs) |
|
append fontmap { |
|
00 00 00 00 00 00 00 00 |
|
3c 42 a5 81 bd 42 3c 00 |
|
3c 7e db ff c3 7e 3c 00 |
|
00 ee fe fe 7c 38 10 00 |
|
10 38 7c fe 7c 38 10 00 |
|
00 3c 18 ff ff 08 18 00 |
|
10 38 7c fe fe 10 38 00 |
|
00 00 18 3c 18 00 00 00 |
|
ff ff e7 c3 e7 ff ff ff |
|
00 3c 42 81 81 42 3c 00 |
|
ff c3 bd 7e 7e bd c3 ff |
|
1f 07 0d 7c c6 c6 7c 00 |
|
00 7e c3 c3 7e 18 7e 18 |
|
04 06 07 04 04 fc f8 00 |
|
0c 0a 0d 0b f9 f9 1f 1f |
|
00 92 7c 44 c6 7c 92 00 |
|
00 00 60 78 7e 78 60 00 |
|
00 00 06 1e 7e 1e 06 00 |
|
18 7e 18 18 18 18 7e 18 |
|
66 66 66 66 66 00 66 00 |
|
ff b6 76 36 36 36 36 00 |
|
7e c1 dc 22 22 1f 83 7e |
|
00 00 00 7e 7e 00 00 00 |
|
18 7e 18 18 7e 18 00 ff |
|
18 7e 18 18 18 18 18 00 |
|
18 18 18 18 18 7e 18 00 |
|
00 04 06 ff 06 04 00 00 |
|
00 20 60 ff 60 20 00 00 |
|
00 00 00 c0 c0 c0 ff 00 |
|
00 24 66 ff 66 24 00 00 |
|
00 00 10 38 7c fe 00 00 |
|
00 00 00 fe 7c 38 10 00 |
|
} |
|
#chars SP to "/" row 0x20 to 0x2f |
|
append fontmap { |
|
00 00 00 00 00 00 00 00 |
|
30 30 30 30 30 00 30 00 |
|
66 66 00 00 00 00 00 00 |
|
6c 6c fe 6c fe 6c 6c 00 |
|
10 7c d2 7c 86 7c 10 00 |
|
f0 96 fc 18 3e 72 de 00 |
|
30 48 30 78 ce cc 78 00 |
|
0c 0c 18 00 00 00 00 00 |
|
10 60 c0 c0 c0 60 10 00 |
|
10 0c 06 06 06 0c 10 00 |
|
00 54 38 fe 38 54 00 00 |
|
00 18 18 7e 18 18 00 00 |
|
00 00 00 00 00 00 18 70 |
|
00 00 00 7e 00 00 00 00 |
|
00 00 00 00 00 00 18 00 |
|
02 06 0c 18 30 60 c0 00 |
|
} |
|
#chars "0" to "?"" row 0x30 to 0x3f |
|
append fontmap { |
|
7c c6 c6 c6 c6 c6 7c 00 |
|
18 38 78 18 18 18 3c 00 |
|
7c c6 06 0c 30 60 fe 00 |
|
7c c6 06 3c 06 c6 7c 00 |
|
0e 1e 36 66 fe 06 06 00 |
|
fe c0 c0 fc 06 06 fc 00 |
|
7c c6 c0 fc c6 c6 7c 00 |
|
fe 06 0c 18 30 60 60 00 |
|
7c c6 c6 7c c6 c6 7c 00 |
|
7c c6 c6 7e 06 c6 7c 00 |
|
00 30 00 00 00 30 00 00 |
|
00 30 00 00 00 30 20 00 |
|
00 1c 30 60 30 1c 00 00 |
|
00 00 7e 00 7e 00 00 00 |
|
00 70 18 0c 18 70 00 00 |
|
7c c6 0c 18 30 00 30 00 |
|
} |
|
#chars "@" to "O" row 0x40 to 0x4f |
|
append fontmap { |
|
7c 82 9a aa aa 9e 7c 00 |
|
38 6c c6 c6 fe c6 c6 00 |
|
fc c6 c6 fc c6 c6 fc 00 |
|
7c c6 c6 c0 c0 c6 7c 00 |
|
f8 cc c6 c6 c6 cc f8 00 |
|
fe c0 c0 fc c0 c0 fe 00 |
|
fe c0 c0 fc c0 c0 c0 00 |
|
7c c6 c0 ce c6 c6 7e 00 |
|
c6 c6 c6 fe c6 c6 c6 00 |
|
78 30 30 30 30 30 78 00 |
|
1e 06 06 06 c6 c6 7c 00 |
|
c6 cc d8 f0 d8 cc c6 00 |
|
c0 c0 c0 c0 c0 c0 fe 00 |
|
c6 ee fe d6 c6 c6 c6 00 |
|
c6 e6 f6 de ce c6 c6 00 |
|
7c c6 c6 c6 c6 c6 7c 00 |
|
} |
|
#chars "P" to "_" row 0x50 to 0x5f |
|
append fontmap { |
|
fc c6 c6 fc c0 c0 c0 00 |
|
7c c6 c6 c6 c6 c6 7c 06 |
|
fc c6 c6 fc c6 c6 c6 00 |
|
78 cc 60 30 18 cc 78 00 |
|
fc 30 30 30 30 30 30 00 |
|
c6 c6 c6 c6 c6 c6 7c 00 |
|
c6 c6 c6 c6 c6 6c 38 00 |
|
c6 c6 c6 d6 fe ee c6 00 |
|
c6 c6 6c 38 6c c6 c6 00 |
|
c3 c3 66 3c 18 18 18 00 |
|
fe 0c 18 30 60 c0 fe 00 |
|
3c 30 30 30 30 30 3c 00 |
|
c0 60 30 18 0c 06 03 00 |
|
3c 0c 0c 0c 0c 0c 3c 00 |
|
00 38 6c c6 00 00 00 00 |
|
00 00 00 00 00 00 00 ff |
|
} |
|
#chars "`" to "o" row 0x60 to 0x6f |
|
append fontmap { |
|
30 30 18 00 00 00 00 00 |
|
00 00 7c 06 7e c6 7e 00 |
|
c0 c0 fc c6 c6 e6 dc 00 |
|
00 00 7c c6 c0 c0 7e 00 |
|
06 06 7e c6 c6 ce 76 00 |
|
00 00 7c c6 fe c0 7e 00 |
|
1e 30 7c 30 30 30 30 00 |
|
00 00 7e c6 ce 76 06 7c |
|
c0 c0 fc c6 c6 c6 c6 00 |
|
18 00 38 18 18 18 3c 00 |
|
18 00 38 18 18 18 18 f0 |
|
c0 c0 cc d8 f0 d8 cc 00 |
|
38 18 18 18 18 18 3c 00 |
|
00 00 cc fe d6 c6 c6 00 |
|
00 00 fc c6 c6 c6 c6 00 |
|
00 00 7c c6 c6 c6 7c 00 |
|
} |
|
#chars "p" to DEL row 0x70 to 0x7f |
|
append fontmap { |
|
00 00 fc c6 c6 e6 dc c0 |
|
00 00 7e c6 c6 ce 76 06 |
|
00 00 6e 70 60 60 60 00 |
|
00 00 7c c0 7c 06 fc 00 |
|
30 30 7c 30 30 30 1c 00 |
|
00 00 c6 c6 c6 c6 7e 00 |
|
00 00 c6 c6 c6 6c 38 00 |
|
00 00 c6 c6 d6 fe 6c 00 |
|
00 00 c6 6c 38 6c c6 00 |
|
00 00 c6 c6 ce 76 06 7c |
|
00 00 fc 18 30 60 fc 00 |
|
0e 18 18 70 18 18 0e 00 |
|
18 18 18 00 18 18 18 00 |
|
e0 30 30 1c 30 30 e0 00 |
|
00 00 70 9a 0e 00 00 00 |
|
00 00 18 3c 66 ff 00 00 |
|
} |
|
|
|
proc bigstr {str row col} { |
|
variable fontmap |
|
#curses attr off reverse |
|
#a noreverse |
|
set reverse 0 |
|
set output "" |
|
set charno 0 |
|
foreach char [split $str {}] { |
|
binary scan $char c f |
|
set index [expr {$f * 8}] |
|
for {set line 0} {$line < 8} {incr line} { |
|
set bitline 0x[lindex $fontmap [expr {$index + $line}]] |
|
binary scan [binary format c $bitline] B8 charline |
|
set cix 0 |
|
foreach c [split $charline {}] { |
|
if {$c} { |
|
append output [punk::ansi::move_emit [expr {$row + $line}] [expr {$col + $charno * 8 + $cix}] "[a+ reverse] [a+ noreverse]"] |
|
#curses attr on reverse |
|
#curses move [expr $row + $line] [expr $col + $charno * 8 + $cix] |
|
#curses puts " " |
|
} |
|
incr cix |
|
} |
|
} |
|
incr charno |
|
} |
|
return $output |
|
} |
|
proc get_time {} { |
|
overtype::left -width 70 "" [bigstr [clock format [clock seconds] -format %H:%M:%S] 1 1] |
|
} |
|
|
|
|
|
proc display1 {} { |
|
#punk::console::clear |
|
punk::console::move_call_return 20 20 {punk::console::clear_above} |
|
flush stdout |
|
punk::console::move_call_return 0 0 {puts stdout [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5]} |
|
after 2000 {punk::console::clock::display} |
|
} |
|
proc display {} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
punk::console::move 20 20 |
|
punk::console::clear_above |
|
punk::console::move 0 0 |
|
puts -nonewline [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5] |
|
|
|
punk::console::move $orig_row $orig_col |
|
#after 2000 {punk::console::clock::display} |
|
} |
|
|
|
proc displaystr {str} { |
|
lassign [punk::console::get_cursor_pos_list] orig_row orig_col |
|
punk::console::move 20 20 |
|
punk::console::clear_above |
|
punk::console::move 0 0 |
|
puts -nonewline [bigstr $str 10 5] |
|
|
|
punk::console::move $orig_row $orig_col |
|
} |
|
|
|
|
|
} |
|
|
|
proc test {} { |
|
set high_unicode_length [string length \U00010000] |
|
set can_high_unicode 0 |
|
set can_regex_high_unicode 0 |
|
set can_terminal_report_dingbat_width 0 |
|
set can_terminal_report_diacritic_width 0 |
|
if {$high_unicode_length != 1} { |
|
puts stderr "punk::console WARNING: no modern unicode support in this Tcl version. High unicode values not properly supported. (string length \\U00010000 : $high_unicode_length should be 1)" |
|
} else { |
|
set can_high_unicode 1 |
|
set can_regex_high_unicode [string match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] |
|
if {!$can_regex_high_unicode} { |
|
puts stderr "punk::console warning: TCL version cannot perform braced regex of high unicode" |
|
} |
|
} |
|
set dingbat_heavy_plus_width [punk::console::test_char_width \U2795] ;#review - may be font dependent. We chose a wide dingbat as a glyph that is hopefully commonly renderable - and should display 2 wide. |
|
#This will give a false report that terminal can't report width if the glyph (or replacement glyph) is actually being rendered 1 wide. |
|
#we can't distinguish without user interaction? |
|
if {$dingbat_heavy_plus_width == 2} { |
|
set can_terminal_report_dingbat_width 1 |
|
} else { |
|
puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." |
|
} |
|
set diacritic_width [punk::console::test_char_width a\u0300] |
|
if {$diacritic_width == 1} { |
|
set can_terminal_report_diacritic_width 1 |
|
} else { |
|
puts stderr "punk::console warning: terminal unable to report diacritic width properly." |
|
} |
|
|
|
if {$can_high_unicode && $can_regex_high_unicode && $can_terminal_report_dingbat_width && $can_terminal_report_diacritic_width} { |
|
set result [list result ok] |
|
} else { |
|
set result [list result error] |
|
} |
|
return $result |
|
} |
|
#run the test and allow warnings to be emitted to stderr on package load. User should know the terminal and/or Tcl version are not optimal for unicode character work |
|
#set testresult [test1] |
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::console ---}] |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::console [namespace eval punk::console { |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end]
|
|
|