Browse Source

add punk::sshrun clone of tclssh

master
Julian Noble 7 months ago
parent
commit
ac28379197
  1. 3415
      src/bootsupport/modules/overtype-1.6.2.tm
  2. 9
      src/bootsupport/modules/punk/ansi-0.1.1.tm
  3. 2
      src/bootsupport/modules/punk/lib-0.1.1.tm
  4. 2
      src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm
  5. 9
      src/modules/punk/ansi-999999.0a1.0.tm
  6. 2
      src/modules/punk/lib-999999.0a1.0.tm
  7. 2
      src/modules/punk/mix/commandset/doc-999999.0a1.0.tm
  8. 465
      src/modules/punk/sshrun-999999.0a1.0.tm
  9. 3
      src/modules/punk/sshrun-buildversion.txt
  10. 963
      src/vendormodules/overtype-1.5.1.tm
  11. 1036
      src/vendormodules/overtype-1.5.2.tm
  12. 1037
      src/vendormodules/overtype-1.5.3.tm
  13. 928
      src/vendormodules/overtype-1.5.6.tm
  14. 1034
      src/vendormodules/overtype-1.5.7.tm
  15. 2409
      src/vendormodules/overtype-1.5.8.tm
  16. 2428
      src/vendormodules/overtype-1.5.9.tm
  17. 3333
      src/vendormodules/overtype-1.6.0.tm
  18. 3399
      src/vendormodules/overtype-1.6.1.tm
  19. 3415
      src/vendormodules/overtype-1.6.2.tm

3415
src/bootsupport/modules/overtype-1.6.2.tm

File diff suppressed because it is too large Load Diff

9
src/bootsupport/modules/punk/ansi-0.1.1.tm

