# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -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 0.1.1 # Meta platform tcl # Meta license # @@ Meta End # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[manpage_begin punkshell_module_punk::console 0 0.1.1] #[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 Thread ;#tsv required to sync is_raw package require punk::ansi package require punk::args #*** !doctools #[item] [package {Tcl 8.6-}] #[item] [package {Thread}] #[item] [package {punk::ansi}] #[item] [package {punk::args}] #*** !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 PUNKARGS 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 if {![tsv::exists console is_raw]} { tsv::set console 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 array set ansi_response_wait {} variable ansi_response_queue [list];#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 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 set for input and output modes currently - only valid to set on a readable channel? #on windows they can be set independently (but not with stty) - REVIEW #NOTE - the is_raw is only being set in current interp - but the channel is shared. #this is problematic with the repl thread being separate. - must be a tsv? REVIEW 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 {exec {*}$sttycmd -g <@$channel} previous_stty_state_$channel]} { set previous_stty_state_$channel "" } } exec {*}$sttycmd raw -echo <@$channel tsv::set console 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 "" tsv::set console is_raw 0 return restored } exec {*}$sttycmd -raw echo <@$channel tsv::set console 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 } #todo stop_application_mode {} {} 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 {[tsv::get console 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] tsv::set console 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 tsv::set console 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] tsv::set console 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 tsv::set console 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" } } } lappend PUNKARGS [list { @id -id ::punk::console::internal::get_ansi_response_payload @cmd -name punk::console::internal::get_ansi_response_payload -help\ "Terminal query helper. Captures the significant portion (payload as defined by supplied capturingendregex capture groups) of the input channel's response to a query placed on the output channel. Usually this means a write to stdout with a response on stdin. This function uses a 'chan event' read handler function ::punk::console::internal::ansi_response_handler_regex to read the input channel character by character to ensure it doesn't overconsume input. It can run cooperatively with the punk::repl stdin reader or other readers if done carefully. The mechanism to run while other readers are active involves disabling and re-enabling installed 'chan event' handlers and possibly using a shared namespace variable (::punk::console::input_chunks_waiting) to ensure all data gets to the right handler. (unread data on input prior to this function being called) Not fully documented. (source diving required -see punk::repl) " @opts -ignoreok -type boolean -default 0 -help\ "Experimental/debug ignore the regex match 'ok' response and keep going." -return -type string -default payload -choices {payload dict} -choicelabels { dict\ "dict with keys prefix,response,payload,all" } -help\ "Return format" -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" -expected_ms -default 300 -type integer -help\ "Expected number of ms for response from terminal. 100ms is usually plenty for a local terminal and a basic query such as cursor position. However on a busy machine a higher timeout may be prudent." @values -min 2 -max 2 query -type string -help\ "ANSI sequence such as \x1b\[?6n which should elicit a response by the terminal on stdin" capturingendregex -type string -help\ "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 {args} { #we pay a few 10s of microseconds to use punk::args::parse (on the happy path) #seems reasonable for the flexibility in this case. set argd [punk::args::parse $args withid ::punk::console::internal::get_ansi_response_payload] lassign [dict values $argd] leaders opts values received set inoutchannels [dict get $opts -terminal] set expected [dict get $opts -expected_ms] set ignoreok [dict get $opts -ignoreok] set returntype [dict get $opts -return] set query [dict get $values query] set capturingendregex [dict get $values capturingendregex] 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? #This occurs for example with key held down on autorepeat and is normal #enable it here for debug/testing only #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: [punk::ansi::a][ansistring VIEW $input_chunks_waiting($input)]" #} if {!$::punk::console::ansi_available} { return "" } # -- --- #set callid [info cmdcount] ;#info cmdcount is fast, though not as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context #clock clicks is approx 2x faster - but can sometimes give duplicates if called sequentially e.g list [clock clicks] [clock clicks] #Either is suitable here, where subsequent calls will be relatively far apart in time #speed of call insignificant compared to function set callid [clock clicks] # -- --- # 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_tslaunch tslaunch upvar ::punk::console::ansi_response_tsclock tsclock upvar ::punk::console::ansi_response_timeoutid timeoutid set accumulator($callid) "" set waitvar($callid) "" lappend queue $callid if {[llength $queue] > 1} { #while {[lindex $queue 0] ne $callid} {} set queuedata($callid) $args set runningid [lindex $queue 0] while {$runningid ne $callid} { #puts stderr "." vwait ::punk::console::ansi_response_wait set runningid [lindex $queue 0] if {$runningid ne $callid} { set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid) update ;#REVIEW - probably a bad idea after 10 set runningid [lindex $queue 0] ;#jn test } } } #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 [chan event $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" } } chan event $input readable {} # - 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? set previous_input_state [chan configure $input] #chan configure $input -blocking 0 #todo - make timeout configurable? set waitvarname "::punk::console::ansi_response_wait($callid)" #todo - test and save rawstate so we don't disableRaw if console was already raw if {![tsv::get console is_raw]} { set was_raw 0 punk::console::enableRaw #after 0 [list chan event $input readable [list $this_handler $input $callid $capturingendregex]] incr expected 50 ;#review set timeoutid($callid) [after $expected [list set $waitvarname timedout]] #puts stdout "sending console request [ansistring VIEW $query]" } else { set was_raw 1 set timeoutid($callid) [after $expected [list set $waitvarname timedout]] } #write before console enableRaw vs after?? #There seem to be problems (e.g on WSL) if we write too early - the output ends up on screen but we don't read it puts -nonewline $output $query;flush $output chan configure $input -blocking 0 set tslaunch($callid) [clock millis] ;#time of launch - may be delay before first event depending on what's going on set tsclock($callid) $tslaunch($callid) #after 0 #------------------ #trying alternatives to get faster read and maintain reliability..REVIEW #we should care more about performance in raw mode - as ultimately that's the one we prefer for full features #------------------ # 1) faster - races? $this_handler $input $callid $capturingendregex $this_handler $input $callid $capturingendregex if {$ignoreok || $waitvar($callid) ne "ok"} { chan event $input readable [list $this_handler $input $callid $capturingendregex] } # 2) more reliable? #chan event $input readable [list $this_handler $input $callid $capturingendregex] #------------------ #response from terminal #e.g for cursor position \033\[46;1R #after 0 [list $this_handler $input $callid $capturingendregex] set remaining $expected if {$waitvar($callid) eq ""} { set lastvwait [clock millis] vwait ::punk::console::ansi_response_wait($callid) #puts stderr ">>>> end vwait1 $waitvar($callid)<<<<" while {[string match extend-* $waitvar($callid)] || ($ignoreok && $waitvar($callid) eq "ok")} { if {[string match extend-* $waitvar($callid)]} { set extension [lindex [split $waitvar($callid) -] 1] if {$extension eq ""} { puts "blank extension $waitvar($callid)" puts "->[set $waitvar($callid)]<-" } puts stderr "get_ansi_response_payload Extending timeout by $extension for callid:$callid" after cancel $timeoutid($callid) set total_elapsed [expr {[clock millis] - $tslaunch($callid)}] set last_elapsed [expr {[clock millis] - $lastvwait}] set remaining [expr {$remaining - $last_elapsed}] if {$remaining < 0} {set remaining 0} set newtime [expr {$remaining + $extension}] set timeoutid($callid) [after $newtime [list set $waitvarname timedout]] set lastvwait [clock millis] vwait ::punk::console::ansi_response_wait($callid) } else { #ignoreok - reapply the handler that disabled itself due to 'ok' chan event $input readable [list $this_handler $input $callid $capturingendregex] set lastvwait [clock millis] vwait ::punk::console::ansi_response_wait($callid) } } } #response handler automatically removes it's own chan event chan event $input readable {} ;#explicit remove anyway - review if {$waitvar($callid) ne "timedout"} { after cancel $timeoutid($callid) } else { puts stderr "timeout (timediff [expr {[clock millis] - $tslaunch($callid)}]ms) 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 #it *might* be ok to restore entire state on an input channel #(it's not always on all channels - e.g stdout has -winsize which is read-only) #Safest to only restore what we think we've modified. chan configure $input -blocking [dict get $previous_input_state -blocking] set input_read [set accumulator($callid)] if {$input_read ne ""} { set got_match [regexp -indices $capturingendregex $input_read _match_indices prefix_indices response_indices payload_indices] if {$got_match} { set responsedata [string range $input_read {*}$response_indices] set payload [string range $input_read {*}$payload_indices] set prefixdata [string range $input_read {*}$prefix_indices] if {!$ignoreok && $prefixdata ne ""} { #puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (responsedata=[ansistring VIEW -lf 1 $responsedata])" lappend input_chunks_waiting($input) $prefixdata } } else { #timedout - or eof? if {!$ignoreok} { puts stderr "get_ansi_response_payload callid:$callid regex match '$capturingendregex' to input_read '[ansistring VIEW -lf 1 -vt 1 $input_read]' not found" lappend input_chunks_waiting($input) $input_read set payload "" } else { set responsedata "" set payload "" set prefixdata "" } } } else { #timedout or eof? and nothing read set responsedata "" set prefixdata "" set payload "" } # ------------------------------------------------------------------------------------- # Other input readers # ------------------------------------------------------------------------------------- #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<------" chan event $input readable $existing_handler #this_handler may have consumed all pending input on $input - so there may be no trigger for the readable chan event for existing_handler 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 "get_ansi_response_payload experimental - restarting repl" repl::reopen stdin } } # ------------------------------------------------------------------------------------- unset -nocomplain accumulator($callid) unset -nocomplain waitvar($callid) unset -nocomplain timeoutid($callid) unset -nocomplain tsclock($callid) unset -nocomplain tslaunch($callid) dict unset queuedata $callid #lpop queue 0 ledit queue 0 0 if {[llength $queue] > 0} { set next_callid [lindex $queue 0] set waitvar($callid) go_ahead #set nextdata [set queuedata($next_callid)] } #set punk::console::chunk "" if {$returntype eq "dict"} { return [dict create\ prefix $prefixdata\ payload $payload\ response $responsedata\ all $input_read\ ] } else { 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_tslaunch tslaunch ;#initial time in millis was set when chan event was created upvar ::punk::console::ansi_response_tsclock tsclock #endregex should explicitly have a trailing $ set status [catch {read $chan 1} bytes] if { $status != 0 } { # Error on the channel chan event $chan readable {} puts "ansi_response_handler_regex error reading $chan: $bytes" set waits($callid) [list error error_read status $status bytes $bytes] } elseif {$bytes ne ""} { #puts stderr . ;flush stderr # Successfully read the channel #puts "got: [string length $bytes]bytes" set sofar [append chunks($callid) $bytes] #puts stderr [ansistring VIEW $chunks($callid)] #review - what is min length of any ansiresponse? #we know there is at least one of only 3 chars, vt52 response to ESC Z: ESC / Z #endregex is capturing - but as we are only testing the match here #it should perform the same as if it were non-capturing if {[string length $sofar] > 2 && [regexp $endregex $sofar]} { #puts stderr "matched - setting ansi_response_wait($callid) ok" chan event $chan readable {} set waits($callid) ok } else { # 30ms 16ms? set tsnow [clock millis] set total_elapsed [expr {[set tslaunch($callid)] - $tsnow}] set last_elapsed [expr {[set tsclock($callid)] - $tsnow}] if {[string length $sofar] % 10 == 0 || $last_elapsed > 16} { if {$total_elapsed > 3000} { #REVIEW #too long since initial read handler launched.. #is other data being pumped into stdin? Eventloop starvation? Did we miss our codes? #For now we'll stop extending the timeout. after cancel $::punk::console::ansi_response_timeoutid($callid) set waits($callid) [list error error_ansi_response_handler_regex_too_long_reading] } else { if {$last_elapsed > 0} { after cancel $::punk::console::ansi_response_timeoutid($callid) set waits($callid) extend-[expr {min(16,$last_elapsed)}] } } } set tsclock(callid) [clock millis] } } elseif {[catch {eof $chan}] || [eof $chan]} { catch {chan event $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 {chan blocked $chan}] && [chan blocked $chan]} { # Read blocked is normal. (chan -blocking = 0 but reading only 1 char) # Caller should be using timeout on the wait variable #set waits($callid) continue set tsclock($callid) [clock millis] } else { chan event $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 not chan blocked 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 #punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ lappend PUNKARGS_aliases {::punk::console::code_a+ ::punk::ansi::a+} 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 } lappend PUNKARGS_aliases {::punk::console::code_a ::punk::ansi::a} proc code_a {args} { variable ansi_wanted if {$ansi_wanted <= 0} { return } #tailcall punk::ansi::a {*}$args ::punk::ansi::a {*}$args } lappend PUNKARGS_aliases {::punk::console::code_a? ::punk::ansi::a?} 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 } } #proc a? {args} { # #stdout # variable ansi_wanted # if {$ansi_wanted <= 0} { # puts -nonewline [punk::ansi::ansistripraw [::punk::ansi::a?]] # } else { # tailcall 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}] } #test - find a better place to set terminal type variable is_vt52 0 proc vt52 {{onoff {}}} { #todo - return to colour state beforehand?. support 0-15 vt52 colours? #we shouldn't have to trun off colour to enter vt52 - we should make punk::console emit correct codes variable is_vt52 if {$onoff eq ""} { return $is_vt52 } if {![string is boolean -strict $onoff]} { error "vt52 setting must be a boolean - or empty to query" } if {$is_vt52} { if {!$onoff} { puts -nonewline "\x1b<" set is_vt52 0 colour on } } else { if {$onoff} { unset_mode DECANM set is_vt52 1 colour off } else { puts -nonewline "\x1b<" #emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ } } return $is_vt52 } 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)" } } lappend PUNKARGS [list { @id -id ::punk::console::local::echo @cmd -name punk::console::local::echo -help\ "Use stty on unix, or twapi on windows to set terminal local input echo on/off - experimental" @values -min 0 -max 1 onoff -type boolean -default "" -help\ "Omit or pass empty string to query current echo state." }] proc echo {args} { set argd [punk::args::parse $args withid ::punk::console::local::echo] set onoff [dict get $argd values onoff] set is_windows [string equal "windows" $::tcl_platform(platform)] if {$onoff eq ""} { #query if {$is_windows} { package require twapi set inputstate [twapi::get_console_input_mode] return [dict get $inputstate -echoinput] } else { #counterintuitively - the human format (-a) seems more consistent across platforms than the machine readable (-g) formats #for now, quick and dirty look for echo in the list seems to work on wsl & freebsd at least. set tstate [exec stty -a] if {[lsearch $tstate echo] > 0} { return 1 } else { return 0 } } } else { if {![string is boolean -strict $onoff]} { error "::punk::console::local::echo requires boolean argument to set on or off" } if {$is_windows} { set onoff [expr {true && $onoff}] ;#ensure true,yes etc are converted to 1|0 set conh [twapi::get_console_handle stdin] twapi::modify_console_input_mode $conh -echoinput $onoff return $onoff } else { if {$onoff} { {*}[auto_execok stty] echo return 1 } else { {*}[auto_execok stty] -echo return 0 } } } } } namespace import local::set_codepage_output namespace import local::set_codepage_input lappend PUNKARGS [list { @id -id ::punk::console::show_input_response @cmd -name punk::console::show_input_response -help\ "Debug command for console queries using ANSI" @opts -terminal -default {stdin stdout} -type list -help\ "terminal (currently list of in/out channels) (todo - object?)" -expected_ms -type integer -default 500 -help\ "Number of ms to wait for response" @values -min 1 -max 1 request -type string -help\ {ANSI sequence such as \x1b\[?6n which should elicit a response by the terminal on stdin} }] proc show_input_response {args} { set argd [punk::args::parse $args withid ::punk::console::show_input_response] lassign [dict values $argd] leaders opts values received set request [dict get $values request] set inoutchannels [dict get $opts -terminal] set expected [dict get $opts -expected_ms] set capturingregex {(((.*)))$} ;#capture entire response same as response-payload set ts_start [clock millis] set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] set ts_end [clock millis] puts stderr $response set out "" dict for {k v} $response { append out "$k [ansistring VIEW $v]" \n } append out "totalms [expr {$ts_end - $ts_start}]" return $out } # -- --- --- --- --- --- --- #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}}} { if {$::punk::console::is_vt52} { error "vt52 can't perform get_cursor_pos" } #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 -terminal $inoutchannels $request $capturingregex] #some terminals fail to respond properly to \x1b\[6n but do respond to \x1b\[?6n and vice-versa :/ #todo - what? #often terminals that fail will just put the raw request code on stdin - we could detect that and then #try the other? 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 -terminal $inoutchannels $request $capturingregex] 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 -terminal $inoutchannels $request $capturingregex] return $payload } variable last_da1_result "" #TODO - 22? 28? 32? #1 132 columns #2 Printer port extension #4 Sixel extension #6 Selective erase #7 DRCS #8 UDK #9 NRCS #12 SCS extension #15 Technical character set #18 Windowing capability #21 Horizontal scrolling #23 Greek extension #24 Turkish extension #42 ISO Latin 2 character set #44 PCTerm #45 Soft key map #46 ASCII emulation #https://vt100.net/docs/vt510-rm/DA1.html # proc get_device_attributes {{inoutchannels {stdin stdout}}} { #Note the vt52 rough equivalen \x1bZ - commonly supported but probably best considered obsolete as it collides with ECMA 48 SCI Single Character Introducer #DA1 variable last_da1_result #first element in result is the terminal's architectural class 61,62,63,64.. ? #for vt100 we get things like: "ESC\[?1;0c" #for vt102 "ESC\[?6c" #set capturingregex {(.*)(\x1b\[\?6[0-9][;]*([;0-9]+)c)$} ;#must capture prefix,entire-response,response-payload set capturingregex {(.*)(\x1b\[\?([0-9]*[;0-9]+)c)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[c" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] set last_da1_result $payload return $payload } #https://vt100.net/docs/vt510-rm/DA2.html proc get_device_attributes_secondary {{inoutchannels {stdin stdout}}} { #DA2 set capturingregex {(.*)(\x1b\[\>([0-9]*[;][0-9]*[;][0-1]c))$} ;#must capture prefix,entire-response,response-payload #expect CSI > X;10|20;0|1c - docs suggest X should be something like 61. In practice we see 0 or 1 (windows) REVIEW set request "\x1b\[>c" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } proc get_device_attributes_tertiary {{inoutchannels {stdin stdout}}} { #DA3 set capturingregex {(.*)(\x1bP!\|([0-9]{8})\x1b\\)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[=c" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } proc get_terminal_id {{inoutchannels {stdin stdout}}} { #DA3 - alias get_device_attributes_tertiary $inoutchannels } 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 -terminal $inoutchannels $request $capturingregex] 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().." 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 - work out how to query terminal and set cell size in pixels #for now use the windows default variable cell_size set cell_size "" set cell_size_fallback 10x20 #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::define { @id -id ::punk::console::cell_size -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 1 newsize -default "" -help\ "character cell pixel dimensions WxH or omit to query cell size." } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] set newsize [dict get $argd values newsize] variable cell_size if {$newsize eq ""} { #query existing setting if {$cell_size eq ""} { #not set - try to query terminal's overall dimensions set pixeldict [punk::console::get_xterm_pixels $inoutchannels] lassign $pixeldict _w sw _h sh if {[string is integer -strict $sw] && [string is integer -strict $sh]} { lassign [punk::console::get_size] _cols columns _rows rows #review - is returned size in pixels always a multiple of rows and cols? set w [expr {$sw / $columns}] set h [expr {$sh / $rows}] set cell_size ${w}x${h} return $cell_size } else { set cell_size $::punk::console::cell_size_fallback puts stderr "punk::console::cell_size unable to query terminal for pixel data - using default $cell_size" return $cell_size } } return $cell_size } #newsize supplied - try to set lassign [split [string tolower $newsize] x] w h if {![string is integer -strict $w] || ![string is integer -strict $h] || $w < 1 || $h < 1} { error "punk::sixel::cell_size error - expected format WxH where W and H are positive integers - got '$newsize'" } set cell_size ${w}x${h} } punk::args::define { @id -id ::punk::console::test_is_vt52 @cmd -name punk::console::test_is_vt52 -help\ "in development.. broken" -inoutchannels -default {stdin stdout} -type list @values -min 0 -max 0 } #only works in raw mode for windows terminal - (esc in output stripped?) why? # works in line mode for alacrity and wezterm proc test_is_vt52 {args} { set argd [punk::args::get_by_id ::punk::console::test_is_vt52 $args] set inoutchannels [dict get $argd opts -inoutchannels] #ESC / K VT52 without printer #ESC / M VT52 with printer #ESC / Z VT52 emulator?? review #TODO set capturingregex {(.*)(?:(\x1b\/(Z))|(\x1b\/(K))|(\x1b\/(M))|(\x1b\[\?([0-9;]+)c))$} ;#must capture prefix,entire-response,response-payload #set capturingregex {(.*)(\x1b\[([0-9;]+)c)$} ;#must capture prefix,entire-response,response-payload set request "\x1bZ" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] #puts -->$payload<-- return [expr {$payload in {Z K M}}] } #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. #no vt52 equiv? may as well strip all vt52 from here? lassign [get_cursor_pos_list $inoutchannels] start_row start_col variable is_vt52 if {!$is_vt52} { set movefunc "punk::ansi::move" set func_coff "punk::ansi::cursor_off" set func_con "punk::ansi::cursor_on" } else { set movefunc "punk::ansi::vt52move" set func_coff "punk::ansi::cursor_off_vt52" set func_con "punk::ansi::cursor_on_vt52" } 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 [$func_coff][$movefunc 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols puts -nonewline $out [$movefunc $start_row $start_col][$func_con];flush stdout set result [list columns $cols rows $lines] } errM]} { puts -nonewline $out [$movefunc $start_row $start_col] puts -nonewline $out [$func_con] 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 -terminal $inoutchannels $request $capturingregex] lassign [split $payload {;}] rows cols return [list columns $cols rows $rows] } proc get_xterm_pixels {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[4;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[14t" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] lassign [split $payload {;}] height width return [list width $width height $height] } 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 -terminal $inoutchannels $request $capturingregex] return $payload } #Terminals generally default to LNM being reset (off) ie enter key sends a lone #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 and ) 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 -terminal $inoutchannels $request $capturingregex] return $payload } #DECRPM responses e.g: # \x1b\[?7\;1\$y # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) proc get_mode {num_or_name {inoutchannels {stdin stdout}}} { if {[string is integer -strict $num_or_name]} { set m $num_or_name } else { upvar ::punk::ansi::decmode_names decmode_names if {[dict exists $decmode_names $num_or_name]} { set m [dict get $decmode_names $num_or_name] } else { error "punk::console::get_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" } } set capturingregex [string map [list %MODE% $m] {(.*)(\x1b\[\?%MODE%;([0-9]+)\$y)$}] ;#must capture prefix,entire-response,response-payload set request "\x1b\[?$m\$p" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } proc set_mode {num_or_name {inoutchannels {stdin stdout}}} { if {[string is integer -strict $num_or_name]} { set m $num_or_name } else { upvar ::punk::ansi::decmode_names decmode_names if {[dict exists $decmode_names $num_or_name]} { set m [dict get $decmode_names $num_or_name] } else { error "punk::console::set_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" } } puts -nonewline "\x1b\[?${m}h" } proc unset_mode {num_or_name {inoutchannels {stdin stdout}}} { if {[string is integer -strict $num_or_name]} { set m $num_or_name } else { upvar ::punk::ansi::decmode_names decmode_names if {[dict exists $decmode_names $num_or_name]} { set m [dict get $decmode_names $num_or_name] } else { error "punk::console::unset_mode unrecognised mode '$num_or_name'. Known mode names: [dict keys $decmode_names]" } } puts -nonewline "\x1b\[?${m}l" } #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. #review - vertical movements (e.g /n /v will cause emit 0 to be ineffective - todo - disallow?) 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 } #On tcl9 - we could get an 'invalid or incomplete multibye or wide character' error #e.g contains surrogate pair if {[catch { puts -nonewline stdout $char_or_string } errM]} { puts stderr "test_char_width couldn't emit this string - \nerror: $errM" } 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}] } #get reported cursor position after emitting teststring. #The row is more likely to be a lie than the column #With wrapping on we should be able to test if the terminal has an inconsistency between reported width and when it actually wraps. #(but as line wrapping generally occurs based on width - we probably won't see this - just 'apparently' early wrapping due to printing mismatch with width) #unfortunately if terminal reports something like \u200B as width 1, but doesn't print it - we can't tell. (vs reporting 1 wide and printing replacement char/space) #When cursor is already at bottom of screen, scrolling will occur so rowoffset will be zero #we either need to move cursor up before test - or use alt screen ( or scroll_up then scroll_down?) #for now we will use alt screen to reduce scrolling effects - REVIEW proc test_string_cursor {teststring {emit 0}} { variable ansi_available if {!$ansi_available} { puts stderr "No ansi - cannot test char_width of '$teststring' returning [string length $test_string]" return [string length $teststring] } punk::console::enable_alt_screen punk::console::move 0 0 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_string_cursor for '[punk::ansi::ansistring VIEW $teststring]' - 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] || ![string is integer -strict $row1]} { puts stderr "test_string_cursor Could not interpret response from get_cursor_pos for initial cursor pos. Response: '[punk::ansi::ansistring VIEW $response]'" flush stderr return } puts -nonewline stdout $teststring flush stdout set response [punk::console::get_cursor_pos] lassign [split $response ";"] row2 col2 if {![string is integer -strict $col2] || ![string is integer -strict $row2]} { puts stderr "test_string_cursor 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. punk::console::disable_alt_screen return [list rowoffset [expr {$col2 - $col1}] columnoffset [expr {$row2 - $row1}]] } #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 } #ansi_available defaults to -1 (unknown) if {$ansi_available == -1} { set ansi_available [test_can_ansi] return $ansi_available } return 1 } variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested #todo - flag to retest? (for consoles where grapheme cluster support can be disabled e.g via decmode 2027) proc grapheme_cluster_support {} { variable grapheme_cluster_support if {[dict size $grapheme_cluster_support]} { return $grapheme_cluster_support } if {[info exists ::env(TERM_PROGRAM)]} { #terminals known to support grapheme clusters, but unable to respond to decmode request 2027 #wezterm (on windows as at 2024-12 decmode 2027 doesn't work) #REVIEW - what if terminal is remote wezterm? can/will this env variable # iterm and apple terminal also set TERM_PROGRAM if {[string tolower $::env(TERM_PROGRAM)] in [list wezterm]} { set is_available 1 return [dict create available 1 mode set] } } #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) set state [get_mode grapheme_clusters] ;#decmode 2027 extension set is_available 0 switch -- $state { 0 { set m unsupported ;# the dec query is unsupported - but it's possible the terminal still has grapheme support } 1 { set m set set is_available 1 } 2 { set m unset } 3 { set m permanently_set set is_available 1 } 4 { set m permanently_unset } default { set m "BAD_RESPONSE" } } return [dict create available $is_available mode $m] } #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." } } } 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 {![tsv::get console is_raw]} { set was_raw 0 enableRaw } else { set was_raw 1 } puts -nonewline stdout \033\[6n ;flush stdout chan configure 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 { variable PUNKARGS #ansi escape sequence based terminal/console control functions namespace export * #proc a {args} { # puts -nonewline [::punk::ansi::a {*}$args] #} #proc a+ {args} { # puts -nonewline [::punk::ansi::a+ {*}$args] #} #proc a? {args} { # puts -nonewline stdout [::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] } proc cursor_on {} { upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::cursor_on] } else { puts -nonewline stdout [punk::ansi::cursor_on_vt52] } } proc cursor_off {} { upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::cursor_off] } else { puts -nonewline stdout [punk::ansi::cursor_off_vt52] } } lappend PUNKARGS [list { @id -id ::punk::console::ansi::move @cmd -name punk::console::move -help\ {Return an ANSI or vt52 sequence to move cursor to row,col (aka: cursor home) The sequence emitted will depend on the mode of the terminal as stored in the consolehandle. Directly setting the mode via raw escape sequences: e.g unset_mode DECANM for vt52 or puts \x1b< to return to ANSI will not necessarily update the application of the change in terminal state. Major state changes such as this should be done via provided functions that keep the REPL state in sync with the underlying terminal state. For ANSI the sequence is of the form: ESC[;H (CSI row ; col H) This sequence will generally not be understood by terminals that are in vt52 mode. For VT52 the sequence is of the form: ESCY This sequence will generally not be understood by terminals that are not in vt52 mode even if higher modes are supported. } @values -min 2 -max 2 row -type integer -help\ "row number - starting at 1" col -type integer -help\ "column number - starting at 1" }] proc move {row col} { upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { return [punk::ansi::move $row $col] } else { return [punk::ansi::vt52move $row $col] } } proc move_forward {n} { upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_forward $n] } else { puts -nonewline stdout [punk::ansi::vt52move_forward $n] } } proc move_back {n} { upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_back $n] } else { puts -nonewline stdout [punk::ansi::vt52move_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} { upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_column $col] } else { puts -nonewline stdout [punk::ansi::vt52move_column $col] } } proc move_row {row} { puts -nonewline stdout [punk::ansi::move_row $row] } proc move_emit {row col data args} { upvar ::punk::console::is_v52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] } else { puts -nonewline stdout [punk::ansi::v52move_emit $row $col $data {*}$args] } } 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 {*}$args] foreach {row col data} $args { append commands [punk::ansi::move_emit $row $col $data {*}$args] } if {!$is_in_raw} { incr orig_row -1 } append commands [punk::ansi::move $orig_row $orig_col] puts -nonewline stdout $commands return "" } 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 } #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} { upvar ::punk::console::is_vt52 is_vt52 #JMN set commands "" if {!$is_vt52} { 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] } else { append commands [punk::ansi::cursor_save_vt52] append commands [punk::ansi::vt52move_emit $row $col $data] foreach {row col data} $args { append commands [punk::ansi::vt52move_emit $row $col $data] } append commands [punk::ansi::cursor_restore_vt52] } puts -nonewline stdout $commands; flush stdout } proc cursorsave_move_emitblock_return {row col textblock} { set commands "" upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { 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] } else { append commands [punk::ansi::cursor_save_vt52] foreach ln [split $textblock \n] { append commands [punk::ansi::vt52move_emit $row $col $ln] incr row } append commands [punk::ansi::cursor_restore_vt52] } 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 } 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 } proc titleset {windowtitle} { puts -nonewline stdout [punk::ansi::titleset $windowtitle] } proc test_decaln {} { puts -nonewline stdout [punk::ansi::test_decaln] } } namespace import ::punk::console::ansi::* catch {rename titleset ""} #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] } foreach ansicmd [list ::punk::console::ansi::move] { set ctail [namespace tail $ansicmd] set arglist [info args $ansicmd] set argcall "" if {[llength $arglist]} { foreach a [lrange $arglist 0 end-1] { append argcall "\$$a " } if {[lindex $arglist end] eq "args"} { append argcall {{*}$args} } else { append argcall "\$[lindex $arglist end]" } } catch {rename $ctail ""} proc $ctail $arglist [string map [list %ansicmd% $ansicmd %argcall% $argcall] { puts -nonewline [%ansicmd% %argcall%] }] } #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 } #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 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 equal [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 ---}] } namespace eval punk::console::check { variable has_bug_legacysymbolwidth -1 ;#undetermined proc has_bug_legacysymbolwidth {} { #some terminals (on windows as at 2024) miscount width of these single-width blocks internally #resulting in extra spacing that is sometimes well removed from the character itself (e.g at next ansi reset) #This was fixed in windows-terminal based systems (2021) but persists in others. #https://github.com/microsoft/terminal/issues/11694 variable has_bug_legacysymbolwidth if {!$has_bug_legacysymbolwidth} { return 0 } if {$has_bug_legacysymbolwidth == -1} { #run the test using ansi movement #we only test a specific character from the known problematic set set w [punk::console::test_char_width \U1fb7d] if {$w == 1} { set has_bug_legacysymbolwidth 0 } else { #can return 2 on legacy window consoles for example set has_bug_legacysymbolwidth 1 } return $has_bug_legacysymbolwidth } return 1 } variable has_bug_zwsp -1 ;#undetermined proc has_bug_zwsp {} { #Note that some terminals behave differently regarding a leading zwsp vs one that is inline between other chars. #we are only testing the inline behaviour here. variable has_bug_zwsp if {!$has_bug_zwsp} { return 0 } if {$has_bug_zwsp == -1} { set w [punk::console::test_char_width X\u200bY] } if {$w == 2} { return 0 } else { #may return 3 - but this gives no indication of whether terminal hides it or not. return 1 } return 1 } } namespace eval ::punk::args::register { #use fully qualified so 8.6 doesn't find existing var in global namespace lappend ::punk::args::register::NAMESPACES ::punk::console ::punk::console::internal ::punk::console::local ::punk::console::ansi } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::console [namespace eval punk::console { variable version set version 0.1.1 }] return #*** !doctools #[manpage_end]