19 changed files with 7320 additions and 16571 deletions
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,465 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||
# |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2009 Jose F. Nieves |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::sshrun 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license ISC |
||||
# @@ Meta End |
||||
|
||||
# Copyright (c) 2009 Jose F. Nieves <nieves@ltp.uprrp.edu> |
||||
# |
||||
# Permission to use, copy, modify, and distribute this software for any |
||||
# purpose with or without fee is hereby granted, provided that the above |
||||
# copyright notice and this permission notice appear in all copies. |
||||
# |
||||
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES |
||||
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF |
||||
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR |
||||
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES |
||||
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN |
||||
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF |
||||
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin shellspy_module_punk::sshrun 0 999999.0a1.0] |
||||
#[copyright "2009"] |
||||
#[titledesc {Tcl procedures to execute tcl scripts in remote hosts}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {punk::sshrun tclssh clone}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::sshrun] |
||||
#[keywords module ssh] |
||||
#[description] |
||||
#[para] This is a clone of tclssh by Jose F. Nieves |
||||
#[para] The original repo is at: https://bitbucket.org/noaaport/tclssh/src/master/ |
||||
#[para] This version is namespaced under punk::sshrun specifically for the Punk shell project - and may lag the original project or diverge. |
||||
#[para] You are encouraged to use the original Tclssh source from the above URL for your own projects |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::sshrun |
||||
#[para] SYNOPSIS |
||||
#[para] package require punk::sshrun |
||||
#[para] - |
||||
#[para] punk::sshrun::connect [lb]-t <tclsh_name>[rb] [lb]-- <ssh_options>[rb] [lb]<user>@[rb]<host> |
||||
#[para] Defaults: -t tclsh |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::sshrun |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6 |
||||
package require cmdline |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package {cmdline}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::sshrun::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::sshrun::class}] |
||||
#[para] class definitions |
||||
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::sshrun { |
||||
namespace export * |
||||
|
||||
variable ssh; |
||||
array set ssh {}; |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::sshrun}] |
||||
#[para] Core API functions for punk::sshrun |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
proc connect {args} { |
||||
#*** !doctools |
||||
#[call connect [arg args]] |
||||
#[para] Must be called first. |
||||
#[para] This proc opens an io channel to the tclsh in the remote host (via ssh) that is kept in an internal variable for subsequent use. |
||||
#[para] The file handle can be retrieved if desired through the command: get_filehandle {host} |
||||
variable ssh; |
||||
|
||||
set usage {connect [-t <tclsh_name>] [-- <ssh_options>] |
||||
[<user>@]<host>}; |
||||
set optlist {{t.arg "tclsh"}}; |
||||
|
||||
array set option [::cmdline::getoptions args $optlist $usage]; |
||||
set cmd [concat "|ssh" $args $option(t) 2>@ stdout]; |
||||
set F [open $cmd r+]; |
||||
|
||||
set host [lindex $args end]; |
||||
if {[regexp {(.*)@(.*)} $host match s1 s2]} { |
||||
set user $s1; |
||||
set host $s2; |
||||
} |
||||
|
||||
# These are the only internal variables (apart from the "user" variables). |
||||
set ssh($host,F) $F; |
||||
set ssh($host,script) [list]; |
||||
} |
||||
|
||||
proc disconnect {host} { |
||||
#*** !doctools |
||||
# [call disconnect [arg host]] |
||||
# [para] Must be called last. Closes the filehandle opened by connect. |
||||
variable ssh; |
||||
|
||||
system::_verify_connection $host; |
||||
set status [catch { |
||||
close $ssh($host,F); |
||||
} errmsg]; |
||||
|
||||
unset ssh($host,F); |
||||
unset ssh($host,script); |
||||
|
||||
if {$status != 0} { |
||||
return -code error $errmsg; |
||||
} |
||||
} |
||||
|
||||
proc push {host script} { |
||||
#*** !doctools |
||||
# [call push [arg host] [arg script]] |
||||
# [para] <script> can be any tcl code. |
||||
# [para] For example, if the remote host is named "diablo" |
||||
# [example { |
||||
# ssh::push "diablo" "exec date" |
||||
# ssh::push "diablo" "exec uname -a" |
||||
# }] |
||||
# [para] The commands are note executed immediately. Instead, the "push" proc simply accumulates them in a list that is sent to the host when the "send" procedure is executed. |
||||
# [para] Each push proc inserts the newline '\n' character after each <script> |
||||
# [para] In the above example. Internally, each <script> is a member of a list, and when the "send" proc is invoked the entire script is constructed as a "join <list> \n |
||||
|
||||
variable ssh; |
||||
system::_verify_connection $host; |
||||
lappend ssh($host,script) $script; |
||||
} |
||||
|
||||
proc send {host} { |
||||
#*** !doctools |
||||
# [call send [arg host]] |
||||
# [para]This proc does the equivalent of a |
||||
# [example { |
||||
# puts <filehandle> [join <script_list> \n] |
||||
# flush <filehandle> |
||||
# }] |
||||
variable ssh; |
||||
system::_verify_connection $host; |
||||
|
||||
set status [catch { |
||||
puts $ssh($host,F) [join $ssh($host,script) "\n"]; |
||||
flush $ssh($host,F); |
||||
} errmsg]; |
||||
|
||||
set ssh($host,script) [list]; |
||||
|
||||
if {$status != 0} { |
||||
return -code error $errmsg; |
||||
} |
||||
} |
||||
proc send_exit {host} { |
||||
#*** !doctools |
||||
# [call send_exit [arg host]] |
||||
# [para] This proc is similar to the above, but it "pushes" an exit command at the end of the script. The proc does the equivalent of |
||||
# [example { |
||||
# ssh::push <host> "exit" |
||||
# ssh::send <host> |
||||
# }] |
||||
# [para] The net effect if this is that the remote host's tclsh will exit, so that the filehandle receives an eof and we can use |
||||
# [example { |
||||
# [read <filehandle>] |
||||
# }] |
||||
# [para]to read the entire output at once (see the pop proc below) |
||||
|
||||
push $host "exit"; |
||||
send $host; |
||||
} |
||||
|
||||
proc pop_line {host line_varname} { |
||||
#*** !doctools |
||||
# [call pop_line [arg host] [arg line_varname]] |
||||
# [para]After executing a "send", this can be used to read one line of output. The proc does the equivalent of |
||||
# [example { |
||||
# [gets <filehandle> line] |
||||
# }] |
||||
upvar $line_varname line; |
||||
variable ssh; |
||||
|
||||
system::_verify_connection $host; |
||||
set r [gets $ssh($host,F) line]; |
||||
return $r; |
||||
} |
||||
|
||||
proc pop_all {host output_varname} { |
||||
#*** !doctools |
||||
# [call pop_all [arg host] [arg output_varname]] |
||||
# [para]This proc does the equivalent of |
||||
# [example { |
||||
# while {[pop_line $host line] >=0} { |
||||
# puts $line; |
||||
# } |
||||
# }] |
||||
# [para] but all the output is returned as one string in output_varname. |
||||
# [para]It should be used only when we know that the remote host's tclsh will exit, so that the above code will detect the eof and exit |
||||
# [para](see the send_exit proc above) |
||||
# [para]The function returns the number of lines read (0 if nothing is read before encoutering eof) |
||||
# |
||||
upvar $output_varname output; |
||||
variable ssh; |
||||
|
||||
system::_verify_connection $host; |
||||
|
||||
set r 0; |
||||
set output_list [list]; |
||||
while {[pop_line $host line] >= 0} { |
||||
incr r; |
||||
lappend output_list $line; |
||||
} |
||||
set output [join $output_list "\n"]; |
||||
|
||||
return $r; |
||||
} |
||||
proc pop_read {host numbytes output_varname} { |
||||
#*** !doctools |
||||
# [call pop_read [arg host] [arg numbytes] [arg output_varname]] |
||||
# [para] Returns: numbytes read. If numbytes is not positive, then read is called without the numbytes argument. |
||||
upvar $output_varname output; |
||||
variable ssh; |
||||
|
||||
system::_verify_connection $host; |
||||
|
||||
if {$numbytes <= 0} { |
||||
set output [read $ssh($host,F)]; |
||||
} else { |
||||
set output [read $ssh($host,F) $numbytes]; |
||||
} |
||||
|
||||
return [string length $output]; |
||||
} |
||||
|
||||
proc hfileevent {host readable_writable script} { |
||||
#*** !doctools |
||||
# [call hfileevent [arg host] [arg readable_writable] [arg script]] |
||||
# [para] Equivalent to: |
||||
# [example { |
||||
# fileevent <filehandle> $readable_writable $script |
||||
# }] |
||||
variable ssh; |
||||
system::_verify_connection $host; |
||||
fileevent $ssh($host,F) $readable_writable $script; |
||||
} |
||||
|
||||
proc hfconfigure {host args} { |
||||
#*** !doctools |
||||
# [call hconfigure [arg host] [arg args]] |
||||
variable ssh; |
||||
system::_verify_connection $host; |
||||
eval fconfigure $ssh($host,F) $args; |
||||
} |
||||
|
||||
proc rexec {host script output_varname} { |
||||
#*** !doctools |
||||
# [call rexec [arg host] [arg script] [arg output_varname]] |
||||
# [para] shortcut for: |
||||
# [example { |
||||
# ssh::rexec_nopop $host $script |
||||
# ssh::pop_all $host outputvar |
||||
# }] |
||||
upvar $output_varname output; |
||||
rexec_nopop $host $script; |
||||
pop_all $host output; |
||||
} |
||||
|
||||
proc rexec_nopop {host script} { |
||||
push $host $script; |
||||
send_exit $host; |
||||
} |
||||
|
||||
# |
||||
# Utility |
||||
# |
||||
proc set_var {host var val} { |
||||
variable ssh; |
||||
# These functions can be used even when there is no valid connection |
||||
# and therefore we do not call _verify_connection here. |
||||
set ssh($host,user,$var) $val; |
||||
} |
||||
|
||||
proc get_var {host var} { |
||||
variable ssh; |
||||
if {[info exists ssh($host,user,$var)] == 0} { |
||||
return -code error "$var not defined"; |
||||
} |
||||
return $ssh($host,user,$var); |
||||
} |
||||
|
||||
proc incr_var {host var {step 1}} { |
||||
variable ssh; |
||||
if {[info exists ssh($host,user,$var)] == 0} { |
||||
return -code error "$var not defined"; |
||||
} |
||||
puts "incr ssh($host,user,$var) by $step"; |
||||
incr ssh($host,user,$var) $step; |
||||
} |
||||
|
||||
proc set_lvar {var val} { |
||||
set host "localhost"; |
||||
set_var $host $var $val; |
||||
} |
||||
|
||||
proc get_lvar {var} { |
||||
set host "localhost"; |
||||
set status [catch { |
||||
set r [get_var $host $var]; |
||||
} errmsg]; |
||||
|
||||
if {$status != 0} { |
||||
return -code error $errmsg; |
||||
} |
||||
return $r; |
||||
} |
||||
|
||||
proc incr_lvar {var {step 1}} { |
||||
set host "localhost"; |
||||
incr_var $host $var $step; |
||||
} |
||||
|
||||
# |
||||
# low level |
||||
# |
||||
proc get_filehandle {host} { |
||||
#*** !doctools |
||||
# [call get_filehandle [arg host]] |
||||
variable ssh; |
||||
system::_verify_connection $host; |
||||
|
||||
return $ssh($host,F); |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::sshrun ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::sshrun::lib { |
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::sshrun::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::sshrun::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval punk::sshrun::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::sshrun::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
# |
||||
# private |
||||
# |
||||
proc _verify_connection {host} { |
||||
upvar ::punk::sshrun::ssh ssh |
||||
#variable ssh; |
||||
if {[info exists ssh($host,F)]} { |
||||
return 1; |
||||
} |
||||
return -code error "There is no connection to $host."; |
||||
} |
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::sshrun [namespace eval punk::sshrun { |
||||
variable pkg punk::sshrun |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
@ -1,963 +0,0 @@
|
||||
# -*- 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) Julian Noble 2003-2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application overtype 1.5.1 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin overtype_module_overtype 0 1.5.1] |
||||
#[copyright "2024"] |
||||
#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] |
||||
#[require overtype] |
||||
#[keywords module text ansi] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of overtype |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by overtype |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6 |
||||
package require textutil |
||||
package require punk::ansi ;#required to detect, split, strip and calculate lengths |
||||
package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package textutil] |
||||
#[item] [package punk::ansi] |
||||
#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes |
||||
#[item] [package punk::char] |
||||
#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
#Julian Noble <julian@precisium.com.au> - 2003 |
||||
#Released under standard 'BSD license' conditions. |
||||
# |
||||
#todo - ellipsis truncation indicator for center,right |
||||
|
||||
#v1.4 2023-07 - naive ansi color handling - todo - fix string range |
||||
# - need to extract and replace ansi codes? |
||||
|
||||
namespace eval overtype { |
||||
namespace export * |
||||
variable default_ellipsis_horizontal "..." ;#fallback |
||||
variable default_ellipsis_vertical "..." |
||||
namespace eval priv { |
||||
proc _init {} { |
||||
upvar ::overtype::default_ellipsis_horizontal e_h |
||||
upvar ::overtype::default_ellipsis_vertical e_v |
||||
set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis |
||||
set e_v [format %c 0x22EE] |
||||
#The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text |
||||
#Also - unicode ellipsis has semantic meaning that other processors can interpret |
||||
#unicode does also provide a midline horizontal ellipsis 0x22EF |
||||
|
||||
#set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal |
||||
#if {![catch {package require punk::char}]} { |
||||
# set e [punk::char::charshort boxd_ltdshhz] |
||||
#} |
||||
} |
||||
} |
||||
priv::_init |
||||
} |
||||
proc overtype::about {} { |
||||
return "Simple text formatting. Author JMN. BSD-License" |
||||
} |
||||
|
||||
namespace eval overtype { |
||||
variable escape_terminals |
||||
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). |
||||
dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] |
||||
#dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic |
||||
dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals |
||||
|
||||
#self-contained 2 byte ansi escape sequences - review more? |
||||
variable ansi_2byte_codes_dict |
||||
set ansi_2byte_codes_dict [dict create\ |
||||
"reset_terminal" "\u001bc"\ |
||||
"save_cursor_posn" "\u001b7"\ |
||||
"restore_cursor_posn" "\u001b8"\ |
||||
"cursor_up_one" "\u001bM"\ |
||||
"NEL - Next Line" "\u001bE"\ |
||||
"IND - Down one line" "\u001bD"\ |
||||
"HTS - Set Tab Stop" "\u001bH"\ |
||||
] |
||||
|
||||
#debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. |
||||
# "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ |
||||
} |
||||
|
||||
|
||||
#proc overtype::stripansi {text} { |
||||
# variable escape_terminals ;#dict |
||||
# variable ansi_2byte_codes_dict |
||||
# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway |
||||
# if {[string first \033 $text] <0 && [string first \009c $text] <0} { |
||||
# #\033 same as \x1b |
||||
# return $text |
||||
# } |
||||
# |
||||
# set text [convert_g0 $text] |
||||
# |
||||
# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. |
||||
# #line endings can theoretically occur within an ansi escape sequence (review e.g title?) |
||||
# set inputlist [split $text ""] |
||||
# set outputlist [list] |
||||
# |
||||
# set 2bytecodes [dict values $ansi_2byte_codes_dict] |
||||
# |
||||
# set in_escapesequence 0 |
||||
# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls |
||||
# set i 0 |
||||
# foreach u $inputlist { |
||||
# set v [lindex $inputlist $i+1] |
||||
# set uv ${u}${v} |
||||
# if {$in_escapesequence eq "2b"} { |
||||
# #2nd byte - done. |
||||
# set in_escapesequence 0 |
||||
# } elseif {$in_escapesequence != 0} { |
||||
# set escseq [dict get $escape_terminals $in_escapesequence] |
||||
# if {$u in $escseq} { |
||||
# set in_escapesequence 0 |
||||
# } elseif {$uv in $escseq} { |
||||
# set in_escapseequence 2b ;#flag next byte as last in sequence |
||||
# } |
||||
# } else { |
||||
# #handle both 7-bit and 8-bit CSI and OSC |
||||
# if {[regexp {^(?:\033\[|\u009b)} $uv]} { |
||||
# set in_escapesequence CSI |
||||
# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { |
||||
# set in_escapesequence OSC |
||||
# } elseif {$uv in $2bytecodes} { |
||||
# #self-contained e.g terminal reset - don't pass through. |
||||
# set in_escapesequence 2b |
||||
# } else { |
||||
# lappend outputlist $u |
||||
# } |
||||
# } |
||||
# incr i |
||||
# } |
||||
# return [join $outputlist ""] |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc overtype::string_columns {text} { |
||||
if {[punk::ansi::ta::detect $text]} { |
||||
error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length" |
||||
} |
||||
return [punk::char::string_width $text] |
||||
} |
||||
|
||||
|
||||
#string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r |
||||
proc overtype::left {args} { |
||||
# @c overtype starting at left (overstrike) |
||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
||||
variable default_ellipsis_horizontal |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
||||
} |
||||
lassign [lrange $args end-1 end] underblock overblock |
||||
set defaults [dict create\ |
||||
-ellipsis 0\ |
||||
-ellipsistext $default_ellipsis_horizontal\ |
||||
-overflow 0\ |
||||
-transparent 0\ |
||||
-exposed1 \uFFFD\ |
||||
-exposed2 \uFFFD\ |
||||
] |
||||
set known_opts [dict keys $defaults] |
||||
set argsflags [lrange $args 0 end-2] |
||||
dict for {k v} $argsflags { |
||||
if {$k ni $known_opts} { |
||||
error "overtype::left unknown option '$k'. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $argsflags] |
||||
# -- --- --- --- --- --- |
||||
set opt_transparent [dict get $opts -transparent] |
||||
set opt_ellipsistext [dict get $opts -ellipsistext] |
||||
set opt_exposed1 [dict get $opts -exposed1] |
||||
set opt_exposed2 [dict get $opts -exposed2] |
||||
# -- --- --- --- --- --- |
||||
|
||||
set norm [list \r\n \n] |
||||
set underblock [string map $norm $underblock] |
||||
set overblock [string map $norm $overblock] |
||||
|
||||
set underlines [split $underblock \n] |
||||
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] |
||||
set overlines [split $overblock \n] |
||||
|
||||
set outputlines [list] |
||||
foreach undertext $underlines overtext $overlines { |
||||
set undertext_printlen [punk::ansi::printing_length $undertext] |
||||
set overlen [punk::ansi::printing_length $overtext] |
||||
set diff [expr {$overlen - $colwidth}] |
||||
|
||||
#review |
||||
#append overtext "\033\[0m" |
||||
|
||||
if {$diff > 0} { |
||||
#background line is narrower |
||||
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow [dict get $opts -overflow] $undertext $overtext] |
||||
if {![dict get $opts -overflow]} { |
||||
#set overtext [string range $overtext 0 $colwidth-1] ;#string range won't be correct e.g if contains ansi codes or leading \r or \b etc |
||||
if {[dict get $opts -ellipsis]} { |
||||
set rendered [overtype::right $rendered $opt_ellipsistext] |
||||
} |
||||
} |
||||
lappend outputlines $rendered |
||||
} else { |
||||
#we know overtext is shorter or equal |
||||
lappend outputlines [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] |
||||
} |
||||
} |
||||
return [join $outputlines \n] |
||||
|
||||
} |
||||
|
||||
namespace eval overtype::piper { |
||||
proc overcentre {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-bias left|right? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata} |
||||
} |
||||
lassign [lrange $args end-1 end] over under |
||||
set argsflags [lrange $args 0 end-2] |
||||
tailcall overtype::centre {*}$argsflags $under $over |
||||
} |
||||
proc overleft {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-start <column>? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata} |
||||
} |
||||
lassign [lrange $args end-1 end] over under |
||||
set argsflags [lrange $args 0 end-2] |
||||
tailcall overtype::left {*}$argsflags $under $over |
||||
} |
||||
} |
||||
#todo - left-right ellipsis ? |
||||
proc overtype::centre {args} { |
||||
variable default_ellipsis_horizontal |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
|
||||
foreach {underblock overblock} [lrange $args end-1 end] break |
||||
|
||||
set defaults [dict create\ |
||||
-bias left\ |
||||
-ellipsis 0\ |
||||
-ellipsistext $default_ellipsis_horizontal\ |
||||
-overflow 0\ |
||||
-transparent 0\ |
||||
-exposed1 \uFFFD\ |
||||
-exposed2 \uFFFD\ |
||||
] |
||||
set known_opts [dict keys $defaults] |
||||
set argsflags [lrange $args 0 end-2] |
||||
dict for {k v} $argsflags { |
||||
if {$k ni $known_opts} { |
||||
error "overtype::centre unknown option '$k'. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $argsflags] |
||||
# -- --- --- --- --- --- |
||||
set opt_transparent [dict get $opts -transparent] |
||||
set opt_ellipsistext [dict get $opts -ellipsistext] |
||||
set opt_exposed1 [dict get $opts -exposed1] |
||||
set opt_exposed2 [dict get $opts -exposed2] |
||||
# -- --- --- --- --- --- |
||||
|
||||
|
||||
set norm [list \r\n \n] |
||||
set underblock [string map $norm $underblock] |
||||
set overblock [string map $norm $overblock] |
||||
|
||||
set underlines [split $underblock \n] |
||||
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] |
||||
set overlines [split $overblock \n] |
||||
set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] |
||||
|
||||
set outputlines [list] |
||||
foreach undertext $underlines overtext $overlines { |
||||
#set olen [punk::ansi::printing_length $overtext] |
||||
set ulen [punk::ansi::printing_length $undertext] |
||||
if {$ulen < $colwidth} { |
||||
set udiff [expr {$colwidth - $ulen}] |
||||
set undertext "$undertext[string repeat { } $udiff]" |
||||
} |
||||
#review |
||||
#append overtext "\033\[0m" |
||||
|
||||
set under_exposed [expr {$colwidth - $overblock_width}] |
||||
if {$under_exposed > 0} { |
||||
#background block is wider |
||||
if {$under_exposed % 2 == 0} { |
||||
#even left/right exposure |
||||
set left_exposed [expr {$under_exposed / 2}] |
||||
} else { |
||||
set beforehalf [expr {$under_exposed / 2}] ;#1 less than half due to integer division |
||||
if {[string tolower [dict get $opts -bias]] eq "left"} { |
||||
set left_exposed $beforehalf |
||||
} else { |
||||
#bias to the right |
||||
set left_exposed [expr {$beforehalf + 1}] |
||||
} |
||||
} |
||||
|
||||
if 0 { |
||||
set rhs [expr {$diff - $half - 1}] |
||||
set lhs [expr {$half - 1}] |
||||
set rhsoffset [expr {$rhs +1}] |
||||
set a [string range $undertext 0 $lhs] |
||||
set background [string range $undertext $lhs+1 end-$rhsoffset] |
||||
set b [renderline -transparent $opt_transparent $background $overtext] |
||||
set c [string range $undertext end-$rhs end] |
||||
lappend outputlines $a$b$c |
||||
} |
||||
lappend outputlines [renderline -start $left_exposed -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] |
||||
|
||||
} else { |
||||
#overlay wider or equal |
||||
set rendered [renderline -transparent $opt_transparent -overflow [dict get $opts -overflow] $undertext $overtext] |
||||
if {$under_exposed < 0} { |
||||
#overlay is wider - trim if overflow not specified in opts |
||||
if {![dict get $opts -overflow]} { |
||||
#lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]] |
||||
#set overtext [string range $overtext 0 $colwidth-1 ] |
||||
if {[dict get $opts -ellipsis]} { |
||||
set rendered [overtype::right $rendered $opt_ellipsistext] |
||||
} |
||||
} |
||||
} else { |
||||
#zero under_exposed - widths match |
||||
} |
||||
lappend outputlines $rendered |
||||
#lappend outputlines [renderline -transparent $opt_transparent $undertext $overtext] |
||||
} |
||||
} |
||||
return [join $outputlines \n] |
||||
} |
||||
|
||||
proc overtype::right {args} { |
||||
variable default_ellipsis_horizontal |
||||
# @d !todo - implement overflow, length checks etc |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {underblock overblock} [lrange $args end-1 end] break |
||||
|
||||
set defaults [dict create\ |
||||
-bias left\ |
||||
-ellipsis 0\ |
||||
-ellipsistext $default_ellipsis_horizontal\ |
||||
-overflow 0\ |
||||
-transparent 0\ |
||||
-exposed1 \uFFFD\ |
||||
-exposed2 \uFFFD\ |
||||
] |
||||
set known_opts [dict keys $defaults] |
||||
set argsflags [lrange $args 0 end-2] |
||||
dict for {k v} $argsflags { |
||||
if {$k ni $known_opts} { |
||||
error "overtype::centre unknown option '$k'. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $argsflags] |
||||
# -- --- --- --- --- --- |
||||
set opt_transparent [dict get $opts -transparent] |
||||
set opt_ellipsis [dict get $opts -ellipsis] |
||||
set opt_ellipsistext [dict get $opts -ellipsistext] |
||||
set opt_overflow [dict get $opts -overflow] |
||||
set opt_exposed1 [dict get $opts -exposed1] |
||||
set opt_exposed2 [dict get $opts -exposed2] |
||||
# -- --- --- --- --- --- |
||||
|
||||
set norm [list \r\n \n] |
||||
set underblock [string map $norm $underblock] |
||||
set overblock [string map $norm $overblock] |
||||
|
||||
set underlines [split $underblock \n] |
||||
set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] |
||||
set overlines [split $overblock \n] |
||||
|
||||
set outputlines [list] |
||||
foreach undertext $underlines overtext $overlines { |
||||
set olen [punk::ansi::printing_length $overtext] |
||||
set ulen [punk::ansi::printing_length $undertext] |
||||
if {$ulen < $colwidth} { |
||||
set udiff [expr {$colwidth - $ulen}] |
||||
set undertext "$undertext[string repeat { } $udiff]" |
||||
} |
||||
#review |
||||
#append overtext "\033\[0m" |
||||
|
||||
set overflowlength [expr {$olen - $colwidth}] |
||||
if {$overflowlength > 0} { |
||||
#overtext wider than undertext column |
||||
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -start 0 $undertext $overtext] |
||||
if {!$opt_overflow} { |
||||
if {$opt_ellipsis} { |
||||
set rendered [overtype::right $rendered $opt_ellipsistext] |
||||
} |
||||
} |
||||
lappend outputlines $rendered |
||||
} else { |
||||
#lappend outputlines [string range $undertext 0 end-$olen]$overtext |
||||
lappend outputlines [renderline -transparent $opt_transparent -start [expr {$colwidth - $olen}] $undertext $overtext] |
||||
} |
||||
} |
||||
|
||||
return [join $outputlines \n] |
||||
} |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- |
||||
proc overtype::transparentline {args} { |
||||
foreach {under over} [lrange $args end-1 end] break |
||||
set argsflags [lrange $args 0 end-2] |
||||
set defaults [dict create\ |
||||
-transparent 1\ |
||||
-exposed 1 " "\ |
||||
-exposed 2 " "\ |
||||
] |
||||
set newargs [dict merge $defaults $argsflags] |
||||
tailcall overtype::renderline {*}$newargs $under $over |
||||
} |
||||
#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. |
||||
# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. |
||||
#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. |
||||
# |
||||
namespace eval overtype::piper { |
||||
proc renderline {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? overtext pipelinedata} |
||||
} |
||||
foreach {over under} [lrange $args end-1 end] break |
||||
set argsflags [lrange $args 0 end-2] |
||||
tailcall overtype::renderline {*}$argsflags $under $over |
||||
} |
||||
} |
||||
interp alias "" piper_renderline "" overtype::piper::renderline |
||||
|
||||
#-returnextra to enable returning of overflow and length |
||||
# todo - use punk::ansi::ta::detect to short-circuit processing and do simple string calcs as an optimisation? |
||||
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements |
||||
#todo - review transparency issues with single/double width characters! |
||||
proc overtype::renderline {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
lassign [lrange $args end-1 end] under over |
||||
if {[string first \n $under] >=0 || [string first \n $over] >= 0} { |
||||
error "overtype::renderline not allowed to contain newlines" |
||||
} |
||||
set defaults [dict create\ |
||||
-overflow 0\ |
||||
-transparent 0\ |
||||
-start 0\ |
||||
-returnextra 0\ |
||||
-exposed1 \uFFFD\ |
||||
-exposed2 \uFFFD\ |
||||
] |
||||
#exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow |
||||
|
||||
set known_opts [dict keys $defaults] |
||||
set argsflags [lrange $args 0 end-2] |
||||
dict for {k v} $argsflags { |
||||
if {$k ni $known_opts} { |
||||
error "overtype::renderline unknown option '$k'. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $argsflags] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_overflow [dict get $opts -overflow] |
||||
set opt_colstart [dict get $opts -start] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_transparent [dict get $opts -transparent] |
||||
if {$opt_transparent eq "0"} { |
||||
set do_transparency 0 |
||||
} else { |
||||
set do_transparency 1 |
||||
if {$opt_transparent eq "1"} { |
||||
set opt_transparent {[\s]} |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_returnextra [dict get $opts -returnextra] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_exposed1 [dict get $opts -exposed1] |
||||
set opt_exposed2 [dict get $opts -exposed2] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
#----- |
||||
# |
||||
if {[string first \t $under] >= 0} { |
||||
#set under [textutil::tabify::untabify2 $under] |
||||
set under [textutil::tabify::untabifyLine $under 8] ;#8 is default for untabify2 - review |
||||
} |
||||
set overdata $over |
||||
if {[string first \t $over] >= 0} { |
||||
#set overdata [textutil::tabify::untabify2 $over] |
||||
set overdata [textutil::tabify::untabifyLine $over 8] |
||||
} |
||||
#------- |
||||
|
||||
#ta_detect ansi and do simpler processing? |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- |
||||
set undermap [punk::ansi::ta::split_codes_single $under] |
||||
set understacks [dict create] |
||||
|
||||
set i_u -1 |
||||
set i_o 0 |
||||
set out [list] |
||||
set u_codestack [list] |
||||
set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation |
||||
set remainder [list] ;#for returnextra |
||||
foreach {pt code} $undermap { |
||||
#pt = plain text |
||||
append pt_underchars $pt |
||||
foreach ch [split $pt ""] { |
||||
set width [punk::char::string_width $ch] |
||||
incr i_u |
||||
dict set understacks $i_u $u_codestack |
||||
lappend out $ch |
||||
if {$width > 1} { |
||||
#presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) |
||||
incr i_u |
||||
dict set understacks $i_u $u_codestack |
||||
lappend out "" |
||||
} |
||||
} |
||||
#underlay should already have been rendered and not have non-sgr codes - but let's check for and not stack them if other codes are here |
||||
if {[priv::is_sgr $code]} { |
||||
if {[priv::has_sgr_leadingreset $code]} { |
||||
set u_codestack [list $code] |
||||
} else { |
||||
lappend u_codestack $code |
||||
} |
||||
} |
||||
#consider also other codes that should be stacked..? |
||||
} |
||||
#trailing codes in effect for underlay |
||||
if {[llength $undermap]} { |
||||
dict set understacks [expr {$i_u + 1}] $u_codestack |
||||
} |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- |
||||
#### |
||||
#if opt_colstart - we need to build a space (or any singlewidth char really) padding on the left of the right number of columns. |
||||
#this will be processed as transparent - and handle doublewidth underlay characters appropriately |
||||
set startpad [string repeat " " $opt_colstart] |
||||
append startpad $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency |
||||
set overmap [punk::ansi::ta::split_codes_single $startpad] |
||||
#### |
||||
|
||||
|
||||
|
||||
set overstacks [dict create] |
||||
set o_codestack [list] |
||||
set pt_overchars "" |
||||
foreach {pt code} $overmap { |
||||
append pt_overchars $pt |
||||
foreach ch [split $pt ""] { |
||||
dict set overstacks $i_o $o_codestack |
||||
incr i_o |
||||
} |
||||
if {[priv::is_sgr $code]} { |
||||
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc |
||||
if {[priv::has_sgr_leadingreset $code]} { |
||||
#m code which has sgr reset at start - no need to replay prior sgr codes |
||||
set o_codestack [list $code] |
||||
} else { |
||||
lappend o_codestack $code |
||||
} |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
|
||||
|
||||
set bs [format %c 0x08] |
||||
set idx 0 ;# line index (cursor - 1) |
||||
set idx_over -1 |
||||
foreach {pt code} $overmap { |
||||
set ptchars [split $pt ""] ;#for lookahead |
||||
#emit plaintext chars first using existing SGR codes from under/over stack as appropriate |
||||
#then check if the following code is a cursor movement within the line and adjust index if so |
||||
foreach ch $ptchars { |
||||
incr idx_over |
||||
if {$ch eq "\r"} { |
||||
set idx $opt_colstart |
||||
} elseif {$ch eq "\b"} { |
||||
#review - backspace effect on double-width chars |
||||
if {$idx > $opt_colstart} { |
||||
incr idx -1 |
||||
} |
||||
} elseif {($idx < $opt_colstart)} { |
||||
incr idx |
||||
} elseif {($do_transparency && [regexp $opt_transparent $ch])} { |
||||
#pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) |
||||
set owidth [punk::char::string_width $ch] |
||||
if {$idx > [llength $out]-1} { |
||||
lappend out " " |
||||
dict set understacks $idx [list] ;#review - use idx-1 codestack? |
||||
incr idx |
||||
} else { |
||||
set uwidth [punk::char::string_width [lindex $out $idx]] |
||||
if {[lindex $out $idx] eq ""} { |
||||
#2nd col of 2-wide char in underlay |
||||
incr idx |
||||
} elseif {$uwidth == 0} { |
||||
#e.g combining diacritic |
||||
incr idx |
||||
} elseif {$uwidth == 1} { |
||||
incr idx |
||||
if {$owidth > 1} { |
||||
incr idx |
||||
} |
||||
} elseif {$uwidth > 1} { |
||||
if {[punk::char::string_width $ch] == 1} { |
||||
#normal singlewide transparency |
||||
set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay |
||||
if {$next_pt_overchar eq ""} { |
||||
#special-case trailing transparent - no next_pt_overchar |
||||
incr idx |
||||
} else { |
||||
if {[regexp $opt_transparent $next_pt_overchar]} { |
||||
incr idx |
||||
} else { |
||||
#next overlay char is not transparent.. first-half of underlying 2wide char is exposed |
||||
priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over] |
||||
incr idx |
||||
} |
||||
} |
||||
} else { |
||||
#2wide transparency over 2wide in underlay |
||||
incr idx |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
#non-transparent char in overlay |
||||
set owidth [punk::char::string_width $ch] |
||||
set uwidth [punk::char::string_width [lindex $out $idx]] |
||||
if {[lindex $out $idx] eq ""} { |
||||
#2nd col of 2wide char in underlay |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
} elseif {$uwidth == 0} { |
||||
#e.g combining diacritic - increment before over char REVIEW |
||||
#arguably the previous overchar should have done this - ie lookahead for combiners? |
||||
priv::render_addchar $idx "" [dict get $overstacks $idx_over] |
||||
incr idx |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
|
||||
} elseif {$uwidth == 1} { |
||||
if {$owidth == 1} { |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
} else { |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
priv::render_addchar $idx "" [dict get $overstacks $idx_over] |
||||
} |
||||
} elseif {$uwidth > 1} { |
||||
if {$owidth == 1} { |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
priv::render_addchar $idx $opt_exposed2 [dict get $overstacks $idx_over] |
||||
#don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char |
||||
} else { |
||||
#2wide over 2wide |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
} |
||||
} |
||||
} |
||||
} |
||||
#check following code |
||||
if {![priv::is_sgr $code]} { |
||||
|
||||
} |
||||
} |
||||
|
||||
if {$opt_overflow == 0} { |
||||
#need to truncate to the width of the original undertext |
||||
#review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? |
||||
set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars |
||||
} |
||||
|
||||
#coalesce and replay codestacks for out char list |
||||
set outstring "" |
||||
set remstring "" ;#remainder after overflow point reached |
||||
set i 0 |
||||
set cstack [list] |
||||
set prevstack [list] |
||||
set out_rawchars ""; #for overflow counting |
||||
set output_to "outstring" ;#var in effect depending on overflow |
||||
set in_overflow 0 ;#used to stop char-width scanning once in overflow |
||||
foreach ch $out { |
||||
append out_rawchars $ch |
||||
if {$opt_overflow == 0 && !$in_overflow} { |
||||
if {[set nextvisualwidth [punk::char::string_width $out_rawchars]] < $num_under_columns} { |
||||
} else { |
||||
#todo - check if we overflowed with a double-width char ? |
||||
#store visualwidth which may be short |
||||
set in_overflow 1 |
||||
} |
||||
} |
||||
set cstack [dict get $understacks $i] |
||||
if {$cstack ne $prevstack} { |
||||
if {[llength $prevstack]} { |
||||
append $output_to \033\[m |
||||
} |
||||
foreach code $cstack { |
||||
append $output_to $code |
||||
} |
||||
} |
||||
append $output_to $ch |
||||
set prevstack $cstack |
||||
incr i |
||||
if {$in_overflow} { |
||||
set output_to "remstring" |
||||
} |
||||
} |
||||
if {[dict size $understacks] > 0} { |
||||
append $output_to [join [dict get $understacks [expr {[dict size $understacks]-1}]] ""] ;#tail codes |
||||
} |
||||
if {[string length $remstring]} { |
||||
#puts stderr "remainder:$remstring" |
||||
} |
||||
#pdict $understacks |
||||
if {$opt_returnextra} { |
||||
return [list $outstring $visualwidth [string length $outstring] $remstring] |
||||
} else { |
||||
return $outstring |
||||
} |
||||
#return [join $out ""] |
||||
} |
||||
proc overtype::test_renderline {} { |
||||
set t \uFF5E ;#2-wide tilde |
||||
set u \uFF3F ;#2-wide underscore |
||||
set missing \uFFFD |
||||
return [list $t $u A${t}B] |
||||
} |
||||
namespace eval overtype::priv { |
||||
#todo - move to punk::ansi::codetype |
||||
proc is_sgr {code} { |
||||
#SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline |
||||
#we will accept and pass through the less common colon separator (ITU Open Document Architecture) |
||||
#Terminals should generally ignore it if they don't use it |
||||
regexp {\033\[[0-9;:]*m$} $code |
||||
} |
||||
proc is_cursor_move_in_line {code} { |
||||
#review - what about CSI n : m H where row n happens to be current line? |
||||
regexp {\033\[[0-9]*(:?C|D|G)$} |
||||
} |
||||
#pure SGR reset |
||||
proc is_sgr_reset {code} { |
||||
#todo 8-bit csi |
||||
regexp {\033\[0*m$} $code |
||||
} |
||||
#whether this code has 0 (or equivalently empty) parameter (but may set others) |
||||
#if an SGR code as a reset in it - we don't need to carry forward any previous SGR codes |
||||
#it generally only makes sense for the reset to be the first entry - otherwise the code has ineffective portions |
||||
#However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. |
||||
#We will only look at initial parameter as this is the well-formed normal case. |
||||
#Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg color twice in same code |
||||
proc has_sgr_leadingreset {code} { |
||||
set params "" |
||||
regexp {\033\[(.*)m} $code _match params |
||||
set plist [split $params ";"] |
||||
if {[string trim [lindex $plist 0] 0] eq ""} { |
||||
#e.g \033\[m \033\[0\;...m \033\[0000...m |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
#has_sgr_reset - rather than support this - create an sgr normalize function that removes dead params and brings reset to front of param list |
||||
proc render_addchar {i c stack} { |
||||
upvar out o |
||||
upvar understacks ustacks |
||||
set nxt [llength $o] |
||||
if {$i < $nxt} { |
||||
lset o $i $c |
||||
} else { |
||||
lappend o $c |
||||
} |
||||
dict set ustacks $i $stack |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- |
||||
if 0 { |
||||
namespace eval overtype::ta { |
||||
namespace path ::overtype |
||||
# *based* on but not identical to: |
||||
#https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm |
||||
|
||||
#handle both 7-bit and 8-bit csi |
||||
#review - does codepage affect this? e.g ebcdic has 8bit csi in different position |
||||
|
||||
#CSI |
||||
#variable re_csi_open {(?:\033\[|\u009b)[0-9;]+} ;#too specific - doesn't detect \033\[m |
||||
variable re_csi_open {(?:\033\[|\u009b])} |
||||
|
||||
#colour and style |
||||
variable re_csi_colour {(?:\033\[|\u009b)[0-9;]*m} ;#e.g \033\[31m \033\[m \033\[0m \033\[m0000m |
||||
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). |
||||
variable re_csi_code {(?:\033\[|\u009b])[0-9;]*[a-zA-Z\\@^_|~`]} |
||||
|
||||
#OSC - termnate with BEL (\a \007) or ST (string terminator \033\\) |
||||
#variable re_esc_osc1 {(?:\033\]|\u009c).*\007} |
||||
#variable re_esc_osc2 {(?:\033\]|\u009c).*\033\\} |
||||
|
||||
#test - non-greedy |
||||
variable re_esc_osc1 {(?:\033\]|\u009c).*?\007} |
||||
variable re_esc_osc2 {(?:\033\]|\u009c).*?\033\\} |
||||
|
||||
variable re_ansi_detect "${re_csi_open}|${re_esc_osc1}|${re_esc_osc2}" |
||||
|
||||
#detect any ansi escapes |
||||
#review - only detect 'complete' codes - or just use the opening escapes for performance? |
||||
#proc detect {text} { |
||||
# variable re_ansi_detect |
||||
# #variable re_csi_open |
||||
# #variable re_esc_osc1 |
||||
# #variable re_esc_osc2 |
||||
# #todo - other escape sequences |
||||
# #expr {[regexp $re_csi_open $text] || [regexp $re_esc_osc1 $text] || [regexp $re_esc_osc2 $text]} |
||||
# expr {[regexp $re_ansi_detect $text]} |
||||
#} |
||||
#not in perl ta |
||||
#proc detect_csi {text} { |
||||
# variable re_csi_colour |
||||
# expr {[regexp $re_csi_colour $text]} |
||||
#} |
||||
proc strip {text} { |
||||
tailcall punk::ansi::stripansi $text |
||||
} |
||||
#note this is character length after stripping ansi codes - not the printing length |
||||
proc length {text} { |
||||
string length [punk::ansi::stripansi $text] |
||||
} |
||||
|
||||
|
||||
# -- --- --- --- --- --- |
||||
#Split $text to a list containing alternating ANSI color codes and text. |
||||
#ANSI color codes are always on the second element, fourth, and so on. |
||||
#(ie plaintext on odd list-indices ansi on even indices) |
||||
# Example: |
||||
#ta_split_codes "" # => "" |
||||
#ta_split_codes "a" # => "a" |
||||
#ta_split_codes "a\e[31m" # => {"a" "\e[31m"} |
||||
#ta_split_codes "\e[31ma" # => {"" "\e[31m" "a"} |
||||
#ta_split_codes "\e[31ma\e[0m" # => {"" "\e[31m" "a" "\e[0m"} |
||||
#ta_split_codes "\e[31ma\e[0mb" # => {"" "\e[31m" "a" "\e[0m", "b"} |
||||
#ta_split_codes "\e[31m\e[0mb" # => {"" "\e[31m\e[0m" "b"} |
||||
# |
||||
#proc split_codes {text} { |
||||
# variable re_esc_osc1 |
||||
# variable re_esc_osc2 |
||||
# variable re_csi_code |
||||
# set re "(?:${re_csi_code}|${re_esc_osc1}|${re_esc_osc2})+" |
||||
# return [_perlish_split $re $text] |
||||
#} |
||||
##like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds) |
||||
#proc split_codes_single {text} { |
||||
# variable re_esc_osc1 |
||||
# variable re_esc_osc2 |
||||
# variable re_csi_code |
||||
# set re "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}" |
||||
# return [_perlish_split $re $text] |
||||
#} |
||||
|
||||
##review - tcl greedy expressions may match multiple in one element |
||||
#proc _perlish_split {re text} { |
||||
# if {[string length $text] == 0} { |
||||
# return {} |
||||
# } |
||||
# set list [list] |
||||
# set start 0 |
||||
# while {[regexp -start $start -indices -- $re $text match]} { |
||||
# lassign $match matchStart matchEnd |
||||
# lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd] |
||||
# set start [expr {$matchEnd+1}] |
||||
# } |
||||
# lappend list [string range $text $start end] |
||||
# return $list |
||||
#} |
||||
## -- --- --- --- --- --- |
||||
|
||||
} |
||||
} ;# end if 0 |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- |
||||
namespace eval overtype { |
||||
interp alias {} ::overtype::center {} ::overtype::centre |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide overtype [namespace eval overtype { |
||||
variable version |
||||
set version 1.5.1 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,928 +0,0 @@
|
||||
# -*- 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) Julian Noble 2003-2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application overtype 1.5.6 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin overtype_module_overtype 0 1.5.6] |
||||
#[copyright "2024"] |
||||
#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] |
||||
#[require overtype] |
||||
#[keywords module text ansi] |
||||
#[description] |
||||
#[para] - |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of overtype |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by overtype |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6 |
||||
package require textutil |
||||
package require punk::lib ;#required for lines_as_list |
||||
package require punk::ansi ;#required to detect, split, strip and calculate lengths |
||||
package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package textutil] |
||||
#[item] [package punk::ansi] |
||||
#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes |
||||
#[item] [package punk::char] |
||||
#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
#Julian Noble <julian@precisium.com.au> - 2003 |
||||
#Released under standard 'BSD license' conditions. |
||||
# |
||||
#todo - ellipsis truncation indicator for center,right |
||||
|
||||
#v1.4 2023-07 - naive ansi color handling - todo - fix string range |
||||
# - need to extract and replace ansi codes? |
||||
|
||||
namespace eval overtype { |
||||
namespace export * |
||||
variable default_ellipsis_horizontal "..." ;#fallback |
||||
variable default_ellipsis_vertical "..." |
||||
namespace eval priv { |
||||
proc _init {} { |
||||
upvar ::overtype::default_ellipsis_horizontal e_h |
||||
upvar ::overtype::default_ellipsis_vertical e_v |
||||
set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis |
||||
set e_v [format %c 0x22EE] |
||||
#The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text |
||||
#Also - unicode ellipsis has semantic meaning that other processors can interpret |
||||
#unicode does also provide a midline horizontal ellipsis 0x22EF |
||||
|
||||
#set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal |
||||
#if {![catch {package require punk::char}]} { |
||||
# set e [punk::char::charshort boxd_ltdshhz] |
||||
#} |
||||
} |
||||
} |
||||
priv::_init |
||||
} |
||||
proc overtype::about {} { |
||||
return "Simple text formatting. Author JMN. BSD-License" |
||||
} |
||||
|
||||
namespace eval overtype { |
||||
variable escape_terminals |
||||
#single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). |
||||
dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] |
||||
#dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic |
||||
dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals |
||||
|
||||
#self-contained 2 byte ansi escape sequences - review more? |
||||
variable ansi_2byte_codes_dict |
||||
set ansi_2byte_codes_dict [dict create\ |
||||
"reset_terminal" "\u001bc"\ |
||||
"save_cursor_posn" "\u001b7"\ |
||||
"restore_cursor_posn" "\u001b8"\ |
||||
"cursor_up_one" "\u001bM"\ |
||||
"NEL - Next Line" "\u001bE"\ |
||||
"IND - Down one line" "\u001bD"\ |
||||
"HTS - Set Tab Stop" "\u001bH"\ |
||||
] |
||||
|
||||
#debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. |
||||
# "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ |
||||
} |
||||
|
||||
|
||||
#proc overtype::stripansi {text} { |
||||
# variable escape_terminals ;#dict |
||||
# variable ansi_2byte_codes_dict |
||||
# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway |
||||
# if {[string first \033 $text] <0 && [string first \009c $text] <0} { |
||||
# #\033 same as \x1b |
||||
# return $text |
||||
# } |
||||
# |
||||
# set text [convert_g0 $text] |
||||
# |
||||
# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. |
||||
# #line endings can theoretically occur within an ansi escape sequence (review e.g title?) |
||||
# set inputlist [split $text ""] |
||||
# set outputlist [list] |
||||
# |
||||
# set 2bytecodes [dict values $ansi_2byte_codes_dict] |
||||
# |
||||
# set in_escapesequence 0 |
||||
# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls |
||||
# set i 0 |
||||
# foreach u $inputlist { |
||||
# set v [lindex $inputlist $i+1] |
||||
# set uv ${u}${v} |
||||
# if {$in_escapesequence eq "2b"} { |
||||
# #2nd byte - done. |
||||
# set in_escapesequence 0 |
||||
# } elseif {$in_escapesequence != 0} { |
||||
# set escseq [dict get $escape_terminals $in_escapesequence] |
||||
# if {$u in $escseq} { |
||||
# set in_escapesequence 0 |
||||
# } elseif {$uv in $escseq} { |
||||
# set in_escapseequence 2b ;#flag next byte as last in sequence |
||||
# } |
||||
# } else { |
||||
# #handle both 7-bit and 8-bit CSI and OSC |
||||
# if {[regexp {^(?:\033\[|\u009b)} $uv]} { |
||||
# set in_escapesequence CSI |
||||
# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { |
||||
# set in_escapesequence OSC |
||||
# } elseif {$uv in $2bytecodes} { |
||||
# #self-contained e.g terminal reset - don't pass through. |
||||
# set in_escapesequence 2b |
||||
# } else { |
||||
# lappend outputlist $u |
||||
# } |
||||
# } |
||||
# incr i |
||||
# } |
||||
# return [join $outputlist ""] |
||||
#} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc overtype::string_columns {text} { |
||||
if {[punk::ansi::ta::detect $text]} { |
||||
#error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length" |
||||
set text [punk::ansi::stripansi $text] |
||||
} |
||||
return [punk::char::string_width $text] |
||||
} |
||||
|
||||
|
||||
#string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r |
||||
proc overtype::left {args} { |
||||
# @c overtype starting at left (overstrike) |
||||
# @c can/should we use something like this?: 'format "%-*s" $len $overtext |
||||
variable default_ellipsis_horizontal |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} |
||||
} |
||||
lassign [lrange $args end-1 end] underblock overblock |
||||
set defaults [dict create\ |
||||
-bias ignored\ |
||||
-ellipsis 0\ |
||||
-ellipsistext $default_ellipsis_horizontal\ |
||||
-ellipsiswhitespace 0\ |
||||
-overflow 0\ |
||||
-transparent 0\ |
||||
-exposed1 \uFFFD\ |
||||
-exposed2 \uFFFD\ |
||||
] |
||||
set known_opts [dict keys $defaults] |
||||
set argsflags [lrange $args 0 end-2] |
||||
dict for {k v} $argsflags { |
||||
if {$k ni $known_opts} { |
||||
error "overtype::left unknown option '$k'. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $argsflags] |
||||
# -- --- --- --- --- --- |
||||
set opt_transparent [dict get $opts -transparent] |
||||
set opt_ellipsistext [dict get $opts -ellipsistext] |
||||
set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] |
||||
set opt_exposed1 [dict get $opts -exposed1] ;#widechar_exposed_left - todo |
||||
set opt_exposed2 [dict get $opts -exposed2] ;#widechar_exposed_right - todo |
||||
# -- --- --- --- --- --- |
||||
|
||||
set norm [list \r\n \n] |
||||
set underblock [string map $norm $underblock] |
||||
set overblock [string map $norm $overblock] |
||||
|
||||
set underlines [split $underblock \n] |
||||
#set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] |
||||
lassign [blocksize $underblock] _w colwidth _h colheight |
||||
set overlines [split $overblock \n] |
||||
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] |
||||
lassign [blocksize $overblock] _w overblock_width _h overblock_height |
||||
set under_exposed_max [expr {$colwidth - $overblock_width}] |
||||
set right_exposed $under_exposed_max |
||||
|
||||
set outputlines [list] |
||||
foreach undertext $underlines overtext $overlines { |
||||
set undertext_printlen [punk::ansi::printing_length $undertext] |
||||
if {$undertext_printlen < $colwidth} { |
||||
set udiff [expr {$colwidth - $undertext_printlen}] |
||||
set undertext "$undertext[string repeat { } $udiff]" |
||||
} |
||||
set overtext_printlen [punk::ansi::printing_length $overtext] |
||||
set overflowlength [expr {$overtext_printlen - $colwidth}] |
||||
|
||||
#review |
||||
#append overtext "\033\[0m" |
||||
|
||||
|
||||
if {$overflowlength > 0} { |
||||
#background line is narrower than data in line |
||||
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow [dict get $opts -overflow] $undertext $overtext] |
||||
if {![dict get $opts -overflow]} { |
||||
#set overtext [string range $overtext 0 $colwidth-1] ;#string range won't be correct e.g if contains ansi codes or leading \r or \b etc |
||||
if {[dict get $opts -ellipsis]} { |
||||
set show_ellipsis 1 |
||||
if {!$opt_ellipsiswhitespace} { |
||||
#we don't want ellipsis if only whitespace was lost |
||||
set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] |
||||
if {[string trim $lostdata] eq ""} { |
||||
set show_ellipsis 0 |
||||
} |
||||
} |
||||
if {$show_ellipsis} { |
||||
set rendered [overtype::right $rendered $opt_ellipsistext] |
||||
} |
||||
} |
||||
} |
||||
lappend outputlines $rendered |
||||
} else { |
||||
#we know overtext data is shorter or equal (for this line) |
||||
lappend outputlines [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] |
||||
} |
||||
} |
||||
return [join $outputlines \n] |
||||
|
||||
} |
||||
|
||||
namespace eval overtype::piper { |
||||
proc overcentre {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-bias left|right? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata} |
||||
} |
||||
lassign [lrange $args end-1 end] over under |
||||
set argsflags [lrange $args 0 end-2] |
||||
tailcall overtype::centre {*}$argsflags $under $over |
||||
} |
||||
proc overleft {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-start <column>? ?-transparent [0|1|<regexp>]? ?-exposed1 <char>? ?-exposed2 <char>? ?-overflow [1|0]? overtext pipelinedata} |
||||
} |
||||
lassign [lrange $args end-1 end] over under |
||||
set argsflags [lrange $args 0 end-2] |
||||
tailcall overtype::left {*}$argsflags $under $over |
||||
} |
||||
} |
||||
#todo - left-right ellipsis ? |
||||
proc overtype::centre {args} { |
||||
variable default_ellipsis_horizontal |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
|
||||
foreach {underblock overblock} [lrange $args end-1 end] break |
||||
|
||||
#todo - vertical vs horizontal overflow for blocks |
||||
set defaults [dict create\ |
||||
-bias left\ |
||||
-ellipsis 0\ |
||||
-ellipsistext $default_ellipsis_horizontal\ |
||||
-ellipsiswhitespace 0\ |
||||
-overflow 0\ |
||||
-transparent 0\ |
||||
-exposed1 \uFFFD\ |
||||
-exposed2 \uFFFD\ |
||||
] |
||||
set known_opts [dict keys $defaults] |
||||
set argsflags [lrange $args 0 end-2] |
||||
dict for {k v} $argsflags { |
||||
if {$k ni $known_opts} { |
||||
error "overtype::centre unknown option '$k'. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $argsflags] |
||||
# -- --- --- --- --- --- |
||||
set opt_transparent [dict get $opts -transparent] |
||||
set opt_ellipsis [dict get $opts -ellipsis] |
||||
set opt_ellipsistext [dict get $opts -ellipsistext] |
||||
set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] |
||||
set opt_exposed1 [dict get $opts -exposed1] |
||||
set opt_exposed2 [dict get $opts -exposed2] |
||||
# -- --- --- --- --- --- |
||||
|
||||
|
||||
set norm [list \r\n \n] |
||||
set underblock [string map $norm $underblock] |
||||
set overblock [string map $norm $overblock] |
||||
|
||||
set underlines [split $underblock \n] |
||||
#set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] |
||||
lassign [blocksize $underblock] _w colwidth _h colheight |
||||
set overlines [split $overblock \n] |
||||
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] |
||||
lassign [blocksize $overblock] _w overblock_width _h overblock_height |
||||
set under_exposed_max [expr {$colwidth - $overblock_width}] |
||||
if {$under_exposed_max > 0} { |
||||
#background block is wider |
||||
if {$under_exposed_max % 2 == 0} { |
||||
#even left/right exposure |
||||
set left_exposed [expr {$under_exposed_max / 2}] |
||||
} else { |
||||
set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division |
||||
if {[string tolower [dict get $opts -bias]] eq "left"} { |
||||
set left_exposed $beforehalf |
||||
} else { |
||||
#bias to the right |
||||
set left_exposed [expr {$beforehalf + 1}] |
||||
} |
||||
} |
||||
} else { |
||||
set left_exposed 0 |
||||
} |
||||
|
||||
set outputlines [list] |
||||
foreach undertext $underlines overtext $overlines { |
||||
set overtext_datalen [punk::ansi::printing_length $overtext] |
||||
set ulen [punk::ansi::printing_length $undertext] |
||||
if {$ulen < $colwidth} { |
||||
set udiff [expr {$colwidth - $ulen}] |
||||
set undertext "$undertext[string repeat { } $udiff]" |
||||
} |
||||
|
||||
set overflowlength [expr {$overtext_datalen - $colwidth}] |
||||
#review - right-to-left langs should elide on left! - extra option required |
||||
|
||||
if {$overflowlength > 0} { |
||||
#overlay line wider or equal |
||||
set rendered [renderline -transparent $opt_transparent -overflow [dict get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] |
||||
#overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified |
||||
if {![dict get $opts -overflow]} { |
||||
#lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]] |
||||
#set overtext [string range $overtext 0 $colwidth-1 ] |
||||
if {$opt_ellipsis} { |
||||
set show_ellipsis 1 |
||||
if {!$opt_ellipsiswhitespace} { |
||||
#we don't want ellipsis if only whitespace was lost |
||||
set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] |
||||
if {[string trim $lostdata] eq ""} { |
||||
set show_ellipsis 0 |
||||
} |
||||
} |
||||
if {$show_ellipsis} { |
||||
set rendered [overtype::right $rendered $opt_ellipsistext] |
||||
} |
||||
} |
||||
} |
||||
lappend outputlines $rendered |
||||
#lappend outputlines [renderline -transparent $opt_transparent $undertext $overtext] |
||||
} else { |
||||
#background block is wider than or equal to data for this line |
||||
lappend outputlines [renderline -start $left_exposed -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] |
||||
} |
||||
} |
||||
return [join $outputlines \n] |
||||
} |
||||
|
||||
proc overtype::right {args} { |
||||
#NOT the same as align-right - which should be done to the overblock first if required |
||||
variable default_ellipsis_horizontal |
||||
# @d !todo - implement overflow, length checks etc |
||||
|
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
foreach {underblock overblock} [lrange $args end-1 end] break |
||||
|
||||
set defaults [dict create\ |
||||
-bias ignored\ |
||||
-ellipsis 0\ |
||||
-ellipsistext $default_ellipsis_horizontal\ |
||||
-ellipsiswhitespace 0\ |
||||
-overflow 0\ |
||||
-transparent 0\ |
||||
-exposed1 \uFFFD\ |
||||
-exposed2 \uFFFD\ |
||||
] |
||||
set known_opts [dict keys $defaults] |
||||
set argsflags [lrange $args 0 end-2] |
||||
dict for {k v} $argsflags { |
||||
if {$k ni $known_opts} { |
||||
error "overtype::centre unknown option '$k'. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $argsflags] |
||||
# -- --- --- --- --- --- |
||||
set opt_transparent [dict get $opts -transparent] |
||||
set opt_ellipsis [dict get $opts -ellipsis] |
||||
set opt_ellipsistext [dict get $opts -ellipsistext] |
||||
set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] |
||||
set opt_overflow [dict get $opts -overflow] |
||||
set opt_exposed1 [dict get $opts -exposed1] |
||||
set opt_exposed2 [dict get $opts -exposed2] |
||||
# -- --- --- --- --- --- |
||||
|
||||
set norm [list \r\n \n] |
||||
set underblock [string map $norm $underblock] |
||||
set overblock [string map $norm $overblock] |
||||
|
||||
set underlines [split $underblock \n] |
||||
#set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] |
||||
lassign [blocksize $underblock] _w colwidth _h colheight |
||||
set overlines [split $overblock \n] |
||||
#set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] |
||||
lassign [blocksize $overblock] _w overblock_width _h overblock_height |
||||
set under_exposed_max [expr {$colwidth - $overblock_width}] |
||||
set left_exposed $under_exposed_max |
||||
|
||||
set outputlines [list] |
||||
foreach undertext $underlines overtext $overlines { |
||||
set overtext_datalen [punk::ansi::printing_length $overtext] |
||||
set ulen [punk::ansi::printing_length $undertext] |
||||
if {$ulen < $colwidth} { |
||||
set udiff [expr {$colwidth - $ulen}] |
||||
puts xxx |
||||
set undertext "$undertext[string repeat { } $udiff]" |
||||
} |
||||
if {$overtext_datalen < $overblock_width} { |
||||
set odiff [expr {$overblock_width - $overtext_datalen}] |
||||
#padding always on right - if alignment is required it should be done to block beforehand - not here |
||||
set overtextpadding "$overtext[string repeat { } $odiff]" |
||||
} |
||||
|
||||
set overflowlength [expr {$overtext_datalen - $colwidth}] |
||||
if {$overflowlength > 0} { |
||||
#raw overtext wider than undertext column |
||||
set rendered [renderline -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -start 0 $undertext $overtext] |
||||
if {!$opt_overflow} { |
||||
if {$opt_ellipsis} { |
||||
set show_ellipsis 1 |
||||
if {!$opt_ellipsiswhitespace} { |
||||
#we don't want ellipsis if only whitespace was lost |
||||
set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] |
||||
if {[string trim $lostdata] eq ""} { |
||||
set show_ellipsis 0 |
||||
} |
||||
} |
||||
if {$show_ellipsis} { |
||||
set rendered [overtype::right $rendered $opt_ellipsistext] |
||||
} |
||||
} |
||||
} |
||||
lappend outputlines $rendered |
||||
} else { |
||||
#padded overtext |
||||
lappend outputlines [renderline -transparent $opt_transparent -start $left_exposed $undertext $overtext] |
||||
} |
||||
} |
||||
|
||||
return [join $outputlines \n] |
||||
} |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- |
||||
proc overtype::transparentline {args} { |
||||
foreach {under over} [lrange $args end-1 end] break |
||||
set argsflags [lrange $args 0 end-2] |
||||
set defaults [dict create\ |
||||
-transparent 1\ |
||||
-exposed 1 " "\ |
||||
-exposed 2 " "\ |
||||
] |
||||
set newargs [dict merge $defaults $argsflags] |
||||
tailcall overtype::renderline {*}$newargs $under $over |
||||
} |
||||
#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. |
||||
# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. |
||||
#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. |
||||
# |
||||
namespace eval overtype::piper { |
||||
proc renderline {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? overtext pipelinedata} |
||||
} |
||||
foreach {over under} [lrange $args end-1 end] break |
||||
set argsflags [lrange $args 0 end-2] |
||||
tailcall overtype::renderline {*}$argsflags $under $over |
||||
} |
||||
} |
||||
interp alias "" piper_renderline "" overtype::piper::renderline |
||||
|
||||
#-returnextra to enable returning of overflow and length |
||||
# todo - use punk::ansi::ta::detect to short-circuit processing and do simple string calcs as an optimisation? |
||||
#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements |
||||
#todo - review transparency issues with single/double width characters! |
||||
proc overtype::renderline {args} { |
||||
if {[llength $args] < 2} { |
||||
error {usage: ?-start <int>? ?-transparent [0|1|<regexp>]? ?-overflow [1|0]? undertext overtext} |
||||
} |
||||
lassign [lrange $args end-1 end] under over |
||||
#should also rule out \v |
||||
if {[string first \n $over] >=0 || [string first \n $under] >= 0} { |
||||
error "overtype::renderline not allowed to contain newlines" |
||||
} |
||||
set defaults [dict create\ |
||||
-overflow 0\ |
||||
-transparent 0\ |
||||
-start 0\ |
||||
-returnextra 0\ |
||||
-exposed1 \uFFFD\ |
||||
-exposed2 \uFFFD\ |
||||
] |
||||
#exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow |
||||
|
||||
set known_opts [dict keys $defaults] |
||||
set argsflags [lrange $args 0 end-2] |
||||
dict for {k v} $argsflags { |
||||
if {$k ni $known_opts} { |
||||
error "overtype::renderline unknown option '$k'. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $argsflags] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_overflow [dict get $opts -overflow] |
||||
set opt_colstart [dict get $opts -start] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_transparent [dict get $opts -transparent] |
||||
if {$opt_transparent eq "0"} { |
||||
set do_transparency 0 |
||||
} else { |
||||
set do_transparency 1 |
||||
if {$opt_transparent eq "1"} { |
||||
set opt_transparent {[\s]} |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_returnextra [dict get $opts -returnextra] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_exposed1 [dict get $opts -exposed1] |
||||
set opt_exposed2 [dict get $opts -exposed2] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
#----- |
||||
# |
||||
if {[string first \t $under] >= 0} { |
||||
#set under [textutil::tabify::untabify2 $under] |
||||
set under [textutil::tabify::untabifyLine $under 8] ;#8 is default for untabify2 - review |
||||
} |
||||
set overdata $over |
||||
if {[string first \t $over] >= 0} { |
||||
#set overdata [textutil::tabify::untabify2 $over] |
||||
set overdata [textutil::tabify::untabifyLine $over 8] |
||||
} |
||||
#------- |
||||
|
||||
#ta_detect ansi and do simpler processing? |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- |
||||
set undermap [punk::ansi::ta::split_codes_single $under] |
||||
set understacks [dict create] |
||||
|
||||
set i_u -1 |
||||
set i_o 0 |
||||
set out [list] |
||||
set u_codestack [list] |
||||
set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation |
||||
set remainder [list] ;#for returnextra |
||||
foreach {pt code} $undermap { |
||||
#pt = plain text |
||||
append pt_underchars $pt |
||||
foreach grapheme [punk::char::grapheme_split $pt] { |
||||
set width [punk::char::string_width $grapheme] |
||||
incr i_u |
||||
dict set understacks $i_u $u_codestack |
||||
lappend out $grapheme |
||||
if {$width > 1} { |
||||
incr i_u |
||||
#presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) |
||||
#but what about emoji combinations etc - can they be wider than 2? |
||||
dict set understacks $i_u $u_codestack |
||||
lappend out "" |
||||
} |
||||
} |
||||
|
||||
#underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here |
||||
|
||||
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc |
||||
#order of if-else based on assumptions: |
||||
# that pure resets are fairly common - more so than leading resets with other info |
||||
# that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. |
||||
if {[punk::ansi::codetype::is_sgr_reset $code]} { |
||||
set u_codestack [list] |
||||
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { |
||||
set u_codestack [list $code] |
||||
} elseif {[punk::ansi::codetype::is_sgr $code]} { |
||||
lappend u_codestack $code |
||||
} |
||||
#consider also if there are other codes that should be stacked..? |
||||
} |
||||
#trailing codes in effect for underlay |
||||
if {[llength $undermap]} { |
||||
dict set understacks [expr {$i_u + 1}] $u_codestack |
||||
} |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- |
||||
#### |
||||
#if opt_colstart - we need to build a space (or any singlewidth char really) padding on the left of the right number of columns. |
||||
#this will be processed as transparent - and handle doublewidth underlay characters appropriately |
||||
set startpad [string repeat " " $opt_colstart] |
||||
append startpad $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency |
||||
set overmap [punk::ansi::ta::split_codes_single $startpad] |
||||
#### |
||||
|
||||
#set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} |
||||
#as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes |
||||
|
||||
|
||||
set overstacks [dict create] |
||||
set o_codestack [list] |
||||
set pt_overchars "" |
||||
foreach {pt code} $overmap { |
||||
append pt_overchars $pt |
||||
foreach grapheme [punk::char::grapheme_split $pt] { |
||||
dict set overstacks $i_o $o_codestack |
||||
incr i_o |
||||
} |
||||
|
||||
if {[punk::ansi::codetype::is_sgr $code]} { |
||||
if {[punk::ansi::codetype::has_sgr_leadingreset $code]} { |
||||
#m code which has sgr reset at start - no need to replay prior sgr codes |
||||
set o_codestack [list $code] |
||||
} else { |
||||
lappend o_codestack $code |
||||
} |
||||
} |
||||
|
||||
#only stack SGR (graphics rendition) codes - not title sets, cursor moves etc |
||||
#order of if-else based on assumptions: |
||||
# that pure resets are fairly common - more so than leading resets with other info |
||||
# that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. |
||||
if {[punk::ansi::codetype::is_sgr_reset $code]} { |
||||
set o_codestack [list] |
||||
} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { |
||||
set o_codestack [list $code] |
||||
} elseif {[punk::ansi::codetype::is_sgr $code]} { |
||||
lappend o_codestack $code |
||||
} |
||||
|
||||
} |
||||
# -- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
#potential problem - combinining diacritics directly following control chars like \r \b |
||||
|
||||
set bs [format %c 0x08] |
||||
set idx 0 ;# line index (cursor - 1) |
||||
set idx_over -1 |
||||
foreach {pt code} $overmap { |
||||
#set ptchars [split $pt ""] ;#for lookahead |
||||
set graphemes [punk::char::grapheme_split $pt] |
||||
#emit plaintext chars first using existing SGR codes from under/over stack as appropriate |
||||
#then check if the following code is a cursor movement within the line and adjust index if so |
||||
foreach ch $graphemes { |
||||
incr idx_over |
||||
if {$ch eq "\r"} { |
||||
set idx $opt_colstart |
||||
} elseif {$ch eq "\b"} { |
||||
#review - backspace effect on double-width chars |
||||
if {$idx > $opt_colstart} { |
||||
incr idx -1 |
||||
} |
||||
} elseif {($idx < $opt_colstart)} { |
||||
incr idx |
||||
} elseif {($do_transparency && [regexp $opt_transparent $ch])} { |
||||
#pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) |
||||
set owidth [punk::char::string_width $ch] |
||||
if {$idx > [llength $out]-1} { |
||||
lappend out " " |
||||
dict set understacks $idx [list] ;#review - use idx-1 codestack? |
||||
incr idx |
||||
} else { |
||||
set uwidth [punk::char::string_width [lindex $out $idx]] |
||||
if {[lindex $out $idx] eq ""} { |
||||
#2nd col of 2-wide char in underlay |
||||
incr idx |
||||
} elseif {$uwidth == 0} { |
||||
#e.g control char ? combining diacritic ? |
||||
incr idx |
||||
} elseif {$uwidth == 1} { |
||||
incr idx |
||||
if {$owidth > 1} { |
||||
incr idx |
||||
} |
||||
} elseif {$uwidth > 1} { |
||||
if {[punk::char::string_width $ch] == 1} { |
||||
#normal singlewide transparency |
||||
set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay |
||||
if {$next_pt_overchar eq ""} { |
||||
#special-case trailing transparent - no next_pt_overchar |
||||
incr idx |
||||
} else { |
||||
if {[regexp $opt_transparent $next_pt_overchar]} { |
||||
incr idx |
||||
} else { |
||||
#next overlay char is not transparent.. first-half of underlying 2wide char is exposed |
||||
priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over] |
||||
incr idx |
||||
} |
||||
} |
||||
} else { |
||||
#2wide transparency over 2wide in underlay |
||||
incr idx |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
#non-transparent char in overlay |
||||
set owidth [punk::char::string_width $ch] |
||||
set uwidth [punk::char::string_width [lindex $out $idx]] |
||||
if {[lindex $out $idx] eq ""} { |
||||
#2nd col of 2wide char in underlay |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
} elseif {$uwidth == 0} { |
||||
#e.g combining diacritic - increment before over char REVIEW |
||||
#arguably the previous overchar should have done this - ie lookahead for combiners? |
||||
priv::render_addchar $idx "" [dict get $overstacks $idx_over] |
||||
incr idx |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
|
||||
} elseif {$uwidth == 1} { |
||||
if {$owidth == 1} { |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
} else { |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
priv::render_addchar $idx "" [dict get $overstacks $idx_over] |
||||
} |
||||
} elseif {$uwidth > 1} { |
||||
if {$owidth == 1} { |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
priv::render_addchar $idx $opt_exposed2 [dict get $overstacks $idx_over] |
||||
#don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char |
||||
} else { |
||||
#2wide over 2wide |
||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
||||
incr idx |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
#cursor movement? |
||||
#if {![punk::ansi::codetype::is_sgr $code]} { |
||||
# |
||||
#} |
||||
} |
||||
|
||||
if {$opt_overflow == 0} { |
||||
#need to truncate to the width of the original undertext |
||||
#review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? |
||||
set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars |
||||
} |
||||
|
||||
#coalesce and replay codestacks for out char list |
||||
set outstring "" |
||||
set remstring "" ;#remainder after overflow point reached |
||||
set i 0 |
||||
set cstack [list] |
||||
set prevstack [list] |
||||
set out_rawchars ""; #for overflow counting |
||||
set output_to "outstring" ;#var in effect depending on overflow |
||||
set in_overflow 0 ;#used to stop char-width scanning once in overflow |
||||
foreach ch $out { |
||||
append out_rawchars $ch |
||||
if {$opt_overflow == 0 && !$in_overflow} { |
||||
if {[set nextvisualwidth [punk::char::string_width $out_rawchars]] < $num_under_columns} { |
||||
} else { |
||||
#todo - check if we overflowed with a double-width char ? |
||||
#store visualwidth which may be short |
||||
set in_overflow 1 |
||||
} |
||||
} |
||||
set cstack [dict get $understacks $i] |
||||
if {$cstack ne $prevstack} { |
||||
if {[llength $prevstack]} { |
||||
append $output_to \033\[m |
||||
} |
||||
foreach code $cstack { |
||||
append $output_to $code |
||||
} |
||||
} |
||||
append $output_to $ch |
||||
set prevstack $cstack |
||||
incr i |
||||
if {$in_overflow} { |
||||
set output_to "remstring" |
||||
} |
||||
} |
||||
if {[dict size $understacks] > 0} { |
||||
append $output_to [join [dict get $understacks [expr {[dict size $understacks]-1}]] ""] ;#tail codes |
||||
} |
||||
if {[string length $remstring]} { |
||||
#puts stderr "remainder:$remstring" |
||||
} |
||||
#pdict $understacks |
||||
if {$opt_returnextra} { |
||||
return [list $outstring $visualwidth [string length $outstring] $remstring] |
||||
} else { |
||||
return $outstring |
||||
} |
||||
#return [join $out ""] |
||||
} |
||||
proc overtype::test_renderline {} { |
||||
set t \uFF5E ;#2-wide tilde |
||||
set u \uFF3F ;#2-wide underscore |
||||
set missing \uFFFD |
||||
return [list $t $u A${t}B] |
||||
} |
||||
|
||||
#same as textblock::size - but we don't want that circular dependency |
||||
proc overtype::blocksize {textblock} { |
||||
if {$textblock eq ""} { |
||||
return [dict create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings |
||||
} |
||||
set textblock [textutil::tabify::untabify2 $textblock] |
||||
#stripansi on entire block in one go rather than line by line - result should be the same - review - make tests |
||||
set textblock [punk::ansi::stripansi $textblock] |
||||
if {[string first \n $textblock] >= 0} { |
||||
set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::string_width $v}]] |
||||
} else { |
||||
set width [punk::char::string_width $textblock] |
||||
} |
||||
set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list |
||||
#our concept of block-height is likely to be different to other line-counting mechanisms |
||||
set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le |
||||
|
||||
return [dict create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize <data>]] width height |
||||
} |
||||
|
||||
namespace eval overtype::priv { |
||||
|
||||
#is actually addgrapheme? |
||||
proc render_addchar {i c stack} { |
||||
upvar out o |
||||
upvar understacks ustacks |
||||
set nxt [llength $o] |
||||
if {$i < $nxt} { |
||||
lset o $i $c |
||||
} else { |
||||
lappend o $c |
||||
} |
||||
dict set ustacks $i $stack |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- |
||||
namespace eval overtype { |
||||
interp alias {} ::overtype::center {} ::overtype::centre |
||||
} |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide overtype [namespace eval overtype { |
||||
variable version |
||||
set version 1.5.6 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
Loading…
Reference in new issue