@ -1612,9 +1612,16 @@ namespace eval punk::ansi {
return "\u0090+q$payload\u009c" return "\u0090+q$payload\u009c"
} }
namespace eval codetype { namespace eval codetype {
#*** !doctools
#[subsection {Namespace punk::ansi::codetype}]
#[para] API functions for punk::ansi::codetype
#[para] Utility functions for processing ansi code sequences
#[list_begin definitions]
#Functions that are primarily intended to operate on a single ansi code sequence - rather than a sequence, or codes embedded in another string #Functions that are primarily intended to operate on a single ansi code sequence - rather than a sequence, or codes embedded in another string
#in some cases multiple sequences or leading trailing strings are ok - but the proc docs should note where the function is looking #in some cases multiple sequences or leading trailing strings are ok - but the proc docs should note where the function is looking
#review - separate namespace for functions that operate on multiple or embedded? #review - separate namespace for functions that operate on multiple or embedded?
proc is_sgr {code} { proc is_sgr {code} {
#SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline #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) #we will accept and pass through the less common colon separator (ITU Open Document Architecture)
@ -2078,6 +2085,8 @@ namespace eval punk::ansi {
#has_sgr_reset - rather than support this function - create an sgr normalize function that removes dead params and brings reset to front of param list? #has_sgr_reset - rather than support this function - create an sgr normalize function that removes dead params and brings reset to front of param list?
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi::codetype ---}]
} }
namespace eval sequence_type { namespace eval sequence_type {
proc is_Fe {code} { proc is_Fe {code} {

2
src/bootsupport/modules/punk/lib-0.1.1.tm

@ -104,7 +104,7 @@ namespace eval punk::lib::compat {
#[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so.
#*** !doctools #*** !doctools
#[list_begin enumerated] #[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} { if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove" #puts stderr "Warning - no built-in lremove"

2
src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm

@ -216,7 +216,7 @@ namespace eval punk::mix::commandset::doc {
} }
file mkdir $output_base file mkdir $output_base
set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/**} *.tm] set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm]
set count 0 set count 0
set newdocs [list] set newdocs [list]
set docgen_header_comments "" set docgen_header_comments ""

9
src/modules/punk/ansi-999999.0a1.0.tm

@ -1612,9 +1612,16 @@ namespace eval punk::ansi {
return "\u0090+q$payload\u009c" return "\u0090+q$payload\u009c"
} }
namespace eval codetype { namespace eval codetype {
#*** !doctools
#[subsection {Namespace punk::ansi::codetype}]
#[para] API functions for punk::ansi::codetype
#[para] Utility functions for processing ansi code sequences
#[list_begin definitions]
#Functions that are primarily intended to operate on a single ansi code sequence - rather than a sequence, or codes embedded in another string #Functions that are primarily intended to operate on a single ansi code sequence - rather than a sequence, or codes embedded in another string
#in some cases multiple sequences or leading trailing strings are ok - but the proc docs should note where the function is looking #in some cases multiple sequences or leading trailing strings are ok - but the proc docs should note where the function is looking
#review - separate namespace for functions that operate on multiple or embedded? #review - separate namespace for functions that operate on multiple or embedded?
proc is_sgr {code} { proc is_sgr {code} {
#SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline #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) #we will accept and pass through the less common colon separator (ITU Open Document Architecture)
@ -2078,6 +2085,8 @@ namespace eval punk::ansi {
#has_sgr_reset - rather than support this function - create an sgr normalize function that removes dead params and brings reset to front of param list? #has_sgr_reset - rather than support this function - create an sgr normalize function that removes dead params and brings reset to front of param list?
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi::codetype ---}]
} }
namespace eval sequence_type { namespace eval sequence_type {
proc is_Fe {code} { proc is_Fe {code} {

2
src/modules/punk/lib-999999.0a1.0.tm

@ -104,7 +104,7 @@ namespace eval punk::lib::compat {
#[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so.
#*** !doctools #*** !doctools
#[list_begin enumerated] #[list_begin definitions]
if {"::lremove" ne [info commands ::lremove]} { if {"::lremove" ne [info commands ::lremove]} {
#puts stderr "Warning - no built-in lremove" #puts stderr "Warning - no built-in lremove"

2
src/modules/punk/mix/commandset/doc-999999.0a1.0.tm

@ -216,7 +216,7 @@ namespace eval punk::mix::commandset::doc {
} }
file mkdir $output_base file mkdir $output_base
set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/**} *.tm] set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm]
set count 0 set count 0
set newdocs [list] set newdocs [list]
set docgen_header_comments "" set docgen_header_comments ""

465
src/modules/punk/sshrun-999999.0a1.0.tm

@ -0,0 +1,465 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm
#
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# (C) 2009 Jose F. Nieves
#
# @@ Meta Begin
# Application punk::sshrun 999999.0a1.0
# Meta platform tcl
# Meta license ISC
# @@ Meta End
# Copyright (c) 2009 Jose F. Nieves <nieves@ltp.uprrp.edu>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::sshrun 0 999999.0a1.0]
#[copyright "2009"]
#[titledesc {Tcl procedures to execute tcl scripts in remote hosts}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk::sshrun tclssh clone}] [comment {-- Description at end of page heading --}]
#[require punk::sshrun]
#[keywords module ssh]
#[description]
#[para] This is a clone of tclssh by Jose F. Nieves
#[para] The original repo is at: https://bitbucket.org/noaaport/tclssh/src/master/
#[para] This version is namespaced under punk::sshrun specifically for the Punk shell project - and may lag the original project or diverge.
#[para] You are encouraged to use the original Tclssh source from the above URL for your own projects
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::sshrun
#[para] SYNOPSIS
#[para] package require punk::sshrun
#[para] -
#[para] punk::sshrun::connect [lb]-t <tclsh_name>[rb] [lb]-- <ssh_options>[rb] [lb]<user>@[rb]<host>
#[para] Defaults: -t tclsh
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::sshrun
#[list_begin itemized]
package require Tcl 8.6
package require cmdline
#*** !doctools
#[item] [package {Tcl 8.6}]
#[item] [package {cmdline}]
# #package require frobz
# #*** !doctools
# #[item] [package {frobz}]
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::sshrun::class {
#*** !doctools
#[subsection {Namespace punk::sshrun::class}]
#[para] class definitions
if {[info commands [namespace current]::interface_sample1] eq ""} {
#*** !doctools
#[list_begin enumerated]
# oo::class create interface_sample1 {
# #*** !doctools
# #[enum] CLASS [class interface_sample1]
# #[list_begin definitions]
# method test {arg1} {
# #*** !doctools
# #[call class::interface_sample1 [method test] [arg arg1]]
# #[para] test method
# puts "test: $arg1"
# }
# #*** !doctools
# #[list_end] [comment {-- end definitions interface_sample1}]
# }
#*** !doctools
#[list_end] [comment {--- end class enumeration ---}]
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Base namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::sshrun {
namespace export *
variable ssh;
array set ssh {};
#*** !doctools
#[subsection {Namespace punk::sshrun}]
#[para] Core API functions for punk::sshrun
#[list_begin definitions]
proc connect {args} {
#*** !doctools
#[call connect [arg args]]
#[para] Must be called first.
#[para] This proc opens an io channel to the tclsh in the remote host (via ssh) that is kept in an internal variable for subsequent use.
#[para] The file handle can be retrieved if desired through the command: get_filehandle {host}
variable ssh;
set usage {connect [-t <tclsh_name>] [-- <ssh_options>]
[<user>@]<host>};
set optlist {{t.arg "tclsh"}};
array set option [::cmdline::getoptions args $optlist $usage];
set cmd [concat "|ssh" $args $option(t) 2>@ stdout];
set F [open $cmd r+];
set host [lindex $args end];
if {[regexp {(.*)@(.*)} $host match s1 s2]} {
set user $s1;
set host $s2;
}
# These are the only internal variables (apart from the "user" variables).
set ssh($host,F) $F;
set ssh($host,script) [list];
}
proc disconnect {host} {
#*** !doctools
# [call disconnect [arg host]]
# [para] Must be called last. Closes the filehandle opened by connect.
variable ssh;
system::_verify_connection $host;
set status [catch {
close $ssh($host,F);
} errmsg];
unset ssh($host,F);
unset ssh($host,script);
if {$status != 0} {
return -code error $errmsg;
}
}
proc push {host script} {
#*** !doctools
# [call push [arg host] [arg script]]
# [para] <script> can be any tcl code.
# [para] For example, if the remote host is named "diablo"
# [example {
# ssh::push "diablo" "exec date"
# ssh::push "diablo" "exec uname -a"
# }]
# [para] The commands are note executed immediately. Instead, the "push" proc simply accumulates them in a list that is sent to the host when the "send" procedure is executed.
# [para] Each push proc inserts the newline '\n' character after each <script>
# [para] In the above example. Internally, each <script> is a member of a list, and when the "send" proc is invoked the entire script is constructed as a "join <list> \n
variable ssh;
system::_verify_connection $host;
lappend ssh($host,script) $script;
}
proc send {host} {
#*** !doctools
# [call send [arg host]]
# [para]This proc does the equivalent of a
# [example {
# puts <filehandle> [join <script_list> \n]
# flush <filehandle>
# }]
variable ssh;
system::_verify_connection $host;
set status [catch {
puts $ssh($host,F) [join $ssh($host,script) "\n"];
flush $ssh($host,F);
} errmsg];
set ssh($host,script) [list];
if {$status != 0} {
return -code error $errmsg;
}
}
proc send_exit {host} {
#*** !doctools
# [call send_exit [arg host]]
# [para] This proc is similar to the above, but it "pushes" an exit command at the end of the script. The proc does the equivalent of
# [example {
# ssh::push <host> "exit"
# ssh::send <host>
# }]
# [para] The net effect if this is that the remote host's tclsh will exit, so that the filehandle receives an eof and we can use
# [example {
# [read <filehandle>]
# }]
# [para]to read the entire output at once (see the pop proc below)
push $host "exit";
send $host;
}
proc pop_line {host line_varname} {
#*** !doctools
# [call pop_line [arg host] [arg line_varname]]
# [para]After executing a "send", this can be used to read one line of output. The proc does the equivalent of
# [example {
# [gets <filehandle> line]
# }]
upvar $line_varname line;
variable ssh;
system::_verify_connection $host;
set r [gets $ssh($host,F) line];
return $r;
}
proc pop_all {host output_varname} {
#*** !doctools
# [call pop_all [arg host] [arg output_varname]]
# [para]This proc does the equivalent of
# [example {
# while {[pop_line $host line] >=0} {
# puts $line;
# }
# }]
# [para] but all the output is returned as one string in output_varname.
# [para]It should be used only when we know that the remote host's tclsh will exit, so that the above code will detect the eof and exit
# [para](see the send_exit proc above)
# [para]The function returns the number of lines read (0 if nothing is read before encoutering eof)
#
upvar $output_varname output;
variable ssh;
system::_verify_connection $host;
set r 0;
set output_list [list];
while {[pop_line $host line] >= 0} {
incr r;
lappend output_list $line;
}
set output [join $output_list "\n"];
return $r;
}
proc pop_read {host numbytes output_varname} {
#*** !doctools
# [call pop_read [arg host] [arg numbytes] [arg output_varname]]
# [para] Returns: numbytes read. If numbytes is not positive, then read is called without the numbytes argument.
upvar $output_varname output;
variable ssh;
system::_verify_connection $host;
if {$numbytes <= 0} {
set output [read $ssh($host,F)];
} else {
set output [read $ssh($host,F) $numbytes];
}
return [string length $output];
}
proc hfileevent {host readable_writable script} {
#*** !doctools
# [call hfileevent [arg host] [arg readable_writable] [arg script]]
# [para] Equivalent to:
# [example {
# fileevent <filehandle> $readable_writable $script
# }]
variable ssh;
system::_verify_connection $host;
fileevent $ssh($host,F) $readable_writable $script;
}
proc hfconfigure {host args} {
#*** !doctools
# [call hconfigure [arg host] [arg args]]
variable ssh;
system::_verify_connection $host;
eval fconfigure $ssh($host,F) $args;
}
proc rexec {host script output_varname} {
#*** !doctools
# [call rexec [arg host] [arg script] [arg output_varname]]
# [para] shortcut for:
# [example {
# ssh::rexec_nopop $host $script
# ssh::pop_all $host outputvar
# }]
upvar $output_varname output;
rexec_nopop $host $script;
pop_all $host output;
}
proc rexec_nopop {host script} {
push $host $script;
send_exit $host;
}
#
# Utility
#
proc set_var {host var val} {
variable ssh;
# These functions can be used even when there is no valid connection
# and therefore we do not call _verify_connection here.
set ssh($host,user,$var) $val;
}
proc get_var {host var} {
variable ssh;
if {[info exists ssh($host,user,$var)] == 0} {
return -code error "$var not defined";
}
return $ssh($host,user,$var);
}
proc incr_var {host var {step 1}} {
variable ssh;
if {[info exists ssh($host,user,$var)] == 0} {
return -code error "$var not defined";
}
puts "incr ssh($host,user,$var) by $step";
incr ssh($host,user,$var) $step;
}
proc set_lvar {var val} {
set host "localhost";
set_var $host $var $val;
}
proc get_lvar {var} {
set host "localhost";
set status [catch {
set r [get_var $host $var];
} errmsg];
if {$status != 0} {
return -code error $errmsg;
}
return $r;
}
proc incr_lvar {var {step 1}} {
set host "localhost";
incr_var $host $var $step;
}
#
# low level
#
proc get_filehandle {host} {
#*** !doctools
# [call get_filehandle [arg host]]
variable ssh;
system::_verify_connection $host;
return $ssh($host,F);
}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::sshrun ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::sshrun::lib {
namespace export *
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace punk::sshrun::lib}]
#[para] Secondary functions that are part of the API
#[list_begin definitions]
#proc utility1 {p1 args} {
# #*** !doctools
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]]
# #[para]Description of utility1
# return 1
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::sshrun::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval punk::sshrun::system {
#*** !doctools
#[subsection {Namespace punk::sshrun::system}]
#[para] Internal functions that are not part of the API
#
# private
#
proc _verify_connection {host} {
upvar ::punk::sshrun::ssh ssh
#variable ssh;
if {[info exists ssh($host,F)]} {
return 1;
}
return -code error "There is no connection to $host.";
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::sshrun [namespace eval punk::sshrun {
variable pkg punk::sshrun
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/modules/punk/sshrun-buildversion.txt

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

963
src/vendormodules/overtype-1.5.1.tm

@ -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]

1036
src/vendormodules/overtype-1.5.2.tm

File diff suppressed because it is too large Load Diff

1037
src/vendormodules/overtype-1.5.3.tm

File diff suppressed because it is too large Load Diff

928
src/vendormodules/overtype-1.5.6.tm

@ -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]

1034
src/vendormodules/overtype-1.5.7.tm

File diff suppressed because it is too large Load Diff

2409
src/vendormodules/overtype-1.5.8.tm

File diff suppressed because it is too large Load Diff

2428
src/vendormodules/overtype-1.5.9.tm

File diff suppressed because it is too large Load Diff

3333
src/vendormodules/overtype-1.6.0.tm

File diff suppressed because it is too large Load Diff

3399
src/vendormodules/overtype-1.6.1.tm

File diff suppressed because it is too large Load Diff

3415
src/vendormodules/overtype-1.6.2.tm

File diff suppressed because it is too large Load Diff
Loading…
Cancel
Save