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.
912 lines
34 KiB
912 lines
34 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 |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
package require punk::ansi |
|
|
|
|
|
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 { |
|
variable has_twapi 0 |
|
|
|
#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)} { |
|
proc enableAnsi {} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall enableAnsi |
|
} |
|
proc enableRaw {{channel stdin}} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall enableRaw $channel |
|
} |
|
proc disableRaw {{channel stdin}} { |
|
#loopavoidancetoken (don't remove) |
|
internal::define_windows_procs |
|
internal::abort_if_loop |
|
tailcall disableRaw $channel |
|
} |
|
} else { |
|
proc enableAnsi {} { |
|
#todo? |
|
} |
|
proc enableRaw {{channel stdin}} { |
|
set sttycmd [auto_execok stty] |
|
exec {*}$sttycmd raw -echo <@$channel |
|
} |
|
proc disableRaw {{channel stdin}} { |
|
set sttycmd [auto_execok stty] |
|
exec {*}$sttycmd raw echo <@$channel |
|
} |
|
} |
|
|
|
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 |
|
|
|
} |
|
|
|
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 {} { |
|
set loadstate [zzzload::pkg_require twapi] |
|
if {$loadstate ni [list loading 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.. |
|
|
|
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 | 5}] ;#5? |
|
|
|
twapi::SetConsoleMode $h_out $newmode_out |
|
|
|
#input handle modes |
|
#ENABLE_PROCESSED_INPUT 0x0001 |
|
#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}] |
|
|
|
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 & ~5}] |
|
twapi::SetConsoleMode $h_out $newmode_out |
|
|
|
|
|
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]::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]] |
|
} |
|
|
|
|
|
proc [namespace parent]::enableRaw {{channel stdin}} { |
|
#review - change to modify_console_input_mode |
|
set console_handle [twapi::GetStdHandle -10] |
|
set oldmode [twapi::GetConsoleMode $console_handle] |
|
set newmode [expr {$oldmode & ~6}] ;# Turn off the echo and line-editing bits |
|
twapi::SetConsoleMode $console_handle $newmode |
|
return [list stdin [list from $oldmode to $newmode]] |
|
} |
|
proc [namespace parent]::disableRaw {{channel stdin}} { |
|
set console_handle [twapi::GetStdHandle -10] |
|
set oldmode [twapi::GetConsoleMode $console_handle] |
|
set newmode [expr {$oldmode | 6}] ;# Turn on the echo and line-editing bits |
|
twapi::SetConsoleMode $console_handle $newmode |
|
return [list stdin [list from $oldmode to $newmode]] |
|
} |
|
|
|
} else { |
|
if {$loadstate eq "failed"} { |
|
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]::enableRaw {{channel stdin}} { |
|
set sttycmd [auto_execok stty] |
|
exec {*}$sttycmd raw -echo <@$channel |
|
} |
|
proc [namespace parent]::disableRaw {{channel stdin}} { |
|
set sttycmd [auto_execok stty] |
|
exec {*}$sttycmd raw echo <@$channel |
|
} |
|
} |
|
} |
|
} |
|
|
|
proc ansi_response_handler {chan accumulatorvar waitvar} { |
|
set status [catch {read $chan 1} bytes] |
|
if { $status != 0 } { |
|
# Error on the channel |
|
fileevent stdin readable {} |
|
puts "error reading $chan: $bytes" |
|
set $waitvar [list error_read status $status bytes $bytes] |
|
} elseif {$bytes ne ""} { |
|
# Successfully read the channel |
|
#puts "got: [string length $bytes]" |
|
upvar $accumulatorvar chunk |
|
append chunk $bytes |
|
if {$bytes eq "R"} { |
|
fileevent stdin readable {} |
|
set $waitvar ok |
|
} |
|
} elseif { [eof $chan] } { |
|
fileevent stdin readable {} |
|
# End of file on the channel |
|
#review |
|
puts "ansi_response_handler end of file" |
|
set $waitvar eof |
|
} elseif { [fblocked $chan] } { |
|
# Read blocked. Just return |
|
} else { |
|
fileevent stdin readable {} |
|
# Something else |
|
puts "ansi_response_handler can't happen" |
|
set $waitvar error_unknown |
|
} |
|
} |
|
} ;#end namespace eval internal |
|
|
|
variable colour_disabled 0 |
|
# https://no-color.org |
|
if {[info exists ::env(NO_COLOR)]} { |
|
if {$::env(NO_COLOR) ne ""} { |
|
set colour_disabled 1 |
|
} |
|
} |
|
|
|
namespace eval ansi { |
|
proc a+ {args} { |
|
puts -nonewline [::punk::ansi::a+ {*}$args] |
|
} |
|
} |
|
proc ansi+ {args} { |
|
variable colour_disabled |
|
if {$colour_disabled == 1} { |
|
return |
|
} |
|
#stdout |
|
tailcall ansi::a+ {*}$args |
|
} |
|
proc get_ansi+ {args} { |
|
variable colour_disabled |
|
if {$colour_disabled == 1} { |
|
return |
|
} |
|
tailcall punk::ansi::a+ {*}$args |
|
} |
|
|
|
namespace eval ansi { |
|
proc a {args} { |
|
puts -nonewline [::punk::ansi::a {*}$args] |
|
} |
|
} |
|
proc ansi {args} { |
|
variable colour_disabled |
|
if {$colour_disabled == 1} { |
|
return |
|
} |
|
#stdout |
|
tailcall ansi::a {*}$args |
|
} |
|
proc get_ansi {args} { |
|
variable colour_disabled |
|
if {$colour_disabled == 1} { |
|
return |
|
} |
|
tailcall punk::ansi::a {*}$args |
|
} |
|
|
|
namespace eval ansi { |
|
proc a? {args} { |
|
puts -nonewline stdout [::punk::ansi::a? {*}$args] |
|
} |
|
} |
|
proc ansi? {args} { |
|
#stdout |
|
tailcall ansi::a? {*}$args |
|
} |
|
proc get_ansi? {args} { |
|
tailcall ::punk::ansi::a? {*}$args |
|
} |
|
|
|
proc colour {{onoff {}}} { |
|
variable colour_disabled |
|
if {[string length $onoff]} { |
|
set onoff [string tolower $onoff] |
|
if {$onoff in [list 1 on true yes]} { |
|
interp alias "" a+ "" punk::console::ansi+ |
|
set colour_disabled 0 |
|
} elseif {$onoff in [list 0 off false no]} { |
|
interp alias "" a+ "" control::no-op |
|
set colour_disabled 1 |
|
} else { |
|
error "punk::console::colour expected 0|1|on|off|true|false|yes|no" |
|
} |
|
} |
|
catch {repl::reset_prompt} |
|
return [expr {!$colour_disabled}] |
|
} |
|
|
|
namespace eval ansi { |
|
proc reset {} { |
|
puts -nonewline stdout [punk::ansi::reset] |
|
} |
|
} |
|
namespace import ansi::reset |
|
|
|
namespace eval ansi { |
|
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] |
|
} |
|
} |
|
namespace import ansi::clear |
|
namespace import ansi::clear_above |
|
namespace import ansi::clear_below |
|
namespace import ansi::clear_all |
|
|
|
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 |
|
|
|
|
|
proc get_cursor_pos {} { |
|
set ::punk::console::chunk "" |
|
|
|
set accumulator ::punk::console::chunk |
|
set waitvar ::punk::console::chunkdone |
|
set existing_handler [fileevent stdin readable] |
|
set $waitvar "" |
|
#todo - test and save rawstate so we don't disableRaw if terminal was already raw |
|
enableRaw |
|
fconfigure stdin -blocking 0 |
|
fileevent stdin readable [list ::punk::console::internal::ansi_response_handler stdin $accumulator $waitvar] |
|
puts -nonewline stdout \033\[6n ;flush stdout |
|
after 0 {update idletasks} |
|
#e.g \033\[46;1R |
|
#todo - reset |
|
set info "" |
|
if {[set $waitvar] eq ""} { |
|
vwait $waitvar |
|
} |
|
disableRaw |
|
if {[string length $existing_handler]} { |
|
fileevent stdin readable $existing_handler |
|
} |
|
|
|
set info [set $accumulator] |
|
#set punk::console::chunk "" |
|
set data [string range $info 2 end-1] |
|
return $data |
|
} |
|
proc get_cursor_pos_list {} { |
|
return [split [get_cursor_pos] ";"] |
|
} |
|
|
|
#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}} { |
|
if {!$emit} { |
|
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1 |
|
} |
|
lassign [split [punk::console::get_cursor_pos] ";"] _row1 col1 |
|
puts -nonewline stdout $char_or_string |
|
lassign [split [punk::console::get_cursor_pos] ";"] _row2 col2 |
|
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}] |
|
} |
|
|
|
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 |
|
|
|
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::titleset failed to set title - try punk::console::ansi::titleset" |
|
} |
|
} else { |
|
error "punk::console::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::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 |
|
error "punk::console::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 |
|
#no known pure-ansi solution |
|
proc titleget {} { |
|
return [local::titleget] |
|
} |
|
|
|
proc infocmp_test {} { |
|
set cmd1 [auto_execok infocmp] |
|
if {[string length $cmd1]} { |
|
puts stderr "infocmp seems to be available" |
|
return [exec {*}$cmd1] |
|
} else { |
|
puts stderr "infcmp doesn't seem to be present" |
|
set tcmd [auto_execok tput] |
|
if {[string length $tcmd]} { |
|
puts stderr "tput seems to be available. Try something like: tput -S - (freebsd)" |
|
} |
|
} |
|
} |
|
|
|
proc test_cursor_pos {} { |
|
enableRaw |
|
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] |
|
} |
|
disableRaw |
|
set data [string range [string trim $info] 2 end-1] |
|
return [split $data ";"] |
|
} |
|
|
|
namespace eval ansi { |
|
proc move {row col} { |
|
puts -nonewline stdout [punk::ansi::move $row $col] |
|
} |
|
proc move_forward {row col} { |
|
puts -nonewline stdout [punk::ansi::move_forward $row $col] |
|
} |
|
proc move_back {row col} { |
|
puts -nonewline stdout [punk::ansi::move_back $row $col] |
|
} |
|
proc move_up {row col} { |
|
puts -nonewline stdout [punk::ansi::move_up $row $col] |
|
} |
|
proc move_down {row col} { |
|
puts -nonewline stdout [punk::ansi::move_down $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 |
|
} |
|
} |
|
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 |
|
|
|
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 |
|
|
|
move_emit $row $col $data |
|
foreach {row col data} $args { |
|
move_emit $row $col $data |
|
} |
|
|
|
if {!$is_in_raw} { |
|
incr orig_row -1 |
|
} |
|
move $orig_row $orig_col |
|
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 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] |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::console [namespace eval punk::console { |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |