41 changed files with 1925 additions and 11217 deletions
File diff suppressed because it is too large
Load Diff
@ -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
@ -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] |
|
||||||
@ -1,998 +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.7 |
|
||||||
# Meta platform tcl |
|
||||||
# Meta license BSD |
|
||||||
# @@ Meta End |
|
||||||
|
|
||||||
|
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
# doctools header |
|
||||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
||||||
#*** !doctools |
|
||||||
#[manpage_begin overtype_module_overtype 0 1.5.7] |
|
||||||
#[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: ?-startcolumn <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 -startcolumn [expr {$left_exposed + 1}] -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 -startcolumn 1 $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 -startcolumn [expr {$left_exposed + 1}] $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! |
|
||||||
#bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? |
|
||||||
proc overtype::renderline {args} { |
|
||||||
if {[llength $args] < 2} { |
|
||||||
error {usage: ?-info 0|1? ?-startcolumn <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\ |
|
||||||
-startcolumn 1\ |
|
||||||
-info 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 -startcolumn] ;#start cursor column |
|
||||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
||||||
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 -info] |
|
||||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
||||||
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 outcols [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 outcols $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 outcols "" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#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 " " [expr {$opt_colstart -1}]] |
|
||||||
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 colcursor $opt_colstart |
|
||||||
|
|
||||||
#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 overlay_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 $overlay_graphemes { |
|
||||||
set within_undercols [expr {$idx <= [llength $outcols]-1}] |
|
||||||
incr idx_over |
|
||||||
if {$ch eq "\r"} { |
|
||||||
set idx [expr {$opt_colstart -1}] |
|
||||||
} elseif {$ch eq "\b"} { |
|
||||||
#review - backspace effect on double-width chars |
|
||||||
if {$idx > ($opt_colstart -1)} { |
|
||||||
incr idx -1 |
|
||||||
} |
|
||||||
} elseif {($idx < ($opt_colstart -1))} { |
|
||||||
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) |
|
||||||
if {$idx > [llength $outcols]-1} { |
|
||||||
lappend outcols " " |
|
||||||
dict set understacks $idx [list] ;#review - use idx-1 codestack? |
|
||||||
incr idx |
|
||||||
} else { |
|
||||||
set uwidth [punk::char::string_width [lindex $outcols $idx]] |
|
||||||
if {[lindex $outcols $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} { |
|
||||||
set owidth [punk::char::string_width $ch] |
|
||||||
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 uwidth [punk::char::string_width [lindex $outcols $idx]] |
|
||||||
|
|
||||||
if {$within_undercols && [lindex $outcols $idx] eq ""} { |
|
||||||
#2nd col of 2wide char in underlay |
|
||||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
|
||||||
#JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme |
|
||||||
#e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 |
|
||||||
#vs |
|
||||||
# renderline -startcolumn 2 \uFF21---- \uFF23 |
|
||||||
if {[lindex $outcols $idx-1] != ""} { |
|
||||||
#verified it's an empty following a filled - so it's a legit underlay remnant |
|
||||||
#reset previous to an exposed 1st-half - but leave understacks code as is |
|
||||||
priv::render_addchar [expr {$idx-1}] $opt_exposed1 [dict get $understacks [expr {$idx-1}]] |
|
||||||
} |
|
||||||
incr idx |
|
||||||
|
|
||||||
} elseif {$uwidth == 0} { |
|
||||||
if {$within_undercols} { |
|
||||||
#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 |
|
||||||
} else { |
|
||||||
#overflow |
|
||||||
priv::render_addchar $idx $ch [dict get $overstacks $idx_over] |
|
||||||
incr idx |
|
||||||
} |
|
||||||
} elseif {$uwidth == 1} { |
|
||||||
set owidth [punk::char::string_width $ch] |
|
||||||
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] |
|
||||||
#if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme |
|
||||||
#replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack |
|
||||||
if {[llength $outcols] >= [expr {$idx +2}] && [lindex $outcols $idx+1] eq ""} { |
|
||||||
priv::render_addchar [expr {$idx+1}] $opt_exposed2 [dict get $understacks [expr {$idx+1}]] |
|
||||||
} |
|
||||||
incr idx |
|
||||||
} |
|
||||||
} elseif {$uwidth > 1} { |
|
||||||
set owidth [punk::char::string_width $ch] |
|
||||||
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 2 |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
#cursor movement? |
|
||||||
#if {![punk::ansi::codetype::is_sgr $code]} { |
|
||||||
# |
|
||||||
#} |
|
||||||
if {[punk::ansi::codetype::is_cursor_move_in_line $code]} { |
|
||||||
} |
|
||||||
set re_col_move {\x1b\[([0-9]*)(C|D|G)} |
|
||||||
if {[regexp $re_col_move $code _match num type]} { |
|
||||||
if {$type eq "C"} { |
|
||||||
#left-arrow/move-back |
|
||||||
if {$num eq ""} {set num 1} |
|
||||||
incr idx -$num |
|
||||||
if {$idx < $opt_colstart} { |
|
||||||
set idx $opt_colstart |
|
||||||
} |
|
||||||
} elseif {$type eq "D"} { |
|
||||||
#right-arrow/move forward |
|
||||||
if {$num eq ""} {set num 1} |
|
||||||
if {!$opt_overflow || ($idx + $num) <= [llength $outcols]-1} { |
|
||||||
incr idx $num |
|
||||||
if {$idx > [llength $outcols]-1} { |
|
||||||
set idx [llength $outcols] -1 |
|
||||||
} |
|
||||||
} else { |
|
||||||
set idxstart $idx |
|
||||||
set idxend [expr {[llength $outcols]-1}] |
|
||||||
set moveend [expr {$idxend - $idxstart}] |
|
||||||
incr idx $moveend |
|
||||||
set stackinfo [dict get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext |
|
||||||
#pad outcols |
|
||||||
set movemore [expr {$num - $moveend}] |
|
||||||
#assert movemore always at least 1 or we wouldn't be in this branch |
|
||||||
for {set m 1} {$m <= $movemore} {incr m} { |
|
||||||
incr idx |
|
||||||
priv::render_addchar $idx " " $stackinfo |
|
||||||
} |
|
||||||
} |
|
||||||
} elseif {$type eq "G"} { |
|
||||||
#move absolute column |
|
||||||
#adjust to colstart - as column 1 is within overlay |
|
||||||
#ie |
|
||||||
set num [expr {$num + $opt_colstart}] |
|
||||||
error "renderline absolute col move ESC G unimplemented" |
|
||||||
} |
|
||||||
|
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
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 outcols grapheme 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 $outcols { |
|
||||||
append out_rawchars $ch |
|
||||||
if {$opt_overflow == 0 && !$in_overflow} { |
|
||||||
if {[set nextvisualwidth [punk::char::string_width $out_rawchars]] > $num_under_columns} { |
|
||||||
#todo - check if we overflowed with a double-width char ? |
|
||||||
#store visualwidth which may be short |
|
||||||
set in_overflow 1 |
|
||||||
} |
|
||||||
} |
|
||||||
if {$in_overflow} { |
|
||||||
set output_to "remstring" |
|
||||||
} |
|
||||||
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 {[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} { |
|
||||||
set cursorinfo "" |
|
||||||
return [list result $outstring visualwidth - stringlen [string length $outstring] remainder $remstring cursor [expr {$idx + 1}]] |
|
||||||
} 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] |
|
||||||
} |
|
||||||
|
|
||||||
#maintenance warning |
|
||||||
#same as textblock::size - but we don't want that circular dependency |
|
||||||
#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both |
|
||||||
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 outcols 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.7 |
|
||||||
}] |
|
||||||
return |
|
||||||
|
|
||||||
#*** !doctools |
|
||||||
#[manpage_end] |
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,276 @@ |
|||||||
|
# -*- 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.3.tm |
||||||
|
# |
||||||
|
# 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) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application poshinfo 999999.0a1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_poshinfo 0 999999.0a1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require poshinfo] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of poshinfo |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by poshinfo |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require punk::config |
||||||
|
package require json ;#tcllib |
||||||
|
#toml, yaml? |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
#[item] [package {punk::config}] |
||||||
|
#[item] [package {json}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval poshinfo::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace poshinfo::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval poshinfo { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace poshinfo}] |
||||||
|
#[para] Core API functions for poshinfo |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
proc info_from_filename {fname} { |
||||||
|
#string based filename processing: we are deliberately avoiding test of file existence etc here |
||||||
|
if {$fname eq ""} { |
||||||
|
error "poshinfo::info_from_filename unable to determine name from empty string" |
||||||
|
} |
||||||
|
if {[string first . $fname] < 0} { |
||||||
|
#theoretically we could have a file without dots - but it's more likely an error in this context |
||||||
|
error "poshinfo::info_from_filename supplied value '$fname' doesn't look like a filename. Cowardly refusing to guess a shortname." |
||||||
|
} |
||||||
|
set ftail [file tail $fname] |
||||||
|
set rootname [file rootname $ftail] |
||||||
|
set format [string trimleft [file extension $ftail] .] |
||||||
|
set parts [split $rootname .] |
||||||
|
if {[lindex $parts end] eq "omp"} { |
||||||
|
set type omp |
||||||
|
set shortname [join [lrange $parts 0 end-1] .] |
||||||
|
} else { |
||||||
|
if {$rootname eq "schema"} { |
||||||
|
set type schema |
||||||
|
} else { |
||||||
|
set type unknown |
||||||
|
} |
||||||
|
set shortname $rootname |
||||||
|
} |
||||||
|
return [dict create shortname $shortname format $format type $type] |
||||||
|
} |
||||||
|
|
||||||
|
proc themes_dict {{globfor *}} { |
||||||
|
set running_config [punk::config::get running-config] |
||||||
|
set posh_themes_path [tcl::dict::get $running_config posh_themes_path] |
||||||
|
#posh_themes_path_extra ?? |
||||||
|
|
||||||
|
set themes [tcl::dict::create] |
||||||
|
|
||||||
|
if {[string length $posh_themes_path]} { |
||||||
|
if {[file exists $posh_themes_path]} { |
||||||
|
set files [glob -nocomplain -directory $posh_themes_path -tails $globfor] |
||||||
|
foreach ftail $files { |
||||||
|
set themeinfo [info_from_filename $ftail] |
||||||
|
set shortname [dict get $themeinfo shortname] |
||||||
|
dict set themeinfo path [file join $posh_themes_path $ftail] |
||||||
|
if {![dict exists $themes $shortname]} { |
||||||
|
dict set themes $shortname [list $themeinfo] |
||||||
|
} else { |
||||||
|
dict lappend themes $shortname $themeinfo |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $themes |
||||||
|
} |
||||||
|
proc themes {{globfor *}} { |
||||||
|
set themes [themes_dict $globfor] |
||||||
|
set posh_theme [file normalize [punk::config::get_running_global posh_theme]] |
||||||
|
set t [textblock::class::table new "Posh Themes"] |
||||||
|
$t configure -show_header 1 -show_hseps 0 |
||||||
|
$t add_column -headers Shortname |
||||||
|
$t add_column -headers Path |
||||||
|
dict for {shortname themeinfolist} $themes { |
||||||
|
#hack - support just one for now |
||||||
|
set themeinfo [lindex $themeinfolist 0] |
||||||
|
|
||||||
|
set path [dict get $themeinfo path] |
||||||
|
$t add_row [list $shortname $path] |
||||||
|
set fg "" |
||||||
|
set bg "" |
||||||
|
switch -- [dict get $themeinfo type] { |
||||||
|
schema { |
||||||
|
set bg Web-orange |
||||||
|
} |
||||||
|
omp {} |
||||||
|
unknown { |
||||||
|
set bg Web-red |
||||||
|
} |
||||||
|
default { |
||||||
|
#we shouldn't be getting other values |
||||||
|
set bg Web-yellow |
||||||
|
} |
||||||
|
} |
||||||
|
if {$posh_theme eq [file normalize $path]} { |
||||||
|
set fg web-limegreen |
||||||
|
} |
||||||
|
if {"$fg$bg" ne ""} { |
||||||
|
$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fg {*}$bg] |
||||||
|
} |
||||||
|
} |
||||||
|
set result [$t print] |
||||||
|
$t destroy |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace poshinfo ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval poshinfo::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace poshinfo::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 poshinfo::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval poshinfo::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace poshinfo::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide poshinfo [tcl::namespace::eval poshinfo { |
||||||
|
variable pkg poshinfo |
||||||
|
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. |
||||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in new issue