From 52d5bab868b38370423b7a0342165a6db5a11289 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Fri, 23 Feb 2024 08:16:51 +1100 Subject: [PATCH] ansi and repl fixes - and support libraries --- src/bootsupport/include_modules.config | 4 + src/bootsupport/modules/dictutils-0.2.1.tm | 145 + src/bootsupport/modules/overtype-1.5.6.tm | 928 ++++++ src/bootsupport/modules/overtype-1.5.7.tm | 998 ++++++ src/bootsupport/modules/punk/ansi-0.1.1.tm | 79 +- src/bootsupport/modules/punk/char-0.1.0.tm | 79 +- src/bootsupport/modules/punk/console-0.1.1.tm | 316 +- src/bootsupport/modules/punk/du-0.1.0.tm | 2 +- src/bootsupport/modules/punk/lib-0.1.0.tm | 19 +- .../punk/mix/commandset/loadedlib-0.1.0.tm | 15 +- .../modules/punk/mix/util-0.1.0.tm | 4 + src/bootsupport/modules/punk/repo-0.1.1.tm | 3 + src/modules/patternpunk-1.1.tm | 55 +- src/modules/punk-0.1.tm | 28 +- src/modules/punk/ansi-999999.0a1.0.tm | 525 ++- src/modules/punk/args-999999.0a1.0.tm | 4 +- src/modules/punk/char-999999.0a1.0.tm | 104 +- src/modules/punk/console-999999.0a1.0.tm | 906 ++++-- src/modules/punk/du-999999.0a1.0.tm | 2 +- src/modules/punk/encmime-999999.0a1.0.tm | 4 +- src/modules/punk/fileline-999999.0a1.0.tm | 9 +- src/modules/punk/flib-999999.0a1.0.tm | 4 +- src/modules/punk/lib-999999.0a1.0.tm | 155 +- .../mix/commandset/layout-999999.0a1.0.tm | 8 +- .../mix/commandset/project-999999.0a1.0.tm | 4 +- .../templates/layouts/project/src/build.tcl | 6 + .../templates/layouts/project/src/make.tcl | 995 ++++++ .../templates/modules/template_cli-0.0.1.tm | 4 +- .../modules/template_module-0.0.1.tm | 4 +- src/modules/punk/ns-999999.0a1.0.tm | 3 +- src/modules/punk/path-999999.0a1.0.tm | 4 +- src/modules/punk/repl-0.1.tm | 1021 ++++-- src/modules/punkapp-0.1.tm | 3 +- src/modules/shellrun-0.1.1.tm | 11 +- src/modules/textblock-999999.0a1.0.tm | 337 +- src/vendorlib/base64/ascii85.tcl | 271 ++ src/vendorlib/base64/base64.tcl | 410 +++ src/vendorlib/base64/base64c.tcl | 19 + src/vendorlib/base64/pkgIndex.tcl | 5 + src/vendorlib/base64/uuencode.tcl | 335 ++ src/vendorlib/base64/yencode.tcl | 307 ++ src/vendorlib/control/ascaller.tcl | 72 + src/vendorlib/control/assert.tcl | 91 + src/vendorlib/control/control.tcl | 24 + src/vendorlib/control/do.tcl | 81 + src/vendorlib/control/no-op.tcl | 14 + src/vendorlib/control/pkgIndex.tcl | 2 + src/vendorlib/control/tclIndex | 18 + src/vendorlib/debug/caller.tcl | 97 + src/vendorlib/debug/debug.tcl | 306 ++ src/vendorlib/debug/heartbeat.tcl | 68 + src/vendorlib/debug/pkgIndex.tcl | 5 + src/vendorlib/debug/timestamp.tcl | 47 + src/vendorlib/term/ansi/code.tcl | 56 + src/vendorlib/term/ansi/code/attr.tcl | 108 + src/vendorlib/term/ansi/code/ctrl.tcl | 272 ++ src/vendorlib/term/ansi/code/macros.tcl | 93 + src/vendorlib/term/ansi/ctrlunix.tcl | 91 + src/vendorlib/term/ansi/send.tcl | 92 + src/vendorlib/term/bind.tcl | 132 + src/vendorlib/term/imenu.tcl | 202 ++ src/vendorlib/term/ipager.tcl | 206 ++ src/vendorlib/term/pkgIndex.tcl | 13 + src/vendorlib/term/receive.tcl | 60 + src/vendorlib/term/send.tcl | 34 + src/vendorlib/term/term.tcl | 19 + src/vendormodules/cmdline-1.5.2.tm | 933 ++++++ src/vendormodules/csv-0.9.tm | 787 +++++ src/vendormodules/dictutils-0.2.1.tm | 145 + src/vendormodules/fileutil-1.16.1.tm | 2311 ++++++++++++++ src/vendormodules/overtype-1.5.6.tm | 928 ++++++ src/vendormodules/overtype-1.5.7.tm | 1034 ++++++ src/vendormodules/overtype-1.5.8.tm | 1547 +++++++++ src/vendormodules/struct/list-1.8.5.tm | 1834 +++++++++++ src/vendormodules/struct/matrix-2.1.tm | 2806 +++++++++++++++++ src/vendormodules/struct/set-2.2.3.tm | 189 ++ src/vendormodules/struct/sets.tcl | 189 ++ src/vendormodules/struct/sets_c.tcl | 93 + src/vendormodules/struct/sets_tcl.tcl | 452 +++ src/vendormodules/textutil-0.9.tm | 80 + src/vendormodules/textutil/adjust-0.7.3.tm | 761 +++++ src/vendormodules/textutil/dehypht.tex | 902 ++++++ src/vendormodules/textutil/eshyph_vo.tex | 1104 +++++++ src/vendormodules/textutil/expander-1.3.1.tm | 1122 +++++++ src/vendormodules/textutil/ithyph.tex | 223 ++ src/vendormodules/textutil/patch-0.1.tm | 180 ++ src/vendormodules/textutil/repeat-0.7.tm | 91 + src/vendormodules/textutil/split-0.8.tm | 176 ++ src/vendormodules/textutil/string-0.8.tm | 144 + src/vendormodules/textutil/tabify-0.7.tm | 289 ++ src/vendormodules/textutil/trim-0.7.tm | 112 + src/vendormodules/textutil/wcswidth-35.1.tm | 772 +++++ 92 files changed, 28812 insertions(+), 730 deletions(-) create mode 100644 src/bootsupport/modules/dictutils-0.2.1.tm create mode 100644 src/bootsupport/modules/overtype-1.5.6.tm create mode 100644 src/bootsupport/modules/overtype-1.5.7.tm create mode 100644 src/modules/punk/mix/templates/layouts/project/src/build.tcl create mode 100644 src/modules/punk/mix/templates/layouts/project/src/make.tcl create mode 100644 src/vendorlib/base64/ascii85.tcl create mode 100644 src/vendorlib/base64/base64.tcl create mode 100644 src/vendorlib/base64/base64c.tcl create mode 100644 src/vendorlib/base64/pkgIndex.tcl create mode 100644 src/vendorlib/base64/uuencode.tcl create mode 100644 src/vendorlib/base64/yencode.tcl create mode 100644 src/vendorlib/control/ascaller.tcl create mode 100644 src/vendorlib/control/assert.tcl create mode 100644 src/vendorlib/control/control.tcl create mode 100644 src/vendorlib/control/do.tcl create mode 100644 src/vendorlib/control/no-op.tcl create mode 100644 src/vendorlib/control/pkgIndex.tcl create mode 100644 src/vendorlib/control/tclIndex create mode 100644 src/vendorlib/debug/caller.tcl create mode 100644 src/vendorlib/debug/debug.tcl create mode 100644 src/vendorlib/debug/heartbeat.tcl create mode 100644 src/vendorlib/debug/pkgIndex.tcl create mode 100644 src/vendorlib/debug/timestamp.tcl create mode 100644 src/vendorlib/term/ansi/code.tcl create mode 100644 src/vendorlib/term/ansi/code/attr.tcl create mode 100644 src/vendorlib/term/ansi/code/ctrl.tcl create mode 100644 src/vendorlib/term/ansi/code/macros.tcl create mode 100644 src/vendorlib/term/ansi/ctrlunix.tcl create mode 100644 src/vendorlib/term/ansi/send.tcl create mode 100644 src/vendorlib/term/bind.tcl create mode 100644 src/vendorlib/term/imenu.tcl create mode 100644 src/vendorlib/term/ipager.tcl create mode 100644 src/vendorlib/term/pkgIndex.tcl create mode 100644 src/vendorlib/term/receive.tcl create mode 100644 src/vendorlib/term/send.tcl create mode 100644 src/vendorlib/term/term.tcl create mode 100644 src/vendormodules/cmdline-1.5.2.tm create mode 100644 src/vendormodules/csv-0.9.tm create mode 100644 src/vendormodules/dictutils-0.2.1.tm create mode 100644 src/vendormodules/fileutil-1.16.1.tm create mode 100644 src/vendormodules/overtype-1.5.6.tm create mode 100644 src/vendormodules/overtype-1.5.7.tm create mode 100644 src/vendormodules/overtype-1.5.8.tm create mode 100644 src/vendormodules/struct/list-1.8.5.tm create mode 100644 src/vendormodules/struct/matrix-2.1.tm create mode 100644 src/vendormodules/struct/set-2.2.3.tm create mode 100644 src/vendormodules/struct/sets.tcl create mode 100644 src/vendormodules/struct/sets_c.tcl create mode 100644 src/vendormodules/struct/sets_tcl.tcl create mode 100644 src/vendormodules/textutil-0.9.tm create mode 100644 src/vendormodules/textutil/adjust-0.7.3.tm create mode 100644 src/vendormodules/textutil/dehypht.tex create mode 100644 src/vendormodules/textutil/eshyph_vo.tex create mode 100644 src/vendormodules/textutil/expander-1.3.1.tm create mode 100644 src/vendormodules/textutil/ithyph.tex create mode 100644 src/vendormodules/textutil/patch-0.1.tm create mode 100644 src/vendormodules/textutil/repeat-0.7.tm create mode 100644 src/vendormodules/textutil/split-0.8.tm create mode 100644 src/vendormodules/textutil/string-0.8.tm create mode 100644 src/vendormodules/textutil/tabify-0.7.tm create mode 100644 src/vendormodules/textutil/trim-0.7.tm create mode 100644 src/vendormodules/textutil/wcswidth-35.1.tm diff --git a/src/bootsupport/include_modules.config b/src/bootsupport/include_modules.config index 4c31e884..1a0b1755 100644 --- a/src/bootsupport/include_modules.config +++ b/src/bootsupport/include_modules.config @@ -6,6 +6,10 @@ set bootsupport_modules [list\ src/vendormodules overtype\ src/vendormodules oolib\ src/vendormodules http\ + src/vendormodules dictutils\ + src/vendormodules fileutil\ + src/vendormodules textutil::tabify\ + src/vendormodules textutil::split\ modules punkcheck\ modules punk::ansi\ modules punk::args\ diff --git a/src/bootsupport/modules/dictutils-0.2.1.tm b/src/bootsupport/modules/dictutils-0.2.1.tm new file mode 100644 index 00000000..cd6b4e58 --- /dev/null +++ b/src/bootsupport/modules/dictutils-0.2.1.tm @@ -0,0 +1,145 @@ +# dictutils.tcl -- + # + # Various dictionary utilities. + # + # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). + # + # License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). + # + + #2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" + + package require Tcl 8.6- + package provide dictutils 0.2.1 + + namespace eval dictutils { + namespace export equal apply capture witharray nlappend + namespace ensemble create + + # dictutils witharray dictVar arrayVar script -- + # + # Unpacks the elements of the dictionary in dictVar into the array + # variable arrayVar and then evaluates the script. If the script + # completes with an ok, return or continue status, then the result is copied + # back into the dictionary variable, otherwise it is discarded. A + # [break] can be used to explicitly abort the transaction. + # + proc witharray {dictVar arrayVar script} { + upvar 1 $dictVar dict $arrayVar array + array set array $dict + try { uplevel 1 $script + } on break {} { # Discard the result + } on continue result - on ok result { + set dict [array get array] ;# commit changes + return $result + } on return {result opts} { + set dict [array get array] ;# commit changes + dict incr opts -level ;# remove this proc from level + return -options $opts $result + } + # All other cases will discard the changes and propagage + } + + # dictutils equal equalp d1 d2 -- + # + # Compare two dictionaries for equality. Two dictionaries are equal + # if they (a) have the same keys, (b) the corresponding values for + # each key in the two dictionaries are equal when compared using the + # equality predicate, equalp (passed as an argument). The equality + # predicate is invoked with the key and the two values from each + # dictionary as arguments. + # + proc equal {equalp d1 d2} { + if {[dict size $d1] != [dict size $d2]} { return 0 } + dict for {k v} $d1 { + if {![dict exists $d2 $k]} { return 0 } + if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } + } + return 1 + } + + # apply dictVar lambdaExpr ?arg1 arg2 ...? -- + # + # A combination of *dict with* and *apply*, this procedure creates a + # new procedure scope populated with the values in the dictionary + # variable. It then applies the lambdaTerm (anonymous procedure) in + # this new scope. If the procedure completes normally, then any + # changes made to variables in the dictionary are reflected back to + # the dictionary variable, otherwise they are ignored. This provides + # a transaction-style semantics whereby atomic updates to a + # dictionary can be performed. This procedure can also be useful for + # implementing a variety of control constructs, such as mutable + # closures. + # + proc apply {dictVar lambdaExpr args} { + upvar 1 $dictVar dict + set env $dict ;# copy + lassign $lambdaExpr params body ns + if {$ns eq ""} { set ns "::" } + set body [format { + upvar 1 env __env__ + dict with __env__ %s + } [list $body]] + set lambdaExpr [list $params $body $ns] + set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] + if {$rc == 0} { + # Copy back any updates + set dict $env + } + return -options $opts $ret + } + + # capture ?level? ?exclude? ?include? -- + # + # Captures a snapshot of the current (scalar) variable bindings at + # $level on the stack into a dictionary environment. This dictionary + # can later be used with *dictutils apply* to partially restore the + # scope, creating a first approximation of closures. The *level* + # argument should be of the forms accepted by *uplevel* and + # designates which level to capture. It defaults to 1 as in uplevel. + # The *exclude* argument specifies an optional list of literal + # variable names to avoid when performing the capture. No variables + # matching any item in this list will be captured. The *include* + # argument can be used to specify a list of glob patterns of + # variables to capture. Only variables matching one of these + # patterns are captured. The default is a single pattern "*", for + # capturing all visible variables (as determined by *info vars*). + # + proc capture {{level 1} {exclude {}} {include {*}}} { + if {[string is integer $level]} { incr level } + set env [dict create] + foreach pattern $include { + foreach name [uplevel $level [list info vars $pattern]] { + if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } + upvar $level $name value + catch { dict set env $name $value } ;# no arrays + } + } + return $env + } + + # nlappend dictVar keyList ?value ...? + # + # Append zero or more elements to the list value stored in the given + # dictionary at the path of keys specified in $keyList. If $keyList + # specifies a non-existent path of keys, nlappend will behave as if + # the path mapped to an empty list. + # + proc nlappend {dictvar keylist args} { + upvar 1 $dictvar dict + if {[info exists dict] && [dict exists $dict {*}$keylist]} { + set list [dict get $dict {*}$keylist] + } + lappend list {*}$args + dict set dict {*}$keylist $list + } + + # invoke cmd args... -- + # + # Helper procedure to invoke a callback command with arguments at + # the global scope. The helper ensures that proper quotation is + # used. The command is expected to be a list, e.g. {string equal}. + # + proc invoke {cmd args} { uplevel #0 $cmd $args } + + } diff --git a/src/bootsupport/modules/overtype-1.5.6.tm b/src/bootsupport/modules/overtype-1.5.6.tm new file mode 100644 index 00000000..5c56838b --- /dev/null +++ b/src/bootsupport/modules/overtype-1.5.6.tm @@ -0,0 +1,928 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 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 - 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|]? ?-exposed1 ? ?-exposed2 ? ?-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 ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-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 ? ?-transparent [0|1|]? ?-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 ? ?-transparent [0|1|]? ?-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 ]] 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] diff --git a/src/bootsupport/modules/overtype-1.5.7.tm b/src/bootsupport/modules/overtype-1.5.7.tm new file mode 100644 index 00000000..aefb0840 --- /dev/null +++ b/src/bootsupport/modules/overtype-1.5.7.tm @@ -0,0 +1,998 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 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 - 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|]? ?-exposed1 ? ?-exposed2 ? ?-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 ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-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 ? ?-transparent [0|1|]? ?-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 ? ?-transparent [0|1|]? ?-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 ]] 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] diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index af5f13ce..786a83cf 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -167,6 +167,9 @@ namespace eval punk::ansi { proc controlstring_APC8 {text} { return "\x9f${text}\x9c" } + #there is also the SGR hide code (8) which has intermittent terminal support + #This doesn't change the output length - so support is tricky to detec. (terminal checksum report?) + #candidate for zig/c implementation? proc stripansi {text} { @@ -199,7 +202,8 @@ namespace eval punk::ansi { set outputlist [list] set in_escapesequence 0 - #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls + #assumption - text already 'rendered' - ie no cursor movement controls . (what about backspace and lone carriage returns - they are horizontal cursor movements) + set i 0 foreach u $inputlist { set v [lindex $inputlist $i+1] @@ -598,12 +602,13 @@ namespace eval punk::ansi { proc move_column {col} { #*** !doctools #[call [fun move_column] [arg col]] - return \x1b\[${col}g + return \x1b\[${col}G } proc move_row {row} { #*** !doctools #[call [fun move_row] [arg row]] - return \x1b\[${row}G + #[para]VPA - Vertical Line Position Absolute + return \x1b\[${row}d } # -- --- --- --- --- @@ -686,6 +691,22 @@ namespace eval punk::ansi { return \033\[6n } + proc request_cursor_information {} { + #*** !doctools + #[call [fun request_cursor_information]] + #[para]DECRQPSR (DEC Request Presentation State Report) for DECCCIR Cursor Information report + #[para]When written to the terminal, this sequence causes the terminal to emit cursor information to stdin + #[para]A stdin readloop will need to be in place to read this information + return \x1b\[1\$w + } + proc request_tabstops {} { + #*** !doctools + #[call [fun request_tabstops]] + #[para]DECRQPSR (DEC Request Presentation State Report) for DECTABSR Tab stop report + #[para]When written to the terminal, this sequence causes the terminal to emit tabstop information to stdin + return \x1b\[2\$w + } + #alternative to string terminator is \007 - proc titleset {windowtitle} { @@ -811,7 +832,7 @@ namespace eval punk::ansi { } 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)$} + regexp {\033\[[0-9]*(:?C|D|G)$} $code } #pure SGR reset with no other functions proc is_sgr_reset {code} { @@ -1254,7 +1275,7 @@ namespace eval punk::ansi::ansistring { APC [list \x9f \ue03f]\ ] #it turns out we need pretty much everything for debugging - set visuals [dict create\ + set visuals_c0 [dict create\ NUL [list \x00 \u2400]\ SOH [list \x01 \u2401]\ STX [list \x02 \u2402]\ @@ -1282,41 +1303,71 @@ namespace eval punk::ansi::ansistring { RS [list \x1e \u241e]\ US [list \x1f \u241f]\ DEL [list \x7f \u2421]\ + ] + set visuals_c1 [dict create\ + BPH [list \x82 \ue022]\ + NBH [list \x83 \ue023]\ + IND [list \x84 \ue024]\ + NEL [list \x85 \ue025]\ + SSA [list \x86 \ue026]\ + ESA [list \x87 \ue027]\ + HTS [list \x88 \ue028]\ + HTJ [list \x89 \ue029]\ + VTS [list \x8a \ue02a]\ + PLD [list \x8b \ue02a]\ + PLU [list \x8c \ue02c]\ + RI [list \x8d \ue02d]\ + SS2 [list \x8e \ue02e]\ + SS3 [list \x8f \ue02f]\ + DCS [list \x90 \ue030]\ + PU1 [list \x91 \ue031]\ + PU2 [list \x92 \ue032]\ + STS [list \x93 \ue033]\ + CCH [list \x94 \ue034]\ + MW [list \x95 \ue035]\ + SPA [list \x96 \ue036]\ + EPA [list \x97 \ue037]\ SOS [list \x98 \ue038]\ + SCI [list \x9a \ue03a]\ CSI [list \x9b \ue03b]\ ST [list \x9c \ue03c]\ + OSC [list \x9d \ue03d]\ PM [list \x9e \ue03e]\ APC [list \x9f \ue03f]\ ] + + set visuals_opt [dict create] if {$opt_esc} { - dict set visuals VT [list \x1b \u241b] + dict set visuals_opt ESC [list \x1b \u241b] } if {$opt_cr} { - dict set visuals CR [list \x0d \u240d] + dict set visuals_opt CR [list \x0d \u240d] } if {$opt_lf} { - dict set visuals LF [list \x0a \u240a] + dict set visuals_opt LF [list \x0a \u240a] } if {$opt_vt} { - dict set visuals VT [list \x0b \u240b] + dict set visuals_opt VT [list \x0b \u240b] } if {$opt_ht} { - dict set visuals HT [list \x09 \u2409] + dict set visuals_opt HT [list \x09 \u2409] } if {$opt_bs} { - dict set visuals BS [list \x08 \u2408] + dict set visuals_opt BS [list \x08 \u2408] } if {$opt_sp} { - dict set visuals SP [list \x20 \u2420] + dict set visuals_opt SP [list \x20 \u2420] } + set visuals [dict merge $visuals_opt $visuals_c0 $visuals_c1] set charmap [list] dict for {nm chars} $visuals { lappend charmap {*}$chars } return [string map $charmap $string] - #ISO2047 - 7bit - limited set, limited support + + #test of ISO2047 - 7bit - limited set, limited support, somewhat obscure glyphs #return [string map [list \033 \U2296 \007 \U237E] $string] } @@ -1326,7 +1377,7 @@ namespace eval punk::ansi::ansistring { #[para]Returns the length of the string without ansi codes #[para]This will not count strings hidden inside a 'privacy message' or other ansi codes which may have content between their opening escape and their termination sequence. #[para]This is equivalent to calling string length on the result of stripansi $string - #[para]Note that this returns the number of characters in the payload, and is not always the same as the width of the string as rendered on a terminal. + #[para]Note that this returns the number of characters in the payload (after applying combiners), and is not always the same as the width of the string as rendered on a terminal. #[para]To get the width, use punk::ansi::printing_length instead, which is also ansi aware. string length [stripansi $string] } diff --git a/src/bootsupport/modules/punk/char-0.1.0.tm b/src/bootsupport/modules/punk/char-0.1.0.tm index 19804805..7fc85017 100644 --- a/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/bootsupport/modules/punk/char-0.1.0.tm @@ -1796,12 +1796,21 @@ namespace eval punk::char { #review - what about \r \t \b ? proc string_width {text} { #review is detecting \033 enough? what about 8-bit escapes? + if {[string first \n $text] >= 0} { error "string_width accepts only a single line" } - if {[string first \033 $text] >= 0} { - error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first" - } + + + #we can c0 control characters after or while processing ansi escapes. + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error + #if {[string first \033 $text] >= 0} { + # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first" + #} + set re_ascii_c0 {[\U0000-\U001F]} + set text [regsub -all $re_ascii_c0 $text ""] + #todo - check double-width chars in unicode blocks.. try to do reasonably quicky #short-circuit basic cases if {![regexp {[\uFF-\U10FFFF]} $text]} { @@ -1822,9 +1831,16 @@ namespace eval punk::char { # # initial simplistic approach is just to strip these ... todo REVIEW + #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width + #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #if {[regexp $re_leading_diacritic $text]} { + # set text " $text" + #} set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] + set re_ascii_fullwidth {[\uFF01-\uFF5e]} set doublewidth_char_count 0 @@ -1858,13 +1874,13 @@ namespace eval punk::char { #This shouldn't be called on text containing ansi codes! proc strip_nonprinting_ascii {str} { - #review - some single-byte 'control' chars have visual representations e.g ETX as heart + #review - some single-byte 'control' chars have visual representations e.g ETX as heart depending on font/codepage #It is currently used for screen display width calculations #equivalent for various unicode combining chars etc? set map [list\ - \007 ""\ - [format %c 0] ""\ - [format %c 0x7f] ""\ + \x00 ""\ + \x07 ""\ + \x7f ""\ ] return [string map $map $str] } @@ -1877,6 +1893,55 @@ namespace eval punk::char { error "char_uc_width unimplemented" } + + #split into plaintext and runs of combiners + proc combiner_split {text} { + #split into odd numbered list (or zero) in a similar way to punk::ansi::ta::_perlish_split + # + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set graphemes [list] + set g "" + if {[string length $text] == 0} { + return {} + } + set list [list] + set start 0 + set strlen [string length $text] + #make sure our regexes aren't non-greedy - or we may not have exit condition for loop + #review + while {$start < $strlen && [regexp -start $start -indices -- $re_diacritics $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd] + set start [expr {$matchEnd+1}] + + #if {$start >= [string length $text]} { + # break + #} + } + lappend list [string range $text $start end] + + return $list + } + + #1st shot - basic diacritics + #todo - become aware of unicode grapheme cluster boundaries + # + proc grapheme_split {text} { + set graphemes [list] + set csplits [combiner_split $text] + foreach {pt combiners} [lrange $csplits 0 end-1] { + set clist [split $pt ""] + lappend graphemes {*}[lrange $clist 0 end-1] + lappend graphemes [string cat [lindex $clist end] $combiners] + } + #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme + if {[lindex $csplits end] ne ""} { + lappend graphemes {*}[split [lindex $csplits end] ""] + } + return $graphemes + } + # -- --- --- --- --- #will accept a single char or a string - test using console cursor position reporting proc char_info_testwidth {ch {emit 0}} { diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 944f818c..358bc5d3 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -80,6 +80,12 @@ namespace eval punk::console { internal::abort_if_loop tailcall enableVirtualTerminal } + proc disableVirtualTerminal {} { + #loopavoidancetoken (don't remove) + internal::define_windows_procs + internal::abort_if_loop + tailcall disableVirtualTerminal + } } else { proc enableAnsi {} { #todo? @@ -105,12 +111,19 @@ namespace eval punk::console { if {[set previous_stty_state_$channel] ne ""} { exec {*}$sttycmd [set previous_stty_state_$channel] set previous_stty_state_$channel "" + set is_raw 0 return restored } exec {*}$sttycmd -raw echo <@$channel set is_raw 0 return done } + proc enableVirtualTerminal {} { + + } + proc disableVirtualTerminal {} { + + } } proc enable_mouse {} { @@ -142,6 +155,27 @@ namespace eval punk::console { enable_bracketed_paste } + proc mode {{raw_or_line query}} { + variable is_raw + set raw_or_line [string tolower $raw_or_line] + if {$raw_or_line eq "query"} { + if {$is_raw} { + return "raw" + } else { + return "line" + } + } elseif {$raw_or_line eq "raw"} { + punk::console::enableRaw + punk::console::enableVirtualTerminal both + } elseif {$raw_or_line eq "line"} { + #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) + punk::console::disableRaw + punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc + punk::console::enableVirtualTerminal output ;#display/use ansi codes + } else { + error "punk::console::mode expected 'raw' or 'line' or default value 'query' + } + } namespace eval internal { proc abort_if_loop {{failmsg ""}} { @@ -162,6 +196,10 @@ namespace eval punk::console { proc define_windows_procs {} { package require zzzload set loadstate [zzzload::pkg_require twapi] + + #loadstate could also be stuck on loading? - review - zzzload not very ripe + #Twapi is relatively slow to load - can be 1s plus in normal cases - and much longer if there are disk performance issues. + if {$loadstate ni [list failed]} { #review zzzload usage #puts stdout "=========== console loading twapi =============" @@ -220,17 +258,88 @@ namespace eval punk::console { return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] } - proc [namespace parent]::enableVirtualTerminal {} { - set h_out [twapi::get_console_handle stdout] - set oldmode_out [twapi::GetConsoleMode $h_out] - set newmode_out [expr {$oldmode_out | 4}] - twapi::SetConsoleMode $h_out $newmode_out + # + proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #note setting stdout makes stderr have the same settings - ie there is really only one output to configure + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode | 4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 0x200}] - twapi::SetConsoleMode $h_in $newmode_in - return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + return $result + } + proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #as above - configuring stdout does stderr too + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode & ~4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + + #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + return $result } proc [namespace parent]::enableProcessedInput {} { @@ -249,47 +358,94 @@ namespace eval punk::console { } - proc [namespace parent]::enableRaw {{channel stdin}} { - variable is_raw - #review - change to modify_console_input_mode - set console_handle [twapi::GetStdHandle -10] - set oldmode [twapi::GetConsoleMode $console_handle] - set newmode [expr {$oldmode & ~6}] ;# Turn off the echo and line-editing bits - twapi::SetConsoleMode $console_handle $newmode - set is_raw 1 - #don't disable handler - it will detect is_raw - ### twapi::set_console_control_handler {} - return [list stdin [list from $oldmode to $newmode]] + + } else { + + puts stderr "punk::console falling back to stty because twapi load failed" + proc [namespace parent]::enableAnsi {} { + puts stderr "punk::console::enableAnsi todo" } - proc [namespace parent]::disableRaw {{channel stdin}} { - variable is_raw - set console_handle [twapi::GetStdHandle -10] - set oldmode [twapi::GetConsoleMode $console_handle] - set newmode [expr {$oldmode | 6}] ;# Turn on the echo and line-editing bits - twapi::SetConsoleMode $console_handle $newmode - set is_raw 0 - return [list stdin [list from $oldmode to $newmode]] + proc [namespace parent]::disableAnsi {} { + } + #? + proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} { + } + proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { } - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::console falling back to stty because twapi load failed" - proc [namespace parent]::enableAnsi {} { - puts stderr "punk::console::enableAnsi todo" - } - proc [namespace parent]::enableRaw {{channel stdin}} { - set sttycmd [auto_execok stty] + } + + proc [namespace parent]::enableRaw {{channel stdin}} { + variable is_raw + variable previous_stty_state_$channel + + if {[package provide twapi] ne ""} { + set console_handle [twapi::get_console_handle stdin] + #returns dictionary + #e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0 + set oldmode [twapi::get_console_input_mode] + twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0 + # Turn off the echo and line-editing bits + #set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]] + set newmode [twapi::get_console_input_mode] + + set is_raw 1 + #don't disable handler - it will detect is_raw + ### twapi::set_console_control_handler {} + return [list stdin [list from $oldmode to $newmode]] + } elseif {[set sttycmd [auto_execok stty]] ne ""} { + if {[set previous_stty_state_$channel] eq ""} { + set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] + } + exec {*}$sttycmd raw -echo <@$channel + set is_raw 1 + #review - inconsistent return dict + return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] + } else { + error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" } - proc [namespace parent]::disableRaw {{channel stdin}} { + } + + #note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?) + #could be we were missing a step in reopening stdin and console configuration? + + proc [namespace parent]::disableRaw {{channel stdin}} { + variable is_raw + variable previous_stty_state_$channel + + if {[package provide twapi] ne ""} { + set console_handle [twapi::get_console_handle stdin] + set oldmode [twapi::get_console_input_mode] + # Turn on the echo and line-editing bits + twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1 + set newmode [twapi::get_console_input_mode] + set is_raw 0 + return [list stdin [list from $oldmode to $newmode]] + } elseif {[set sttycmd [auto_execok stty]] ne ""} { set sttycmd [auto_execok stty] - exec {*}$sttycmd raw echo <@$channel + if {[set previous_stty_state_$channel] ne ""} { + exec {*}$sttycmd [set previous_stty_state_$channel] + set previous_stty_state_$channel "" + return restored + } + exec {*}$sttycmd -raw echo <@$channel + set is_raw 0 + #do we really want to exec stty yet again to show final 'to' state? + #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. + return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] + } else { + error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting" } } - } + + } - #review - 1 byte at a time seems inefficient.. + #review - 1 byte at a time seems inefficient... but we don't have a way to peek or put back chars (?) + #todo - timeout - what if terminal doesn't put data on stdin? + #review - what if we slurp in data meant for main loop? Main loop probably needs to detect these responses and store them for lookup *instead* of this handler + #we may still need this handler if such a loop doesn't exist. proc ansi_response_handler {chan accumulatorvar waitvar} { set status [catch {read $chan 1} bytes] if { $status != 0 } { @@ -457,9 +613,14 @@ namespace eval punk::console { set accumulator ::punk::console::chunk set waitvar ::punk::console::chunkdone - set existing_handler [fileevent stdin readable] + set existing_handler [fileevent stdin readable] ;#review! set $waitvar "" - #todo - test and save rawstate so we don't disableRaw if terminal was already raw + + set stdin_state [fconfigure stdin] + + #todo - only use own handler if an existing stdin handler not present.. (or console is in line mode) + + #todo - test and save rawstate so we don't disableRaw if console was already raw if {!$::punk::console::is_raw} { set was_raw 0 enableRaw @@ -467,8 +628,7 @@ namespace eval punk::console { set was_raw 1 } fconfigure stdin -blocking 0 - #review - #fconfigure stdin -blocking 0 -inputmode raw + # fileevent stdin readable [list ::punk::console::internal::ansi_response_handler stdin $accumulator $waitvar] # - stderr vs stdout @@ -478,32 +638,47 @@ namespace eval punk::console { #review - Are there disadvantages to using stdout vs stderr? puts -nonewline stdout \033\[6n ;flush stdout - after 0 {update idletasks} + + + #response from terminal #e.g \033\[46;1R - #todo - reset + + #todo - make timeout configurable? + set cancel_timeout_id [after 2000 [list set $waitvar timedout]] + after 0 {update idletasks} + set info "" if {[set $waitvar] eq ""} { vwait $waitvar } + if {$waitvar ne "timedout"} { + after cancel $cancel_timeout_id + } else { + return "" + } + if {$was_raw == 0} { disableRaw } - #fconfigure stdin -inputmode normal + #restore stdin state + fconfigure stdin -blocking [dict get $stdin_state -blocking] if {[string length $existing_handler]} { fileevent stdin readable $existing_handler } #response handler automatically removes it's own fileevent + set info [set $accumulator] set start [string first \x1b $info] if {$start > 0} { set other [string range $info 0 $start-1] #!!!!! TODO - # Log this somehwere? Work out how to stop it happening? + # Log this somewhere? Work out how to stop it happening? #puts stderr "Warning - get_cursor_pos read extra data at start - '$other'" set info [string range $info $start end] } + #set punk::console::chunk "" set data [string range $info 2 end-1] return $data @@ -520,15 +695,29 @@ namespace eval punk::console { if {!$emit} { puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1 } + set response "" if {[catch { - lassign [split [punk::console::get_cursor_pos] ";"] _row1 col1 + set response [punk::console::get_cursor_pos] } errM]} { - puts stderr "Cannot test_char_width - may be no console? Error message from get_cursor_pos: $errM" + puts stderr "Cannot test_char_width for '[punk::ansi::ansistring VIEW $char_or_string]' - may be no console? Error message from get_cursor_pos: $errM" + return + } + lassign [split $response ";"] _row1 col1 + if {![string length $response] || ![string is integer -strict $col1]} { + puts stderr "test_char_width Could not interpret response from get_cursor_pos for initial cursor pos. Response: '[punk::ansi::ansistring VIEW $response]'" + flush stderr return } puts -nonewline stdout $char_or_string - lassign [split [punk::console::get_cursor_pos] ";"] _row2 col2 + set response [punk::console::get_cursor_pos] + lassign [split $response ";"] _row2 col2 + if {![string is integer -strict $col2]} { + puts stderr "test_char_width could not interpret response from get_cursor_pos for post-emit cursor pos. Response:'[punk::ansi::ansistring VIEW $response]'" + flush stderr + return + } + if {!$emit} { puts -nonewline stdout \033\[2K\033\[1G } @@ -654,19 +843,25 @@ namespace eval punk::console { } move $orig_row $orig_col } - proc save_cursor {} { - puts -nonewline stdout [punk::ansi::save_cursor] - } - proc restore_cursor {} { - puts -nonewline stdout [punk::ansi::restore_cursor] - } proc scroll_up {n} { puts -nonewline stdout [punk::ansi::scroll_up] } proc scroll_down {n} { puts -nonewline stdout [punk::ansi::scroll_down] } - #review - worth the extra microseconds to inline? might be + + #review - worth the extra microseconds to inline? might be if used in for example prompt on every keypress. + #caller should build as much as possible using the punk::ansi versions to avoid extra puts calls + proc save_cursor {} { + #*** !doctools + #[call [fun save_cursor]] + puts -nonewline \x1b\[s + } + proc restore_cursor {} { + #*** !doctools + #[call [fun restore_cursor]] + puts -nonewline \x1b\[u + } proc insert_spaces {count} { puts -nonewline stdout \x1b\[${count}@ } @@ -712,7 +907,8 @@ namespace eval punk::console { #puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text #puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] save_cursor - move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text + #move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text + puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text restore_cursor } proc move_emit_return {row col data args} { diff --git a/src/bootsupport/modules/punk/du-0.1.0.tm b/src/bootsupport/modules/punk/du-0.1.0.tm index 65115ec0..987ade3d 100644 --- a/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/bootsupport/modules/punk/du-0.1.0.tm @@ -18,6 +18,7 @@ ## Requirements ##e.g package require frobz package require punk::mix::base +package require struct::set namespace eval punk::du { @@ -65,7 +66,6 @@ namespace eval punk::du { #breadth-first with sort can be quite fast .. but memory usage can easily get out of control proc du { args } { variable has_twapi - package require struct::set if 0 { diff --git a/src/bootsupport/modules/punk/lib-0.1.0.tm b/src/bootsupport/modules/punk/lib-0.1.0.tm index 605c634e..fea9534f 100644 --- a/src/bootsupport/modules/punk/lib-0.1.0.tm +++ b/src/bootsupport/modules/punk/lib-0.1.0.tm @@ -488,9 +488,11 @@ namespace eval punk::lib { proc askuser {question} { #*** !doctools #[call [fun askuser] [arg question]] - #[para]A very basic utility to read an answer from stdin + #[para]A basic utility to read an answer from stdin #[para]The prompt is written to the terminal and then it waits for a user to type something #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. + #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. + #[para](Generic terminal raw vs linemode detection not yet present) #[para]The user must hit enter to submit the response #[para]The return value is the string if any that was typed prior to hitting enter. #[para]The question argument can be manually colourised using the various punk::ansi funcitons @@ -505,9 +507,22 @@ namespace eval punk::lib { puts stdout $question flush stdout set stdin_state [fconfigure stdin] + if {[catch { + package require punk::console + set console_raw [set ::punk::console::is_raw] + } err_console]} { + #assume normal line mode + set console_raw 0 + } try { fconfigure stdin -blocking 1 - set answer [gets stdin] + if {$console_raw} { + punk::console::disableRaw + set answer [gets stdin] + punk::console::enableRaw + } else { + set answer [gets stdin] + } } finally { fconfigure stdin -blocking [dict get $stdin_state -blocking] } diff --git a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm index 3bbe8b47..8b1f40eb 100644 --- a/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/loadedlib-0.1.0.tm @@ -18,6 +18,7 @@ ## Requirements ##e.g package require frobz package require punk::ns +package require punk::lib @@ -463,11 +464,8 @@ namespace eval punk::mix::commandset::loadedlib { puts stdout "---" puts stdout "$loadinfo" puts stdout "---" - puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" - set stdin_state [fconfigure stdin] - fconfigure stdin -blocking 1 - set answer [string tolower [gets stdin]] - fconfigure stdin -blocking [dict get $stdin_state -blocking] + set question "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" + set answer [punk::lib::askuser $question] ;#takes account of previous stdin state and terminal raw vs line state if {$answer ne "y"} { puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." return @@ -486,11 +484,8 @@ namespace eval punk::mix::commandset::loadedlib { if {[file exists $target_path]} { puts stdout "WARNING - module already exists at $target_path" if {$opt_askme} { - puts stdout "Copy anyway? Y|N" - set stdin_state [fconfigure stdin] - fconfigure stdin -blocking 1 - set answer [string tolower [gets stdin]] - fconfigure stdin -blocking [dict get $stdin_state -blocking] + set question "Copy anyway? Y|N" + set answer [punk::lib::askuser $question] if {$answer ne "y"} { puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." return diff --git a/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/bootsupport/modules/punk/mix/util-0.1.0.tm index 44c01721..aca7eeed 100644 --- a/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -182,6 +182,9 @@ namespace eval punk::mix::util { } proc askuser {question} { + if {![catch {package require punk::lib}]} { + return [punk::lib::askuser $question] ;#takes account of terminal mode raw vs line (if punk::console used) + } puts stdout $question flush stdout set stdin_state [fconfigure stdin] @@ -191,6 +194,7 @@ namespace eval punk::mix::util { return $answer } + #review - can be surprising if caller unaware it uses try proc do_in_path {path script} { #from ::kettle::path::in set here [pwd] diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index b5752b56..81eb7a58 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -139,6 +139,9 @@ namespace eval punk::repo { } proc askuser {question} { + if {![catch {package require punk::lib}]} { + return [punk::lib::askuser $question] ;#takes account of punk::console raw vs line + } puts stdout $question flush stdout set stdin_state [fconfigure stdin] diff --git a/src/modules/patternpunk-1.1.tm b/src/modules/patternpunk-1.1.tm index b07872ff..e30b3f7d 100644 --- a/src/modules/patternpunk-1.1.tm +++ b/src/modules/patternpunk-1.1.tm @@ -100,7 +100,7 @@ set ::punk::bannerTemplate [string trim { |_\ /_| / \ _- -_ -} /n] +} \n] >punk .. Property rhs [string trim { \\\_ \@ > @@ -168,18 +168,18 @@ _+ +_ } \n] >punk .. Property lhs_hips [string trim { - _/// - < @/ - ~ | + _/// + < @/ + ~ | _- -_ \ | | / / \ _+ +_ } \n] >punk .. Property rhs_hips [string trim { - \\\_ - \@ > - | ~ + \\\_ + \@ > + | ~ _- -_ \ | | / / \ @@ -200,13 +200,50 @@ _+ +_ >punk .. Property poop [string trim { _/// < @/ - ^ | -_- -_ + ~ | + _- -_ \ \\ / //. ~ _+_+ @ } \n] +>punk .. Property lhs_bend [string trim { + _/// + < @/ + ~ | + _- -_ + \ \\ / + // + _+_+ +} \n] +>punk .. Property lhs_thrust [string trim { + _/// + < @/ + ~ | + _- -_ + \ // / + \\ + _+_+ +} \n] +>punk .. Property rhs_bend [string trim { + \\\_ + \@ > + | ~ + _- -_ + \ // / + \\ + _+_+ +} \n] +>punk .. Property rhs_thrust [string trim { + \\\_ + \@ > + | ~ + _- -_ + \ \\ / + // + _+_+ +} \n] + >punk .. Property fossil [string trim { .. > < diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 2e62740d..6b109c67 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -78,6 +78,7 @@ namespace eval ::repl { package require punk::lib package require punk::config package require punk::ansi +#package require textblock namespace import punk::ansi::ansistring package require punk::console package require punk::ns @@ -5994,6 +5995,7 @@ namespace eval punk { lappend chunklist [list result $result] set ::punk::last_run_display $chunklist } + #puts stdout "-->[ansistring VIEW $result]" return $result } else { set atail [lassign $args a1] @@ -6122,7 +6124,6 @@ namespace eval punk { if {$::repl::running} { set ::punk::last_run_display $chunklist } - return $result } } @@ -6771,6 +6772,7 @@ namespace eval punk { if {$count > 1} { #val is a list + set llen [llength $val] if {$limit > 0 && ($limit < $llen)} { set displayval [lrange $val 0 $limit-1] if {$llen > $limit} { @@ -6969,18 +6971,9 @@ namespace eval punk { puts -nonewline $chan $text } } - proc mode {raw_or_line} { - set raw_or_line [string tolower $raw_or_line] - if {$raw_or_line eq "raw"} { - punk::console::enableRaw - punk::console::enableVirtualTerminal - } elseif {$raw_or_line eq "line"} { - #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) - punk::console::disableRaw - punk::console::disableVirtualTerminal - } else { - error "punk::mode expected 'raw' or 'line' - } + proc mode {{raw_or_line query}} { + package require punk::console + tailcall ::punk::console::mode $raw_or_line } #this hides cmds mode command - probably no big deal - anyone who needs it will know how to exec it. @@ -7109,11 +7102,12 @@ namespace eval punk { interp alias {} colour {} punk::console::colour + interp alias {} ansi {} punk::console::ansi interp alias {} color {} punk::console::colour - interp alias {} a+ {} punk::console::get_ansi+ - interp alias {} a= {} punk::console::get_ansi - interp alias {} a {} punk::console::get_ansi - interp alias {} a? {} punk::console::get_ansi? + interp alias {} a+ {} punk::console::code_a+ + interp alias {} a= {} punk::console::code_a + interp alias {} a {} punk::console::code_a + interp alias {} a? {} punk::console::code_a? proc dict_getdef {dictValue args} { diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 7ddf415a..73ba43d1 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -48,9 +48,9 @@ #[para] packages used by punk::ansi #[list_begin itemized] -package require Tcl 8.6 +package require Tcl 8.6- #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6-}] # #package require frobz # #*** !doctools @@ -65,6 +65,55 @@ package require Tcl 8.6 #[section API] +namespace eval punk::ansi::class { + if {![llength [info commands class_ansi]]} { + oo::class create class_ansi { + variable o_raw + + variable o_render_dimensions ;#last dimensions at which we rendered + variable o_rendered + variable o_rendered_what + constructor {ansitext {dimensions 80x25}} { + if {![regexp {^([0-9]+)[xX]([0-9]+)$} $dimensions _m w h]} { + error "class_ansi::render dimensions must be of the form x" + } + set o_rendered_what "" + set o_render_dimensions $dimensions + set o_raw $ansitext + } + method rawdata {} { + return $o_raw + } + method render {{dimensions ""}} { + if {$dimensions eq ""} { + set dimensions $o_render_dimensions + } + if {![regexp {^([0-9]+)[xX]([0-9]+)$} $dimensions _m w h]} { + error "class_ansi::render dimensions must be of the form x" + } + if {$o_rendered_what ne $o_raw || $dimensions ne $o_render_dimensions} { + set b [textblock::block $w $h " "] + set o_rendered [overtype::left $b $o_raw] + set o_rendered_what $o_raw + set o_render_dimensions $dimensions + } + + #todo - store rendered and allow partial rendering of new data lines? + return $o_rendered + } + method viewlines {} { + return [ansistring VIEW $o_raw] + } + method viewcodes {} { + return [ansistring VIEWCODES $o_raw] + } + method viewchars {} { + return [punk::ansi::stripansiraw $o_raw] + } + + } + } +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -79,7 +128,6 @@ namespace eval punk::ansi { variable test "blah\033\[1;33mETC\033\[0;mOK" - #Note that a? is actually a pattern. We can't explicitly match it without also matcing a+ ab etc. Presumably this won't matter here. namespace export\ {a?} {a+} a \ @@ -106,8 +154,6 @@ namespace eval punk::ansi { #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) #This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows? - variable standalone_codes - set standalone_codes [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""] #review - there doesn't seem to be an \x1b#7 # https://espterm.github.io/docs/VT100%20escape%20codes.html @@ -124,6 +170,42 @@ namespace eval punk::ansi { "DECPNM norm keypad" "\x1b>"\ ] + + #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? + proc readfile {fname} { + #todo + #1- look for BOM - read according to format given by BOM + #2- assume utf-8 + #3- if errors - assume cp437? + + set data [fcat $fname] + if {[file extension $fname] eq ".ans"} { + set ansidata [encoding convertfrom cp437 $data] + } else { + set ansidata $data + } + set obj [punk::ansi::class::class_ansi new $ansidata] + return $obj + } + proc is_utf8_char {char} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + } $char + } + proc get_utf8 {text} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + \A ( + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + + } $text completeChars + return $completeChars + } #control strings #https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf # @@ -167,39 +249,65 @@ namespace eval punk::ansi { proc controlstring_APC8 {text} { return "\x9f${text}\x9c" } + #there is also the SGR hide code (8) which has intermittent terminal support + #This doesn't change the output length - so support is tricky to detec. (terminal checksum report?) #candidate for zig/c implementation? proc stripansi {text} { + #*** !doctools + #[call [fun stripansi] [arg text] ] + #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) + + #using detect costs us a couple of uS - but saves time on plain text + #we should probably leave this for caller - otherwise it ends up being called more than necessary + #if {![::punk::ansi::ta::detect $text]} { + # return $text + #} + + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + join [::punk::ansi::ta::split_at_codes $text] "" + } + proc stripansiraw {text} { #*** !doctools #[call [fun stripansi] [arg text] ] #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics modes will be stripped - exposing the raw characters as they appear without graphics mode. + #[para]ie instead of a horizontal line you may see: qqqqqq + + + join [::punk::ansi::ta::split_at_codes $text] "" + } + proc stripansi1 {text} { #todo - character set selection - SS2 SS3 - how are they terminated? REVIEW variable escape_terminals ;#dict - variable standalone_codes ;#map to empty string + variable ::punk::ansi::ta::standalone_code_map ;#map to empty string set text [convert_g0 $text] - #we should just map away the 2-byte sequences too - #standalone 3 byte VT100 sequences - some of these work in wezterm + set text [string map $standalone_code_map $text] + #e.g standalone 2 byte and 3 byte VT100(?) sequences - some of these work in wezterm #\x1b#3 double-height letters top half #\x1b#4 double-height letters bottom half #\x1b#5 single-width line #\x1b#6 double-width line #\x1b#8 dec test fill screen - set text [string map $standalone_codes $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 payload (review e.g title?) + + #Theoretically line endings can occur within an ST payload (review e.g title?) + #ecma standard says: The character string following may consist of any bit combination, except those representing SOS or STRING TERMINATOR (ST) set inputlist [split $text ""] set outputlist [list] set in_escapesequence 0 - #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls + #assumption - text already 'rendered' - ie no cursor movement controls . (what about backspace and lone carriage returns - they are horizontal cursor movements) + set i 0 foreach u $inputlist { set v [lindex $inputlist $i+1] @@ -236,39 +344,92 @@ namespace eval punk::ansi { #review - what happens when no terminator? #todo - map other chars to unicode equivs + # convert esc(0 -> esc(B graphics sequences to single char unicode equivalents e.g box drawing set + # esc) ?? proc convert_g0 {text} { #using not \033 inside to stop greediness - review how does it compare to ".*?" + #variable re_altg0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} + #set re {\033\(0[^\033]*\033\(B} + #set re {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} + + + set re2 {\033\(0(.*)\033\(B} ;#capturing + + #puts --$g-- + #box sample + #lqk + #x x + #mqj + #m = boxd_lur + #set map [list l \u250f k \u2513] ;#heavy + set map [list l \u250c q \u2500 k \u2510 x \u2502 m \u2514 j \u2518] ;#light box drawing lines + #todo - map the rest https://vt100.net/docs/vt220-rm/chapter2.html + + set re_g0_open_or_close {\x1b\(0|\x1b\(B} + set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text] + set out "" + set g0_on 0 + foreach {pt g} $parts { + if {$g0_on} { + #split for non graphics-set codes + set othersplits [punk::ansi::ta::split_codes $pt] ;#we don't need single codes here + foreach {innerpt innercodes} $othersplits { + append out [string map $map $innerpt] + append out $innercodes ;#Simplifying assumption - ST codes, titlesets etc don't require/use g0 content + } + } else { + append out $pt ;#may include other codes - put it all through. + } + if {$g ne ""} { + if {[punk::ansi::codetype::is_gx_open $g]} { + set g0_on 1 + } elseif {[punk::ansi::codetype::is_gx_close $g]} { + set g0_on 0 + } + } + } + return $out + } + proc convert_g0_wrong {text} { + #Attempting to split on a group is wrong - because there could be other ansi codes while inside a g0 section + #That will either stop us matching - so no conversion - or risk converting parts of the ansi codes + #using not \033 inside to stop greediness - review how does it compare to ".*?" + #variable re_altg0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} set re {\033\(0[^\033]*\033\(B} set re2 {\033\(0(.*)\033\(B} ;#capturing + + #box sample + #lqk + #x x + #mqj + #m = boxd_lur + #set map [list l \u250f k \u2513] ;#heavy + set map [list l \u250c q \u2500 k \u2510 x \u2502 m \u2514 j \u2518] ;#light box drawing lines + #todo - map the rest https://vt100.net/docs/vt220-rm/chapter2.html + set parts [::punk::ansi::ta::_perlish_split $re $text] set out "" foreach {pt g} $parts { append out $pt if {$g ne ""} { #puts --$g-- - #box sample - #lqk - #x x - #mqj - #m = boxd_lur - #set map [list l \u250f k \u2513] ;#heavy - set map [list l \u250c q \u2500 k \u2510 x \u2502 m \u2514 j \u2518] ;#light - regexp $re2 $g _match contents append out [string map $map $contents] } } return $out } - - #todo - convert esc(0 graphics sequences to single char unicode equivalents e.g box drawing set - # esc) ?? + proc g0 {text} { + return \x1b(0$text\x1b(B + } proc stripansi_gx {text} { #e.g "\033(0" - select VT100 graphics for character set G0 #e.g "\033(B" - reset #e.g "\033)0" - select VT100 graphics for character set G1 #e.g "\033)X" - where X is any char other than 0 to reset ?? - return [convert_g0 $text] + + #return [convert_g0 $text] + return [string map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text] } @@ -608,16 +769,30 @@ namespace eval punk::ansi { } # -- --- --- --- --- - proc save_cursor {} { + proc cursor_save {} { #*** !doctools - #[call [fun save_cursor]] + #[call [fun cursor_save]] + #[para] equivalent term::ansi::code::ctrl::sc return \x1b\[s } - proc restore_cursor {} { + proc cursor_restore {} { #*** !doctools - #[call [fun restore_cursor]] + #[call [fun cursor_restore]] + #[para] equivalent term::ansi::code::ctrl::rc return \x1b\[u } + proc cursor_save_attributes {} { + #*** !doctools + #[call [fun cursor_save_attributes]] + #[para] equivalent term::ansi::code::ctrl::sca + return \x1b7 + } + proc cursor_restore_attributes {} { + #*** !doctools + #[call [fun cursor_restore_attributes]] + #[para] equivalent term::ansi::code::ctrl::rca + return \x1b8 + } # -- --- --- --- --- proc erase_line {} { @@ -686,6 +861,31 @@ namespace eval punk::ansi { #[para]The punk::ansi::cursor_pos function is used by punk::console::get_cursor_pos and punk::console::get_cursor_pos_list return \033\[6n } + + proc cursor_pos_extended {} { + #includes page e.g ^[[47;3;1R + return \033\[?6n + } + + + #DECFRA - Fill rectangular area + #REVIEW - vt100 accepts decimal values 132-126 and 160-255 ("in the current GL or GR in-use table") + #some modern terminals accept and display characters outside this range - but this needs investigation. + #in a modern unicode era - the restricted range doesn't make a lot of sense - but we need to see what terminal emulators actually do. + #e.g what happens with double-width? + #this wrapper accepts a char rather than a decimal value + proc fill_rect {char t l b r} { + set dec [scan $char %c] + return \x1b\[$dec\;$t\;$l\;$b\;$r\$x + } + #DECFRA with decimal char value + proc fill_rect_dec {decimal t l b r} { + return \x1b\[$decimal\;$t\;$l\;$b\;$r\$x + } + + proc checksum_rect {id page t l b r} { + return "\x1b\[${id}\;${page}\;$t\;$l\;$b\;$r*y" + } proc request_cursor_information {} { #*** !doctools @@ -734,8 +934,13 @@ namespace eval punk::ansi { } #what if line has \v (vertical tab) ie more than one logical screen line? - #review - + #review - detect ansi moves and warn/error? They would invalidate this algorithm + #for a string with ansi moves - we would need to use the overtype::renderline function (which is a bit heavier) + #arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review + #the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char + #This should presumably only be done if the over_strike (os) capability is enabled in the terminal. Either way - it presumably won't affect printing width? set line [punk::ansi::stripansi $line] + #we can't use simple \b processing if we get ansi codes and aren't actually processing them (e.g moves) set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi #backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter @@ -752,31 +957,48 @@ namespace eval punk::ansi { #*todo - handle terminal/context where tabwidth != the default 8 spaces set line [textutil::tabify::untabify2 $line] + #NOTE - this is non-destructive backspace as it occurs in text blocks - and is likely different to the sequence coming from a terminal or editor which generally does a destructive backspace + #e.g + #This means for example that abc\b has a length of 3. Trailing or leading backslashes have no effect + set bs [format %c 0x08] - #set line [string map [list "\r${bs}" "\r"] $line] ;#backsp following a \r will have no effect - set line [string trim $line $bs] + #set line [string map [list "\r\b" "\r"] $line] ;#backsp following a \r will have no effect + set line [string trim $line \b] ;#take off at start and tail only + #counterintuitively "x\b" still shows the x ie length is still one. The backspace just moves the position. There must be a char following \b for it to affect the length. + #(we are not interested in the destructive backspace case present in editors,terminals etc - that is a different context) set n 0 - set chars [split $line ""] + #set chars [split $line ""] ; #review - graphemes vs chars? Terminals differ in how they treat this. + set chars [punk::char::grapheme_split $line] + #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner #build an output set idx 0 set outchars [list] set outsizes [list] foreach c $chars { - if {$c eq $bs} { + if {$c eq "\b"} { if {$idx > 0} { incr idx -1 } } elseif {$c eq "\r"} { set idx 0 } else { - punk::ansi::internal::printing_length_addchar $idx $c + set nxt [llength $outchars] + if {$idx < $nxt} { + #overstrike? - should usually have no impact on width - width taken as last grapheme in that column + #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. + lset outchars $idx $c + } else { + lappend outchars $c + } + #punk::ansi::internal::printing_length_addchar $idx $c incr idx } } set line2 [join $outchars ""] - return [punk::char::string_width $line2] + return [punk::char::ansifreestring_width $line2] } @@ -819,39 +1041,84 @@ namespace eval punk::ansi { return "\u0090+q$payload\u009c" } namespace eval codetype { - #Functions that operate on a single ansi code sequence - not a sequence, and not 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 + #review - separate namespace for functions that operate on multiple or embedded? 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)$} + + #review - has_cursor_move_in_line? Are we wanting to allow strings/sequences and detect that there are no moves that *aren't* within line? + proc is_cursor_move_in_line {code {knownline ""}} { + if {[regexp {\033\[[0-9]*(:?C|D|G)$} $code]} { + return 1 + } + if {[string is integer -strict $knownline]} { + #CSI n : m H where row n happens to be current line - review/test + set re [string map [list %n% $knownline] {\x1b\[%n%:[0-9]*H$}] + if {[regexp $re $code]} { + return 1 + } + } + return 0 } #pure SGR reset with no other functions proc is_sgr_reset {code} { + #*** !doctools + #[call [fun is_sgr_reset] [arg code]] + #[para]Return a boolean indicating whether this string has a trailing pure SGR reset + #[para]Note that if the reset is not the very last item in the string - it will not be detected. + #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. + #todo 8-bit csi - regexp {\033\[0*m$} $code + regexp {\x1b\[0*m$} $code } + + #whether this code has 0 (or equivalently empty) parameter (but may set others) #if an SGR code has 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 + #it generally only makes sense for the reset to be the first parameter - 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. + #We only look at the initial parameter within the trailing SGR code 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} { + #*** !doctools + #[call [fun has_sgr_leadingreset] [arg code]] + #[para]The reset must be the very first item in code to be detected. Trailing strings/codes ignored. 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 + #we need non-greedy + if {[regexp {^\033\[([^m]*)m} $code _match params]} { + #must match trailing m to be the type of reset we're looking for + 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 + } } else { return 0 } } + proc is_gx {code} { + #g0 {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} + #g1 {(?:\x1b\)0)(?:(?!\x1b\)B).)*\x1b\)B} + regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + } + proc is_gx_open {code} { + #todo g2,g3? + #pin to start and end with ^ and $ ? + #regexp {\x1b\(0|\x1b\)0} $code + regexp {\x1b(?:\(0|\)0)} $code + } + proc is_gx_close {code} { + #regexp {\x1b\(B|\x1b\)B} $code + regexp {\x1b(?:\(B|\)B)} $code + } #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? @@ -895,45 +1162,70 @@ namespace eval punk::ansi::ta { #CSI #variable re_csi_open {(?:\033\[|\u009b)[0-9;]+} ;#too specific - doesn't detect \033\[m - variable re_csi_open {(?:\033\[|\u009b)} + variable re_csi_open {(?:\x1b\[|\u009b)} + #variable re_csi_code {(?:\033\[|\u009b)[0-9;]*[a-zA-Z\\@\^_\{|\}\[\]~`]} + variable re_csi_code {(?:\x1b\[|\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]} - #colour and style - variable re_csi_colour {(?:\033\[|\u009b)[0-9;]*m} ;#e.g \033\[31m \033\[m \033\[0m \033\[m0000m + #intermediate bytes range 0x20-0x2F (ascii space and !"#$%&'()*+,-./) + #parameter bytes range 0x30-0x3F (ascii 0-9:;<=>?) #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\\) - # 8-byte string terminator is \x9c (\u009c) + #colour and style + variable re_sgr {(?:\033\[|\u009b)[0-9;]*m} ;#e.g \033\[31m \033\[m \033\[0m \033\[m0000m - #non-greedy via "*?" doesn't seem to work like this.. - #variable re_esc_osc1 {(?:\033\]).*?\007} - #variable re_esc_osc2 {(?:\033\]).*?\033\\} - #variable re_esc_osc3 {(?:\u009d).*?\u009c} + #OSC - termnate with BEL (\a \007) or ST (string terminator \x1b\\) + # 8-byte string terminator is \x9c (\u009c) #non-greedy by excluding ST terminators - #TODO - FIX? see re_ST below - variable re_esc_osc1 {(?:\033\])(?:[^\007]*)\007} - variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\} + variable re_esc_osc1 {(?:\x1b\])(?:[^\007]*)\007} + #variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\} ;#somewhat wrong - we want to exclude the ST - not other esc sequences + variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} variable re_esc_osc3 {(?:\u009d)(?:[^\u009c]*)?\u009c} + variable re_osc_open {(?:\x1b\]|\u009d).*} - variable re_osc_open {(?:\033\]|\u009d).*} - #standalone_codes [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""] + variable standalone_code_map [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""] variable re_standalones {(?:\x1bc|\x1b7|\x1b8|\x1bM|\x1bE|\x1bD|\x1bD|\x1bH|\x1b=|\x1b>|\x1b#3|\x1b#4|\x1b#5|\x1b#6|\x1b#8)} - #see stripansi - set re_start_ST {^(?:\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #if we don't split on altgraphics too and separate them out - it's easy to get into a horrible mess + variable re_altg0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} + variable re_altg0_open {(?:\x1b\(0)} + variable re_altg0_close {(?:\x1b\(B)} + + # DCS "ESC P" or "0x90" is also terminated by ST + set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} #ST terminators [list \007 \033\\ \u009c] #regex to capture the start of string/privacy message/application command block including the contents and string terminator (ST) #non-greedy by exclusion of ST terminators in body - #!!! - #TODO - fix. we need to match \033\\ not just \033 ! could be colour codes nested in a privacy msg/string - #This will currently terminate the code too early in this case + #we need to match \x1b\\ not just \x1b There could be colour codes nested in a privacy msg/string + #even if terminals generally don't support that - it's quite possible for an ansi code to get nested this way - and we'd prefer it not to break our splits + #Just checking for \x1b will terminate the match too early #we also need to track the start of ST terminated code and not add it for replay (in the ansistring functions) - variable re_ST {(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)(?:[^\033\007\u009c]*)(?:\033\\|\007|\u009c)} + #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) + #keep our 8bit/7bit start-end codes separate + variable re_ST {(?:\x1bP|\x1bX|\x1b\^|\x1b_)(?:(?!\x1b\\|007).)*(?:\x1b\\|\007)|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)} + + + + #consider standalones as self-opening/self-closing - therefore included in both ansi_detect and ansi_detect_open + + #default for regexes is non-newline-sensitive matching - ie matches can span lines + # -- --- --- --- + variable re_ansi_detect1 "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_altg0_open}|${re_altg0_close}" + # -- --- --- --- + #handrafted TRIE version of above. Somewhat difficult to construct and maintain. TODO - find a regext TRIE generator that works with Tcl regexes + #This does make things quicker - but it's too early to finalise the detect/split regexes (e.g missing \U0090 ) - will need to be redone. + variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} + # -- --- --- --- - variable re_ansi_detect "${re_csi_open}|${re_esc_osc1}|${re_esc_osc2}|${re_standalones}|${re_start_ST}" + + + variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_ST_open}|${re_altg0_open}" + + #may be same as detect - kept in case detect needs to diverge + #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_altg0_open}|${re_altg0_close}" + set re_ansi_split $re_ansi_detect #detect any ansi escapes #review - only detect 'complete' codes - or just use the opening escapes for performance? @@ -944,13 +1236,19 @@ namespace eval punk::ansi::ta { #[para] 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]} } + proc detect2 {text} { + variable re_ansi_detect2 + expr {[regexp $re_ansi_detect2 $text]} + } + + + proc detect_open {text} { + variable re_ansi_detect_open + expr {[regexp $re_ansi_detect_open $text]} + } + #not in perl ta proc detect_csi {text} { #*** !doctools @@ -972,8 +1270,8 @@ namespace eval punk::ansi::ta { #[para]This is most commonly an Ansi colour code - but also things such as underline and italics #[para]An SGR with empty or a single zero argument is a reset of the SGR features - this is also detected. #[para](This function is not in perl ta) - variable re_csi_colour - expr {[regexp $re_csi_colour $text]} + variable re_sgr + expr {[regexp $re_sgr $text]} } proc strip {text} { #*** !doctools @@ -1001,12 +1299,8 @@ namespace eval punk::ansi::ta { #not in perl ta #returns just the plaintext portions in a list proc split_at_codes {text} { - variable re_esc_osc1 - variable re_esc_osc2 - variable re_csi_code - variable re_standalones - variable re_ST - punk::ansi::internal::splitx $text "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_standalones}|${re_ST}" + variable re_ansi_split + punk::ansi::internal::splitx $text ${re_ansi_split} } # -- --- --- --- --- --- @@ -1023,23 +1317,14 @@ namespace eval punk::ansi::ta { #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 - variable re_standalones - variable re_ST - set re "(?:${re_csi_code}|${re_standalones}|${re_ST}|${re_esc_osc1}|${re_esc_osc2})+" + variable re_ansi_split + set re "(?:${re_ansi_split})+" 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 - variable re_standalones - variable re_ST - set re "${re_csi_code}|${re_standalones}|${re_ST}|${re_esc_osc1}|${re_esc_osc2}" - return [_perlish_split $re $text] + variable re_ansi_split + return [_perlish_split $re_ansi_split $text] } #review - tcl greedy expressions may match multiple in one element @@ -1093,7 +1378,7 @@ namespace eval punk::ansi::ansistring { namespace path [list ::punk::ansi ::punk::ansi::ta] namespace ensemble create - namespace export length trim trimleft trimright index VIEW + namespace export length trim trimleft trimright index VIEW VIEWCODES #todo - expose _splits_ methods so caller can work efficiently with the splits themselves #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single @@ -1366,6 +1651,35 @@ namespace eval punk::ansi::ansistring { #test of ISO2047 - 7bit - limited set, limited support, somewhat obscure glyphs #return [string map [list \033 \U2296 \007 \U237E] $string] } + proc VIEWCODES {string} { + if {![llength $string]} { + return "" + } + set redb [a+ red bold] + set greenb [a+ green bold] + set GX [a+ black White bold] + set unk [a+ yellow bold] + set RST [a] + + #don't split into lines first - \n is valid within ST sections + set output "" + set splits [punk::ansi::ta::split_codes_single $string] + foreach {pt code} $splits { + append output "$pt" + if {[punk::ansi::codetype::is_sgr_reset $code]} { + append output ${greenb}RST$RST + } elseif {[punk::ansi::codetype::is_gx_open $code]} { + append output ${GX}GX+$RST + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + append output ${GX}GX-$RST + } elseif {[punk::ansi::codetype::is_sgr $code]} { + append output ${greenb}[ansistring VIEW $code]$RST + } else { + append output ${unk}[ansistring VIEW $code]$RST + } + } + return $output + } proc length {string} { #*** !doctools @@ -1373,8 +1687,14 @@ namespace eval punk::ansi::ansistring { #[para]Returns the length of the string without ansi codes #[para]This will not count strings hidden inside a 'privacy message' or other ansi codes which may have content between their opening escape and their termination sequence. #[para]This is equivalent to calling string length on the result of stripansi $string - #[para]Note that this returns the number of characters in the payload, and is not always the same as the width of the string as rendered on a terminal. + #[para]Note that this returns the number of characters in the payload (after applying combiners), and is not always the same as the width of the string as rendered on a terminal. #[para]To get the width, use punk::ansi::printing_length instead, which is also ansi aware. + + #todo - combiners/diacritics? just map them away here? + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set string [regsub -all $re_diacritics $string ""] + + #we want length to return number of glyphs.. not screen width. Has to be consistent with index function string length [stripansi $string] } @@ -1429,7 +1749,7 @@ namespace eval punk::ansi::ansistring { #[para]Some sort of generator that parses more of the string as required might be more efficient for large chunks. #[para]For end-x operations we have to pre-calculate the content-length by stripping the ansi - which is also potentially sub-optimal - set splits [split_codes_single $string]; #we get empty pt(plaintext) between each ansi code that is in a run + set ansisplits [split_codes_single $string]; #we get empty pt(plaintext) between each ansi code that is in a run #todo - end-x +/-x+/-x etc set original_index $index @@ -1502,16 +1822,21 @@ namespace eval punk::ansi::ansistring { set codes_in_effect "" #we can't only apply leading sequence from previous code - as there may be codes in effect from earlier, so we have to track as we go #(this would apply even if we used split_codes - but then we would need to do further splitting of each codeset anyway) - foreach {pt code} $splits { + foreach {pt code} $ansisplits { incr pt_index 2 + #we want an index per grapheme - whether it is doublewide or single + if {$pt ne ""} { + set graphemes [punk::char::grapheme_split $pt] set low [expr {$high + 1}] ;#last high - incr high [string length $pt] + #incr high [string length $pt] + incr high [llength $graphemes] } if {$pt ne "" && ($index >= $low && $index <= $high)} { set pt_found $pt_index - set char [string index $pt $index-$low] + #set char [string index $pt $index-$low] + set char [lindex $graphemes $index-$low] break } diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 946aa3d4..a9cd5b4e 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -81,9 +81,9 @@ #[para] packages used by punk::args #[list_begin itemized] -package require Tcl 8.6 +package require Tcl 8.6- #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6-}] # #package require frobz # #*** !doctools diff --git a/src/modules/punk/char-999999.0a1.0.tm b/src/modules/punk/char-999999.0a1.0.tm index 7cdd7a2d..d9602010 100644 --- a/src/modules/punk/char-999999.0a1.0.tm +++ b/src/modules/punk/char-999999.0a1.0.tm @@ -55,7 +55,7 @@ #[item] [package console] #[para] - -package require Tcl 8.6 +package require Tcl 8.6- #*** !doctools #[list_end] @@ -525,7 +525,7 @@ namespace eval punk::char { # e.g encoding convertto dingbats will output something that doesn't look dingbatty on screen. #-- --- --- --- --- --- --- --- #must use Tcl instead of tcl (at least for 8.6) - if {![package vsatisfies [package present Tcl] 8.7]} { + if {![package vsatisfies [package present Tcl] 8.7-]} { proc encodable "s {enc [encoding system]}" { set encname [encname $enc] if {($encname eq "ascii")} { @@ -1651,7 +1651,7 @@ namespace eval punk::char { set twidth [dict get $charinfo $dec testwidth] } if {$twidth eq ""} { - set width [string_width $ch] ;#based on unicode props + set width [ansifreestring_width $ch] ;#based on unicode props } else { set width $twidth } @@ -1792,14 +1792,23 @@ namespace eval punk::char { puts stdout "\ncalibration done - results cached in charinfo dictionary" return [dict create charcount $charcount widths $width_results] } - #prerequisites - no ansi escapes - no newlines - #review - what about \r \t \b ? + #todo - provide a char_width equivalent that is optimised for speed proc string_width {text} { - #review is detecting \033 enough? what about 8-bit escapes? - + #burn approx 2uS (2024) checking for ansi codes - not just SGR + if {[punk::ansi::ta::detect $text]} { + puts stderr "string_width detected ANSI!" + } if {[string first \n $text] >= 0} { error "string_width accepts only a single line" } + tailcall ansifreestring_width $text + } + #prerequisites - no ansi escapes - no newlines + #review - what about \r \t \b ? + #NO processing of \b - already handled in ansi::printing_length which then calls this + proc ansifreestring_width {text} { + #caller responsible for calling ansistrip first if text may have ansi codes - and for ensuring no newlines + #we can c0 control characters after or while processing ansi escapes. @@ -1808,15 +1817,6 @@ namespace eval punk::char { #if {[string first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first" #} - set re_ascii_c0 {[\U0000-\U001F]} - set text [regsub -all $re_ascii_c0 $text ""] - - #todo - check double-width chars in unicode blocks.. try to do reasonably quicky - #short-circuit basic cases - if {![regexp {[\uFF-\U10FFFF]} $text]} { - #control chars? - return [string length $text] - } #todo - various combining diacritical marks.. from grave - to various complicated unicode joiners and composing chars etc @@ -1831,9 +1831,32 @@ namespace eval punk::char { # # initial simplistic approach is just to strip these ... todo REVIEW + #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width + #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #if {[regexp $re_leading_diacritic $text]} { + # set text " $text" + #} set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] + + + #only map control sequences to nothing after processing ones with special effects, such as \b (\x07f) + #Note DEL \x1f will only + set re_ascii_c0 {[\U0000-\U001F]} + set text [regsub -all $re_ascii_c0 $text ""] + + #short-circuit basic cases + #support tcl pre 2023-11 - see regexp bug below + #if {![regexp {[\uFF-\U10FFFF]} $text]} { + # return [string length $text] + #} + if {![regexp "\[\uFF-\U10FFFF\]" $text]} { + return [string length $text] + } + + #todo - check double-width chars in unicode blocks.. try to do reasonably quicky set re_ascii_fullwidth {[\uFF01-\uFF5e]} set doublewidth_char_count 0 @@ -1886,6 +1909,55 @@ namespace eval punk::char { error "char_uc_width unimplemented" } + + #split into plaintext and runs of combiners + proc combiner_split {text} { + #split into odd numbered list (or zero) in a similar way to punk::ansi::ta::_perlish_split + # + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set graphemes [list] + set g "" + if {[string length $text] == 0} { + return {} + } + set list [list] + set start 0 + set strlen [string length $text] + #make sure our regexes aren't non-greedy - or we may not have exit condition for loop + #review + while {$start < $strlen && [regexp -start $start -indices -- $re_diacritics $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd] + set start [expr {$matchEnd+1}] + + #if {$start >= [string length $text]} { + # break + #} + } + lappend list [string range $text $start end] + + return $list + } + + #1st shot - basic diacritics + #todo - become aware of unicode grapheme cluster boundaries + # + proc grapheme_split {text} { + set graphemes [list] + set csplits [combiner_split $text] + foreach {pt combiners} [lrange $csplits 0 end-1] { + set clist [split $pt ""] + lappend graphemes {*}[lrange $clist 0 end-1] + lappend graphemes [string cat [lindex $clist end] $combiners] + } + #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme + if {[lindex $csplits end] ne ""} { + lappend graphemes {*}[split [lindex $csplits end] ""] + } + return $graphemes + } + # -- --- --- --- --- #will accept a single char or a string - test using console cursor position reporting proc char_info_testwidth {ch {emit 0}} { diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index e6c69d68..d8123221 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -34,8 +34,20 @@ namespace eval punk::console { variable previous_stty_state_stdin "" variable previous_stty_state_stdout "" variable previous_stty_state_stderr "" - variable is_raw 0 + variable input_chunks_waiting + if {![info exists input_chunks_waiting(stdin)]} { + set input_chunks_waiting(stdin) [list] + } + + # -- + variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run. + #-1 still evaluates to true - as the modern assumption for ansi availability is true + #only false if ansi_available has been set 0 by test_can_ansi + #support stripansi for legacy windows terminals + # -- + + variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset #punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace #directly acting means they write to stdout to cause the console to peform the action, or they perform the action immediately via other means. @@ -55,41 +67,61 @@ namespace eval punk::console { } if {"windows" eq $::tcl_platform(platform)} { - proc enableAnsi {} { + #accept args for all dummy/load functions so we don't have to match/update argument signatures here + + proc enableAnsi {args} { #loopavoidancetoken (don't remove) internal::define_windows_procs internal::abort_if_loop - tailcall enableAnsi + tailcall enableAnsi {*}$args } #review what raw mode means with regard to a specific channel vs terminal as a whole - proc enableRaw {{channel stdin}} { + proc enableRaw {args} { #loopavoidancetoken (don't remove) internal::define_windows_procs internal::abort_if_loop - tailcall enableRaw $channel + tailcall enableRaw {*}$args } - proc disableRaw {{channel stdin}} { + proc disableRaw {args} { #loopavoidancetoken (don't remove) internal::define_windows_procs internal::abort_if_loop - tailcall disableRaw $channel + tailcall disableRaw {*}$args } - proc enableVirtualTerminal {} { + proc enableVirtualTerminal {args} { #loopavoidancetoken (don't remove) internal::define_windows_procs internal::abort_if_loop - tailcall enableVirtualTerminal + tailcall enableVirtualTerminal {*}$args } - proc disableVirtualTerminal {} { + proc disableVirtualTerminal {args} { #loopavoidancetoken (don't remove) internal::define_windows_procs internal::abort_if_loop - tailcall disableVirtualTerminal + tailcall disableVirtualTerminal {*}$args + } + set funcs [list disableAnsi enableProcessedInput disableProcessedInput] + foreach f $funcs { + proc $f {args} [string map [list %f% $f] { + set mybody [info body %f%] + internal::define_windows_procs + set newbody [info body %f%] + if {$newbody ne $mybody} { + tailcall %f% {*}$args + } else { + #error vs noop? + puts stderr "Unable to set implementation for %f% - check twapi?" + } + }] } + } else { proc enableAnsi {} { #todo? } + proc disableAnsi {} { + + } #todo - something better - the 'channel' concept may not really apply on unix, as raw mode is for input and output modes proc enableRaw {{channel stdin}} { @@ -111,14 +143,22 @@ namespace eval punk::console { if {[set previous_stty_state_$channel] ne ""} { exec {*}$sttycmd [set previous_stty_state_$channel] set previous_stty_state_$channel "" + set is_raw 0 return restored } exec {*}$sttycmd -raw echo <@$channel set is_raw 0 return done } + proc enableVirtualTerminal {{channels {input output}}} { + + } + proc disableVirtualTerminal {args} { + + } } + #review - document and decide granularity required. should we enable/disable more than one at once? proc enable_mouse {} { puts -nonewline stdout \x1b\[?1000h puts -nonewline stdout \x1b\[?1003h @@ -148,6 +188,32 @@ namespace eval punk::console { enable_bracketed_paste } + proc mode {{raw_or_line query}} { + variable is_raw + variable ansi_available + set raw_or_line [string tolower $raw_or_line] + if {$raw_or_line eq "query"} { + if {$is_raw} { + return "raw" + } else { + return "line" + } + } elseif {$raw_or_line eq "raw"} { + punk::console::enableRaw + if {[can_ansi]} { + punk::console::enableVirtualTerminal both + } + } elseif {$raw_or_line eq "line"} { + #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) + punk::console::disableRaw + if {[can_ansi]} { + punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc + punk::console::enableVirtualTerminal output ;#display/use ansi codes + } + } else { + error "punk::console::mode expected 'raw' or 'line' or default value 'query'" + } + } namespace eval internal { proc abort_if_loop {{failmsg ""}} { @@ -168,6 +234,10 @@ namespace eval punk::console { proc define_windows_procs {} { package require zzzload set loadstate [zzzload::pkg_require twapi] + + #loadstate could also be stuck on loading? - review - zzzload not very ripe + #Twapi is relatively slow to load - can be 1s plus in normal cases - and much longer if there are disk performance issues. + if {$loadstate ni [list failed]} { #review zzzload usage #puts stdout "=========== console loading twapi =============" @@ -179,6 +249,7 @@ namespace eval punk::console { #enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't. #Find a compromise to organise things somewhat sensibly.. + #this is really enableAnsi *processing* proc [namespace parent]::enableAnsi {} { #output handle modes #Enable virtual terminal processing (sometimes off in older windows terminals) @@ -188,12 +259,13 @@ namespace eval punk::console { #DISABLE_NEWLINE_AUTO_RETURN = 0x0008 set h_out [twapi::get_console_handle stdout] set oldmode_out [twapi::GetConsoleMode $h_out] - set newmode_out [expr {$oldmode_out | 5}] ;#5? + set newmode_out [expr {$oldmode_out | 4}] ;#don't enable processed output too, even though it's required. keep symmetrical with disableAnsi? twapi::SetConsoleMode $h_out $newmode_out + #what does window_input have to do with it?? #input handle modes - #ENABLE_PROCESSED_INPUT 0x0001 + #ENABLE_PROCESSED_INPUT 0x0001 ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal #ENABLE_LINE_INPUT 0x0002 #ENABLE_ECHO_INPUT 0x0004 #ENABLE_WINDOW_INPUT 0x0008 (default off when a terminal created) @@ -213,10 +285,10 @@ namespace eval punk::console { proc [namespace parent]::disableAnsi {} { set h_out [twapi::get_console_handle stdout] set oldmode_out [twapi::GetConsoleMode $h_out] - set newmode_out [expr {$oldmode_out & ~5}] + set newmode_out [expr {$oldmode_out & ~4}] twapi::SetConsoleMode $h_out $newmode_out - + #??? review set h_in [twapi::get_console_handle stdin] set oldmode_in [twapi::GetConsoleMode $h_in] set newmode_in [expr {$oldmode_in & ~8}] @@ -226,30 +298,88 @@ namespace eval punk::console { return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] } - proc [namespace parent]::enableVirtualTerminal {} { - set h_out [twapi::get_console_handle stdout] - set oldmode_out [twapi::GetConsoleMode $h_out] - set newmode_out [expr {$oldmode_out | 4}] - twapi::SetConsoleMode $h_out $newmode_out + # + proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #note setting stdout makes stderr have the same settings - ie there is really only one output to configure + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode | 4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in | 0x200}] - twapi::SetConsoleMode $h_in $newmode_in - return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] - } - proc [namespace parent]::disableVirtualTerminal {} { - set h_out [twapi::get_console_handle stdout] - set oldmode_out [twapi::GetConsoleMode $h_out] - set newmode_out [expr {$oldmode_out & ~4}] - twapi::SetConsoleMode $h_out $newmode_out + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in | 0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } - set h_in [twapi::get_console_handle stdin] - set oldmode_in [twapi::GetConsoleMode $h_in] - set newmode_in [expr {$oldmode_in & ~0x200}] - twapi::SetConsoleMode $h_in $newmode_in - return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + return $result + } + proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { + set ins [list in input stdin] + set outs [list out output stdout stderr] + set known [concat $ins $outs both] + set directions [list] + foreach v $channels { + if {$v in $ins} { + lappend directions input + } elseif {$v in $outs} { + lappend directions output + } elseif {$v eq "both"} { + lappend directions input output + } + if {$v ni $known} { + error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)" + } + } + set channels $directions ;#don't worry about dups. + if {"both" in $channels} { + lappend channels input output + } + set result [dict create] + if {"output" in $channels} { + #as above - configuring stdout does stderr too + set h_out [twapi::get_console_handle stdout] + set oldmode [twapi::GetConsoleMode $h_out] + set newmode [expr {$oldmode & ~4}] + twapi::SetConsoleMode $h_out $newmode + dict set result output [list from $oldmode to $newmode] + } + if {"input" in $channels} { + set h_in [twapi::get_console_handle stdin] + set oldmode_in [twapi::GetConsoleMode $h_in] + set newmode_in [expr {$oldmode_in & ~0x200}] + twapi::SetConsoleMode $h_in $newmode_in + dict set result input [list from $oldmode_in to $newmode_in] + } + #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] + return $result } proc [namespace parent]::enableProcessedInput {} { @@ -268,113 +398,290 @@ namespace eval punk::console { } - proc [namespace parent]::enableRaw {{channel stdin}} { - variable is_raw - #review - change to modify_console_input_mode - #set console_handle [twapi::GetStdHandle -10] - set console_handle [twapi::get_console_handle stdin] - - #returns dictionary - #e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0 - set oldmode [twapi::get_console_input_mode] - twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0 - # Turn off the echo and line-editing bits - - #set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]] - set newmode [twapi::get_console_input_mode] - - set is_raw 1 - #don't disable handler - it will detect is_raw - ### twapi::set_console_control_handler {} - return [list stdin [list from $oldmode to $newmode]] + + } else { + + puts stderr "punk::console falling back to stty because twapi load failed" + proc [namespace parent]::enableAnsi {} { + puts stderr "punk::console::enableAnsi todo" } - #sometimes gives invalid handle.. (after stdin reopened?) - proc [namespace parent]::enableRaw1 {{channel stdin}} { - variable is_raw - #review - change to modify_console_input_mode - set console_handle [twapi::GetStdHandle -10] - set oldmode [twapi::GetConsoleMode $console_handle] - set newmode [expr {$oldmode & ~6}] ;# Turn off the echo and line-editing bits - twapi::SetConsoleMode $console_handle $newmode - set is_raw 1 - #don't disable handler - it will detect is_raw - ### twapi::set_console_control_handler {} - return [list stdin [list from $oldmode to $newmode]] + proc [namespace parent]::disableAnsi {} { } - proc [namespace parent]::disableRaw {{channel stdin}} { - variable is_raw - set console_handle [twapi::get_console_handle stdin] - set oldmode [twapi::get_console_input_mode] - - # Turn on the echo and line-editing bits - twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1 + #? + proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} { + } + proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} { + } + proc [namespace parent]::enableProcessedInput {args} { - set newmode [twapi::get_console_input_mode] + } + proc [namespace parent]::disableProcessedInput {args} { - set is_raw 0 - return [list stdin [list from $oldmode to $newmode]] } - proc [namespace parent]::disableRaw1 {{channel stdin}} { + + } + + proc [namespace parent]::enableRaw {{channel stdin}} { variable is_raw - set console_handle [twapi::GetStdHandle -10] - set oldmode [twapi::GetConsoleMode $console_handle] - set newmode [expr {$oldmode | 6}] ;# Turn on the echo and line-editing bits - twapi::SetConsoleMode $console_handle $newmode - set is_raw 0 - return [list stdin [list from $oldmode to $newmode]] - } + variable previous_stty_state_$channel + + if {[package provide twapi] ne ""} { + set console_handle [twapi::get_console_handle stdin] + #returns dictionary + #e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0 + set oldmode [twapi::get_console_input_mode] + twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0 + # Turn off the echo and line-editing bits + #set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]] + set newmode [twapi::get_console_input_mode] + + set is_raw 1 + #don't disable handler - it will detect is_raw + ### twapi::set_console_control_handler {} + return [list stdin [list from $oldmode to $newmode]] + } elseif {[set sttycmd [auto_execok stty]] ne ""} { + if {[set previous_stty_state_$channel] eq ""} { + set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] + } - } else { - if {$loadstate eq "failed"} { - puts stderr "punk::console falling back to stty because twapi load failed" - proc [namespace parent]::enableAnsi {} { - puts stderr "punk::console::enableAnsi todo" - } - proc [namespace parent]::enableRaw {{channel stdin}} { - set sttycmd [auto_execok stty] exec {*}$sttycmd raw -echo <@$channel + set is_raw 1 + #review - inconsistent return dict + return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] + } else { + error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting" } - proc [namespace parent]::disableRaw {{channel stdin}} { + } + + #note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?) + #could be we were missing a step in reopening stdin and console configuration? + + proc [namespace parent]::disableRaw {{channel stdin}} { + variable is_raw + variable previous_stty_state_$channel + + if {[package provide twapi] ne ""} { + set console_handle [twapi::get_console_handle stdin] + set oldmode [twapi::get_console_input_mode] + # Turn on the echo and line-editing bits + twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1 + set newmode [twapi::get_console_input_mode] + set is_raw 0 + return [list stdin [list from $oldmode to $newmode]] + } elseif {[set sttycmd [auto_execok stty]] ne ""} { set sttycmd [auto_execok stty] - exec {*}$sttycmd raw echo <@$channel + if {[set previous_stty_state_$channel] ne ""} { + exec {*}$sttycmd [set previous_stty_state_$channel] + set previous_stty_state_$channel "" + return restored + } + exec {*}$sttycmd -raw echo <@$channel + set is_raw 0 + #do we really want to exec stty yet again to show final 'to' state? + #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. + return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] + } else { + error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting" } } + + + } + + #capturingendregex should capture ANY prefix, whole escape match - and a subcapture of the data we're interested in and match at end of string. + #ie {(.*)(ESC(info)end)$} + #e.g {(.*)(\x1bP44!~([:alnum:])\x1b\\)$} + #we expect 4 results from regexp -indices -inline (overallmatch, prefix, wholeescape,info) + #todo - check capturingendregex value supplied has appropriate captures and tail-anchor + proc get_ansi_response_payload {query capturingendregex {inoutchannels {stdin stdout}}} { + lassign $inoutchannels input output + + #chunks from input that need to be handled by readers + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + + #we need to cooperate with other stdin/$input readers and put data here if we overconsume. + #Main repl reader may be currently active - or may be inactive. + #This call could come from within code called by the main reader - or from user code running while main read-loop is temporarily disabled + #In other contexts there may not even be another input reader + + #REVIEW - what if there is existing data in input_chunks_waiting - is it for us? + #temp - let's keep alert to it until we decide if it's legit/required.. + if {[info exists input_chunks_waiting($input)] && [llength $input_chunks_waiting($input)]} { + #puts stderr "[punk::ansi::a+ cyan bold]get_ansi_response_payload called while input_chunks_waiting($input) contained data: $input_chunks_waiting($input)[punk::ansi::a]" } + if {!$::punk::console::ansi_available} { + return "" + } + set callid [info cmdcount] ;#info cmdcount is almost as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + # + + upvar ::punk::console::ansi_response_chunk accumulator + upvar ::punk::console::ansi_response_wait waitvar + set accumulator($callid) "" + set waitvar($callid) "" + + + + #todo - use a linked array and an accumulatorid and waitvar id? When can there be more than one terminal query in-flight? + + set existing_handler [fileevent $input readable] ;#review! + fileevent $input readable {} + + set input_state [fconfigure $input] + + + #todo - test and save rawstate so we don't disableRaw if console was already raw + if {!$::punk::console::is_raw} { + set was_raw 0 + punk::console::enableRaw + } else { + set was_raw 1 + } + fconfigure $input -blocking 0 + # + set this_handler ::punk::console::internal::ansi_response_handler_regex + if {[lindex $existing_handler 0] eq $this_handler} { + puts stderr "[punk::ansi::a+ red]Warning get_ansi_response_payload called while existing ansi response handler in place[a]: $this_handler" + } + #in handler - its used for a boolean match (capturing aspect not used) + fileevent $input readable [list $this_handler $input $callid $capturingendregex] + + # - stderr vs stdout + #It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions + #(presumably race conditions as to when data hits console?) + #review - experiment changing this and calling functions to stderr and see if it works + #review - Are there disadvantages to using stdout vs stderr? + + #puts stdout "sending console request [ansistring VIEW $query]" + puts -nonewline $output $query;flush $output + + + #response from terminal + #e.g for cursor position \033\[46;1R + + #todo - make timeout configurable? + set waitvarname "::punk::console::ansi_response_wait($callid)" + set cancel_timeout_id [after 500 [list set $waitvarname timedout]] + + if {[set waitvar($callid)] eq ""} { + vwait ::punk::console::ansi_response_wait($callid) + } + #response handler automatically removes it's own fileevent + fileevent $input readable {} ;#explicit remove anyway - review + + if {$waitvar($callid) ne "timedout"} { + after cancel $cancel_timeout_id + } else { + puts stderr "timeout in get_ansi_response_payload" + } + + if {$was_raw == 0} { + punk::console::disableRaw + } + #restore $input state + fconfigure $input -blocking [dict get $input_state -blocking] + + + + set response [set accumulator($callid)] + + if {$response ne ""} { + set got_match [regexp -indices $capturingendregex $response _match_indices prefix_indices response_indices payload_indices] + if {$got_match} { + set responsedata [string range $response {*}$response_indices] + set payload [string range $response {*}$payload_indices] + set prefixdata [string range $response {*}$prefix_indices] + if {$prefixdata ne ""} { + #puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (response=[ansistring VIEW -lf 1 $responsedata])" + lappend input_chunks_waiting($input) $prefixdata + } + } else { + #timedout - or eof? + puts stderr "get_ansi_response_payload regex match '$capturingendregex' to data '[ansistring VIEW $response]' not found" + lappend input_chunks_waiting($input) $response + set payload "" + } + } else { + #timedout or eof? and nothing read + set payload "" + } + + #is there a way to know if existing_handler is input_chunks_waiting aware? + if {[string length $existing_handler] && [lindex $existing_handler 0] ne $this_handler} { + #puts "get_ansi_response_paylaod reinstalling ------>$existing_handler<------" + fileevent $input readable $existing_handler + #we may have consumed all pending input on $input - so there may be no trigger for the readable fileevent + if {[llength $input_chunks_waiting($input)]} { + #This is experimental If a handler is aware of input_chunks_waiting - there should be no need to schedule a trigger + #If it isn't, but the handler can accept an existing chunk of data as an argument - we could trigger and pass it the waiting chunks - but there's no way to know its API. + #we could look at info args - but that's not likely to tell us much in a robust way. + #we could create a reflected channel for stdin? That is potentially an overreach..? + #triggering it manually... as it was already listening - this should generally do no harm as it was the active reader anyway, but won't help with the missing data if it's input_chunks_waiting-unaware. + puts stderr "[punk::ansi::a+ yellow bold]-->punk::console::get_ansi_response_payload triggering existing handler while over-read data is in punk::console::input_chunks_waiting($input) instead of channel [ansistring VIEW $input_chunks_waiting($input)][punk::ansi::a]" + after idle [list after 0 $existing_handler] + } + #Note - we still may be in_repl_handler here (which disables its own reader while executing commandlines) + #The input_chunks_waiting may really belong to the existing_handler we found - but if it doesn't consume them they will end up being read by the repl_handler when it eventually re-enables. + #todo - some better structure than just a list of waiting chunks indexed by input channel, so repl/other handlers can determine the context in which these waiting chunks were generated? + } elseif {[llength $::repl::in_repl_handler]} { + if {[llength $input_chunks_waiting($input)]} { + #don't trigger the repl handler manually - we will inevitably get things out of order - as it knows when to enable/disable itself based on whether chunks are waiting. + #triggering it by putting it on the eventloop will potentially result in re-entrancy + #The cooperating reader must be designed to consume waiting chunks and only reschedule it's channel read handler once all waiting chunks have been consumed. + #puts stderr "[punk::ansi::a+ green bold]--> repl_handler has chunks to consume [ansistring VIEW $input_chunks_waiting($input)][punk::ansi::a]" + } + } + + catch { + unset accumulator($callid) + unset waitvar($callid) + } + + #set punk::console::chunk "" + return $payload } - #review - 1 byte at a time seems inefficient... but we don't have a way to peek or put back chars (?) - #todo - timeout - what if terminal doesn't put data on stdin? - #review - what if we slurp in data meant for main loop? Main loop probably needs to detect these responses and store them for lookup *instead* of this handler + + #review - reading 1 byte at a time and repeatedly running the small capturing/completion regex seems a little inefficient... but we don't have a way to peek or put back chars (?) + #review (we do have the punk::console::input_chunks_waiting($chan) array to cooperatively put back data - but this won't work for user scripts not aware of this) + #review - timeout - what if terminal doesn't put data on stdin? error vs stderr report vs empty results + #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? + #e.g what happens to mouse-events while user code is executing? #we may still need this handler if such a loop doesn't exist. - proc ansi_response_handler {chan accumulatorvar waitvar} { + proc ansi_response_handler_regex {chan callid endregex} { + upvar ::punk::console::ansi_response_chunk chunks + upvar ::punk::console::ansi_response_wait waits + #endregex should explicitly have a trailing $ set status [catch {read $chan 1} bytes] if { $status != 0 } { # Error on the channel - fileevent stdin readable {} - puts "error reading $chan: $bytes" - set $waitvar [list error_read status $status bytes $bytes] + fileevent $chan readable {} + puts "ansi_response_handler_regex error reading $chan: $bytes" + set waits($callid) [list error_read status $status bytes $bytes] } elseif {$bytes ne ""} { # Successfully read the channel - #puts "got: [string length $bytes]" - upvar $accumulatorvar chunk - append chunk $bytes - if {$bytes eq "R"} { - fileevent stdin readable {} - set $waitvar ok + #puts "got: [string length $bytes]bytes" + append chunks($callid) $bytes + #puts stderr [ansistring VIEW $chunks($callid)] + if {[regexp $endregex $chunks($callid)]} { + fileevent $chan readable {} + #puts stderr "matched - setting ansi_response_wait($callid) ok" + set waits($callid) ok } - } elseif { [eof $chan] } { - fileevent stdin readable {} + } elseif {[eof $chan]} { + fileevent $chan readable {} # End of file on the channel #review - puts "ansi_response_handler end of file" - set $waitvar eof - } elseif { [fblocked $chan] } { + puts stderr "ansi_response_handler_regex end of file on channel $chan" + set waits($callid) eof + } elseif {[fblocked $chan]} { # Read blocked. Just return + # Caller should be using timeout on the wait variable } else { - fileevent stdin readable {} + fileevent $chan readable {} # Something else - puts "ansi_response_handler can't happen" - set $waitvar error_unknown + puts stderr "ansi_response_handler_regex Situation shouldn't be possible. No error and no bytes read on channel $chan but chan is not fblocked or EOF" + set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof } } } ;#end namespace eval internal @@ -387,67 +694,86 @@ namespace eval punk::console { } } - namespace eval ansi { - proc a+ {args} { - puts -nonewline [::punk::ansi::a+ {*}$args] + + proc a {args} { + variable colour_disabled + variable ansi_wanted + if {$colour_disabled || $ansi_wanted <= 0} { + return } + #stdout + tailcall ansi::a {*}$args } - proc ansi+ {args} { + proc a+ {args} { variable colour_disabled - if {$colour_disabled == 1} { + variable ansi_wanted + if {$colour_disabled || $ansi_wanted <= 0} { return } #stdout tailcall ansi::a+ {*}$args } - proc get_ansi+ {args} { + proc a? {args} { + #stdout variable colour_disabled - if {$colour_disabled == 1} { - return + variable ansi_wanted + if {$colour_disabled || $ansi_wanted <= 0} { + puts -nonewline [punk::ansi::stripansi [::punk::ansi::a?]] + } else { + tailcall ansi::a? {*}$args } - tailcall punk::ansi::a+ {*}$args } - namespace eval ansi { - proc a {args} { - puts -nonewline [::punk::ansi::a {*}$args] + proc code_a {args} { + variable colour_disabled + variable ansi_wanted + if {$colour_disabled || $ansi_wanted <= 0} { + return } + tailcall punk::ansi::a {*}$args } - proc ansi {args} { + proc code_a? {args} { variable colour_disabled - if {$colour_disabled == 1} { - return + variable ansi_wanted + if {$colour_disabled || $ansi_wanted <= 0} { + return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]] + } else { + tailcall ::punk::ansi::a? {*}$args } - #stdout - tailcall ansi::a {*}$args } - proc get_ansi {args} { + proc code_a+ {args} { variable colour_disabled - if {$colour_disabled == 1} { + variable ansi_wanted + if {$colour_disabled || $ansi_wanted <= 0} { return } - tailcall punk::ansi::a {*}$args + tailcall punk::ansi::a+ {*}$args } - namespace eval ansi { - proc a? {args} { - puts -nonewline stdout [::punk::ansi::a? {*}$args] + proc ansi {{onoff {}}} { + variable ansi_wanted + if {[string length $onoff]} { + set onoff [string tolower $onoff] + if {$onoff in [list 1 on true yes]} { + set ansi_wanted 1 + } elseif {$onoff in [list 0 off false no]} { + set ansi_wanted 0 + } elseif {$onoff in [list default]} { + set ansi_wanted 2 + } else { + error "punk::console::ansi expected 0|1|on|off|true|false|yes|no|default" + } } + catch {repl::reset_prompt} + return [expr {$ansi_wanted}] } - proc ansi? {args} { - #stdout - tailcall ansi::a? {*}$args - } - proc get_ansi? {args} { - tailcall ::punk::ansi::a? {*}$args - } - proc colour {{onoff {}}} { variable colour_disabled if {[string length $onoff]} { set onoff [string tolower $onoff] + #an experiment with complete disabling vs test of state for each call if {$onoff in [list 1 on true yes]} { - interp alias "" a+ "" punk::console::ansi+ + interp alias "" a+ "" punk::console::code_a+ set colour_disabled 0 } elseif {$onoff in [list 0 off false no]} { interp alias "" a+ "" control::no-op @@ -460,14 +786,17 @@ namespace eval punk::console { return [expr {!$colour_disabled}] } - namespace eval ansi { - proc reset {} { - puts -nonewline stdout [punk::ansi::reset] - } - } - namespace import ansi::reset namespace eval ansi { + proc a {args} { + puts -nonewline [::punk::ansi::a {*}$args] + } + proc a? {args} { + puts -nonewline stdout [::punk::ansi::a? {*}$args] + } + proc a+ {args} { + puts -nonewline [::punk::ansi::a+ {*}$args] + } proc clear {} { puts -nonewline stdout [punk::ansi::clear] } @@ -480,11 +809,15 @@ namespace eval punk::console { proc clear_all {} { puts -nonewline stdout [punk::ansi::clear_all] } + proc reset {} { + puts -nonewline stdout [punk::ansi::reset] + } } namespace import ansi::clear namespace import ansi::clear_above namespace import ansi::clear_below namespace import ansi::clear_all + namespace import ansi::reset namespace eval local { proc set_codepage_output {cpname} { @@ -507,109 +840,103 @@ namespace eval punk::console { namespace import local::set_codepage_output namespace import local::set_codepage_input - - proc get_cursor_pos {} { - set ::punk::console::chunk "" - - set accumulator ::punk::console::chunk - set waitvar ::punk::console::chunkdone - set existing_handler [fileevent stdin readable] ;#review! - set $waitvar "" - - set stdin_state [fconfigure stdin] - - #todo - only use own handler if an existing stdin handler not present.. (or console is in line mode) - - #todo - test and save rawstate so we don't disableRaw if console was already raw - if {!$::punk::console::is_raw} { - set was_raw 0 - enableRaw - } else { - set was_raw 1 - } - fconfigure stdin -blocking 0 - # - fileevent stdin readable [list ::punk::console::internal::ansi_response_handler stdin $accumulator $waitvar] - - # - stderr vs stdout - #It has to be same channel as used by functions such as test_char_width or erroneous results returned for those functions - #(presumably race conditions as to when data hits console?) - #review - experiment changing this and calling functions to stderr and see if it works - #review - Are there disadvantages to using stdout vs stderr? - - puts -nonewline stdout \033\[6n ;flush stdout - after 0 {update idletasks} - - + # -- --- --- --- --- --- --- + #get_ansi_response functions + #review - can these functions sensibly be used on channels not attached to the local console? + #ie can we default to {stdin stdout} but allow other channel pairs? + # -- --- --- --- --- --- --- + proc get_cursor_pos {{inoutchannels {stdin stdout}}} { #response from terminal #e.g \033\[46;1R + set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} ;#must capture prefix,entire-response,response-payload - #todo - make timeout configurable? - set cancel_timeout_id [after 1500 {set $waitvar timedout}] - - set info "" - if {[set $waitvar] eq ""} { - vwait $waitvar - } - if {$waitvar ne "timedout"} { - after cancel $cancel_timeout_id - } else { - return "" - } - - if {$was_raw == 0} { - disableRaw - } - if {[string length $existing_handler]} { - fileevent stdin readable $existing_handler - } - #response handler automatically removes it's own fileevent - - #restore stdin state - fconfigure stdin -blocking [dict get $stdin_state -blocking] - - set info [set $accumulator] - set start [string first \x1b $info] - if {$start > 0} { - set other [string range $info 0 $start-1] - #!!!!! TODO - # Log this somewhere? Work out how to stop it happening? - #puts stderr "Warning - get_cursor_pos read extra data at start - '$other'" - set info [string range $info $start end] - } + set request "\033\[6n" + set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + return $payload + } + proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} { + #e.g \x1b\[P44!~E797\x1b\\ + #re e.g {(.*)(\x1b\[P44!~([[:alnum:]])\x1b\[\\)$} + set capturingregex [string map [list %id% $id] {(.*)(\x1bP%id%!~([[:alnum:]]+)\x1b\\)$}] + set request "\x1b\[${id}\;${page}\;$t\;$l\;$b\;$r*y" + set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + return $payload + } + proc get_device_status {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[([0-9]+)n)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[5n" + set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + return $payload + } - #set punk::console::chunk "" - set data [string range $info 2 end-1] - return $data - } proc get_cursor_pos_list {} { return [split [get_cursor_pos] ";"] } + proc get_size {} { + if {[catch { + puts -nonewline [punk::ansi::cursor_off][punk::ansi::cursor_save][punk::ansi::move 2000 2000] + lassign [get_cursor_pos_list] lines cols + puts -nonewline [punk::ansi::cursor_restore][punk::console::cursor_on];flush stdout + set result [list columns $cols rows $lines] + } errM]} { + puts -nonewline [punk::ansi::cursor_restore] + puts -nonewline [punk::ansi::cursor_on] + error "$errM" + } else { + return $result + } + } + proc get_dimensions {} { + lassign [get_size] _c cols _l lines + return "${cols}x${lines}" + } + #the (xterm?) CSI 18t query is supported by *some* terminals + proc get_xterm_size {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[18t" + set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + lassign [split $payload {;}] rows cols + return [list columns $cols rows $rows] + } #terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate. #todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position. #todo - determine if these anomalies are independent of font #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. proc test_char_width {char_or_string {emit 0}} { + return 1 + #JMN + #puts stderr "cwtest" + variable ansi_available + if {!$ansi_available} { + puts stderr "No ansi - cannot test char_width of '$char_or_string' returning [string length $char_or_string]" + return [string length $char_or_string] + } + if {!$emit} { puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1 } + set response "" if {[catch { - lassign [split [punk::console::get_cursor_pos] ";"] _row1 col1 + set response [punk::console::get_cursor_pos] } errM]} { puts stderr "Cannot test_char_width for '[punk::ansi::ansistring VIEW $char_or_string]' - may be no console? Error message from get_cursor_pos: $errM" return } - if {![string is integer -strict $col1]} { - puts stderr "Could not get response from get_cursor_pos" + lassign [split $response ";"] _row1 col1 + if {![string length $response] || ![string is integer -strict $col1]} { + puts stderr "test_char_width Could not interpret response from get_cursor_pos for initial cursor pos. Response: '[punk::ansi::ansistring VIEW $response]'" + flush stderr return } puts -nonewline stdout $char_or_string - lassign [split [punk::console::get_cursor_pos] ";"] _row2 col2 + set response [punk::console::get_cursor_pos] + lassign [split $response ";"] _row2 col2 if {![string is integer -strict $col2]} { - puts stderr "Could not get response from get_cursor_pos" + puts stderr "test_char_width could not interpret response from get_cursor_pos for post-emit cursor pos. Response:'[punk::ansi::ansistring VIEW $response]'" + flush stderr return } @@ -620,6 +947,50 @@ namespace eval punk::console { return [expr {$col2 - $col1}] } + #todo! - improve + proc test_can_ansi {} { + #don't set ansi_avaliable here - we want to be able to change things, retest etc. + if {"windows" eq "$::tcl_platform(platform)"} { + if {[package provide twapi] ne ""} { + set h_out [twapi::get_console_handle stdout] + set existing_mode [twapi::GetConsoleMode $h_out] + if {[expr {$existing_mode & 4}]} { + #virtual terminal processing happens to be enabled - so it's supported + return 1 + } + #output mode + #ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 + + #try temporarily setting it - if we get an error - ansi not supported + if {[catch { + twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] + } errM]} { + return 0 + } + #restore + twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] + return 1 + } else { + #todo - try a cursorpos query and read stdin to see if we got a response? + puts stderr "Unable to verify terminal ansi support - assuming modern default of true" + puts stderr "to force disable, use command: ansi off" + return 1 + } + } else { + return 1 + } + } + + #review + proc can_ansi {} { + variable ansi_available + if {!$ansi_available} { + return 0 + } + set ansi_available [test_can_ansi] + return [expr {$ansi_available}] + } + namespace eval ansi { proc cursor_on {} { puts -nonewline stdout [punk::ansi::cursor_on] @@ -663,7 +1034,15 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::titleset $windowtitle] } } - namespace import ansi::titleset + #namespace import ansi::titleset + proc titleset {windowtitle} { + variable ansi_wanted + if { $ansi_wanted <= 0} { + punk::console::local::titleset $windowtitle + } else { + tailcall ansi::titleset $windowtitle + } + } #no known pure-ansi solution proc titleget {} { return [local::titleget] @@ -747,14 +1126,14 @@ namespace eval punk::console { #review - worth the extra microseconds to inline? might be if used in for example prompt on every keypress. #caller should build as much as possible using the punk::ansi versions to avoid extra puts calls - proc save_cursor {} { + proc cursor_save {} { #*** !doctools - #[call [fun save_cursor]] + #[call [fun cursor_save]] puts -nonewline \x1b\[s } - proc restore_cursor {} { + proc cursor_restore {} { #*** !doctools - #[call [fun restore_cursor]] + #[call [fun cursor_restore]] puts -nonewline \x1b\[u } proc insert_spaces {count} { @@ -781,8 +1160,8 @@ namespace eval punk::console { namespace import ansi::move_down namespace import ansi::move_column namespace import ansi::move_row - namespace import ansi::save_cursor - namespace import ansi::restore_cursor + namespace import ansi::cursor_save + namespace import ansi::cursor_restore namespace import ansi::scroll_down namespace import ansi::scroll_up namespace import ansi::insert_spaces @@ -801,27 +1180,64 @@ namespace eval punk::console { #set blanks [string repeat " " [expr {$col + $tw}]] #puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text #puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] - save_cursor + cursor_save #move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text - puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text - restore_cursor + #puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text + puts -nonewline [punk::ansi::erase_eol][punk::ansi::move_column $col]$text + cursor_restore } proc move_emit_return {row col data args} { #todo detect if in raw mode or not? set is_in_raw 0 lassign [punk::console::get_cursor_pos_list] orig_row orig_col - move_emit $row $col $data + set commands "" + append commands [punk::ansi::move_emit $row $col $data] foreach {row col data} $args { - move_emit $row $col $data + append commands [punk::ansi::move_emit $row $col $data] } - if {!$is_in_raw} { incr orig_row -1 } - move $orig_row $orig_col + append commands [punk::ansi::move $orig_row $orig_col] + puts -nonewline stdout $commands return "" } + #we can be faster and more efficient if we use the consoles cursor_save command - but each savecursor overrides any previous one. + #leave cursor_off/cursor_on to caller who can wrap more efficiently.. + proc cursorsave_move_emit_return {row col data args} { + set commands "" + append commands [punk::ansi::cursor_save] + append commands [punk::ansi::move_emit $row $col $data] + foreach {row col data} $args { + append commands [punk::ansi::move_emit $row $col $data] + } + append commands [punk::ansi::cursor_restore] + puts -nonewline stdout $commands; flush stdout + } + proc move_emitblock_return {row col textblock} { + lassign [punk::console::get_cursor_pos_list] orig_row orig_col + + set commands "" + foreach ln [split $textblock \n] { + append commands [punk::ansi::move_emit $row $col $ln] + incr row + } + append commands [punk::ansi::move $orig_row $orig_col] + puts -nonewline $commands + return + } + proc cursorsave_move_emitblock_return {row col textblock} { + set commands "" + append commands [punk::ansi::cursor_save] + foreach ln [split $textblock \n] { + append commands [punk::ansi::move_emit $row $col $ln] + incr row + } + append commands [punk::ansi::cursor_restore] + puts -nonewline stdout $commands;flush stdout + return + } proc move_call_return {row col script} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col move $row $col @@ -829,7 +1245,7 @@ namespace eval punk::console { move $orig_row $orig_col } - #this doesn't work - we would need an internal virtual screen structure to pick up cursor attributes from arbitrary locations + #this doesn't work - we would need an internal virtual screen structure to pick up cursor attributes from arbitrary locations? # ncurses and its ilk may have something like that - but we specifically want to avoid curses libraries proc pick {row col} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col diff --git a/src/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index db187362..188a3591 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.0.tm @@ -18,6 +18,7 @@ ## Requirements ##e.g package require frobz package require punk::mix::base +package require struct::set namespace eval punk::du { @@ -65,7 +66,6 @@ namespace eval punk::du { #breadth-first with sort can be quite fast .. but memory usage can easily get out of control proc du { args } { variable has_twapi - package require struct::set if 0 { diff --git a/src/modules/punk/encmime-999999.0a1.0.tm b/src/modules/punk/encmime-999999.0a1.0.tm index ef1db01c..a35f0d32 100644 --- a/src/modules/punk/encmime-999999.0a1.0.tm +++ b/src/modules/punk/encmime-999999.0a1.0.tm @@ -50,9 +50,9 @@ #[para] packages used by punk::encmime #[list_begin itemized] -package require Tcl 8.6 +package require Tcl 8.6- #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6-}] # #package require frobz # #*** !doctools diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index cb928c0c..5f87e25f 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -60,10 +60,10 @@ #[para] packages needed by punk::fileline #[list_begin itemized] - package require Tcl 8.6 + package require Tcl 8.6- package require punk::args #*** !doctools - #[item] [package {Tcl 8.6}] + #[item] [package {Tcl 8.6-}] #[item] [package {punk::args}] @@ -1424,6 +1424,7 @@ namespace eval punk::fileline { set encoding_selected $bomenc } } else { + #!? if {$bomenc eq "binary"} { set datachunk [string range $rawchunk $startdata end] set encoding_selected binary @@ -1523,7 +1524,7 @@ namespace eval punk::fileline::lib { # is_span 1 boundaries {514 1026 1538} #[example_end] #[para] This function automatically uses lseq (if Tcl >= 8.7) when number of boundaries spanned is approximately greater than 75 - if {[catch {package require Tcl 8.7}]} { + if {[catch {package require Tcl 8.7-}]} { #only one implementation available for older Tcl tailcall punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize {*}$args } @@ -1675,7 +1676,7 @@ namespace eval punk::fileline::system { proc _range_spans_chunk_boundaries_TIMEIT {start end chunksize {repeat 1}} { puts "main : [time {punk::fileline::lib::range_spans_chunk_boundaries $start $end $chunksize} $repeat]" puts "tcl : [time {punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize} $repeat]" - if {![catch {package require Tcl 8.7}]} { + if {![catch {package require Tcl 8.7-}]} { puts "lseq : [time {punk::fileline::system::_range_spans_chunk_boundaries_lseq $start $end $chunksize} $repeat]" } } diff --git a/src/modules/punk/flib-999999.0a1.0.tm b/src/modules/punk/flib-999999.0a1.0.tm index 71ca97b1..86bf00a0 100644 --- a/src/modules/punk/flib-999999.0a1.0.tm +++ b/src/modules/punk/flib-999999.0a1.0.tm @@ -44,10 +44,10 @@ #[para] packages used by punk::flib #[list_begin itemized] -package require Tcl 8.6 +package require Tcl 8.6- package require pattern #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6-}] #[item] [package {pattern 1.2.4}] # #package require frobz diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 09ec4e3b..4d59d76c 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -47,9 +47,9 @@ #[para] packages used by punk::lib #[list_begin itemized] -package require Tcl 8.6 +package require Tcl 8.6- #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6-}] # #package require frobz # #*** !doctools @@ -596,7 +596,7 @@ namespace eval punk::lib { #set opts [dict merge {-block {}} $opts] set bposn [lsearch $opts -block] if {$bposn < 0} { - set opts {-block {}} + lappend opts -block {} } set text [lindex $args end] tailcall linelist {*}$opts $text @@ -617,7 +617,6 @@ namespace eval punk::lib { # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace proc linelist {args} { - #puts "---->linelist '$args'" set usage "linelist ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" if {[llength $args] == 0} { error "linelist missing textchunk argument usage:$usage" @@ -630,7 +629,7 @@ namespace eval punk::lib { -block {trimhead1 trimtail1}\ -line {}\ -commandprefix ""\ - -ansiresets 1\ + -ansiresets 0\ ] dict for {o v} $arglist { if {$o ni {-block -line -commandprefix -ansiresets}} { @@ -678,6 +677,8 @@ namespace eval punk::lib { # -- --- --- --- --- --- set opt_commandprefix [dict get $opts -commandprefix] # -- --- --- --- --- --- + set opt_ansiresets [dict get $opts -ansiresets] + # -- --- --- --- --- --- set linelist [list] set nlsplit [split $text \n] if {![llength $opt_line]} { @@ -761,6 +762,103 @@ namespace eval punk::lib { set linelist [lrange $linelist $start $end] } + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansiresets} { + set RST [a] + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + if {![punk::ansi::ta::detect $linelist]} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } else { + + + foreach ln $linelist { + set is_replay_pure_reset [punk::ansi::codetype::is_sgr_reset $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + set newreplay [join $codestack ""] + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + if {[llength $opt_commandprefix]} { set transformed [list] foreach ln $linelist { @@ -1233,7 +1331,46 @@ namespace eval punk::lib { return [dict create opts $opts values $values] } - + #tcl8.7/9 compatibility for 8.6 + if {[info commands ::tcl::string::insert] eq ""} { + #https://wiki.tcl-lang.org/page/string+insert + # Pure Tcl implementation of [string insert] command. + proc ::tcl::string::insert {string index insertString} { + # Convert end-relative and TIP 176 indexes to simple integers. + if {[regexp -expanded { + ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace + |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace + (?:([+-]) # op, omitted when index is "end" + ([+-]?\d+))? # n, omitted when index is "end" + [\t\n\v\f\r ]*$ # optional whitespace (unless "end") + } $index _ m op n]} { + # Convert first index to an integer. + switch $m { + end {set index [string length $string]} + default {scan $m %d index} + } + + # Add or subtract second index, if provided. + switch $op { + + {set index [expr {$index + $n}]} + - {set index [expr {$index - $n}]} + } + } elseif {![string is integer -strict $index]} { + # Reject invalid indexes. + return -code error "bad index \"$index\": must be\ + integer?\[+-\]integer? or end?\[+-\]integer?" + } + + # Concatenate the pre-insert, insertion, and post-insert strings. + string cat [string range $string 0 [expr {$index - 1}]] $insertString\ + [string range $string $index end] + } + + # Bind [string insert] to [::tcl::string::insert]. + namespace ensemble configure string -map [dict replace\ + [namespace ensemble configure string -map]\ + insert ::tcl::string::insert] + } #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib ---}] @@ -1322,6 +1459,7 @@ namespace eval punk::lib::system { return [concat $smallfactors [lreverse $largefactors] $x] } + # incomplte - report which is the innermost bracket/quote etc awaiting completion for a Tcl command #important - used by punk::repl proc incomplete {partial} { #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. @@ -1333,9 +1471,11 @@ namespace eval punk::lib::system { set waiting [list ""] set innerpartials [list ""] set escaped 0 + set i 0 foreach c $clist { if {$c eq "\\"} { set escaped [expr {!$escaped}] + incr i continue } ;# set escaped 0 at end set p [lindex $innerpartials end] @@ -1390,6 +1530,7 @@ namespace eval punk::lib::system { lset innerpartials end $p } set escaped 0 + incr i } set incomplete [list] foreach w $waiting { @@ -1404,7 +1545,7 @@ namespace eval punk::lib::system { set debug 0 if {$debug} { foreach w $waiting p $innerpartials { - puts stderr "->'$w' partial: $p" + puts stderr "->awaiting:'$w' partial: $p" } } return $incomplete diff --git a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm index a7324179..c11564bb 100644 --- a/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/layout-999999.0a1.0.tm @@ -114,11 +114,11 @@ namespace eval punk::mix::commandset::layout { set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] set table "" append table [string repeat - $tablewidth] \n - append table "[textblock::join [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n + append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n append table [string repeat - $tablewidth] \n foreach n $names pt $pathtypes p $paths { - append table "[textblock::join [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n } return $table @@ -161,11 +161,11 @@ namespace eval punk::mix::commandset::layout { set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] set table "" append table [string repeat - $tablewidth] \n - append table "[textblock::join [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n + append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n append table [string repeat - $tablewidth] \n foreach n $names pt $pathtypes p $paths { - append table "[textblock::join [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n + append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n } return $table diff --git a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm index 0e9beee5..5f8a33cf 100644 --- a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm @@ -59,9 +59,9 @@ #[para] packages used by punk::mix::commandset::project #[list_begin itemized] -package require Tcl 8.6 +package require Tcl 8.6- #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6-}] #[item] [package punk::ns] #[item] [package sqlite3] (binary) #[item] [package overtype] diff --git a/src/modules/punk/mix/templates/layouts/project/src/build.tcl b/src/modules/punk/mix/templates/layouts/project/src/build.tcl new file mode 100644 index 00000000..734ccb87 --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/build.tcl @@ -0,0 +1,6 @@ +#!/bin/sh +# -*- tcl -*- \ +# 'build.tcl' name as required by kettle +# Can be run directly - but also using `deck Kettle ...` or `deck KettleShell ...`\ +exec ./kettle -f "$0" "${1+$@}" +kettle doc diff --git a/src/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/templates/layouts/project/src/make.tcl new file mode 100644 index 00000000..10d8e7ed --- /dev/null +++ b/src/modules/punk/mix/templates/layouts/project/src/make.tcl @@ -0,0 +1,995 @@ +# tcl +# +#make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. +#e.g in 'bin' and 'modules' folders at same level as 'src' folder. + +set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" +puts $hashline +puts " punkshell make script " +puts $hashline\n +namespace eval ::punkmake { + variable scriptfolder [file normalize [file dirname [info script]]] + variable foldername [file tail $scriptfolder] + variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] + variable non_help_flags [list -k] + variable help_flags [list -help --help /?] + variable known_commands [list project get-project-info shell bootsupport] +} +if {"::try" ni [info commands ::try]} { + puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" + exit 1 +} + +#------------------------------------------------------------------------------ +#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder +#------------------------------------------------------------------------------ +#If the there is a folder under the current directory /src/bootsupport/modules which contains .tm files +# - then it will attempt to preference these modules +# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the make script +# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables +set startdir [pwd] +if {[file exists [file join $startdir src bootsupport]]} { + set bootsupport_mod [file join $startdir src bootsupport modules] + set bootsupport_lib [file join $startdir src bootsupport lib] +} else { + set bootsupport_mod [file join $startdir bootsupport modules] + set bootsupport_lib [file join $startdir bootsupport lib] +} +if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} { + + set original_tm_list [tcl::tm::list] + tcl::tm::remove {*}$original_tm_list + set original_auto_path $::auto_path + set ::auto_path [list $bootsupport_lib] + + set support_modules [glob -nocomplain -dir $bootsupport_mod -type f -tail *.tm] + set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] ;#packages we + if {[llength $support_modules] || [llength [glob -nocomplain -dir $bootsupport_lib -tail *]]} { + #only forget all *unloaded* package names + foreach pkg [package names] { + if {$pkg in $tcl_core_packages} { + continue + } + if {![llength [package versions $pkg]]} { + #puts stderr "Got no versions for pkg $pkg" + continue + } + if {![string length [package provide $pkg]]} { + #no returned version indicates it wasn't loaded - so we can forget its index + package forget $pkg + } + } + tcl::tm::add $bootsupport_mod + } + + + if {[file exists [pwd]/modules]} { + tcl::tm::add [pwd]/modules + } + + #package require Thread + # - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. + + + # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list + #These are strong dependencies + package forget punk::mix + package require punk::mix + package forget punk::repo + package require punk::repo + package forget punkcheck + package require punkcheck + + + + #restore module paths and auto_path in addition to the bootsupport ones + set tm_list_now [tcl::tm::list] + foreach p $original_tm_list { + if {$p ni $tm_list_now} { + tcl::tm::add $p + } + } + set ::auto_path [list $bootsupport_lib {*}$original_auto_path] + #------------------------------------------------------------------------------ +} + +# ** *** *** *** *** *** *** *** *** *** *** *** +#*temporarily* hijack package command +# ** *** *** *** *** *** *** *** *** *** *** *** +try { + rename ::package ::punkmake::package_temp_aside + proc ::package {args} { + if {[lindex $args 0] eq "require"} { + lappend ::punkmake::pkg_requirements [lindex $args 1] + } + } + package require punk::mix + package require punk::repo +} finally { + catch {rename ::package ""} + catch {rename ::punkmake::package_temp_aside ::package} +} +# ** *** *** *** *** *** *** *** *** *** *** *** +foreach pkg $::punkmake::pkg_requirements { + if {[catch {package require $pkg} errM]} { + puts stderr "missing pkg: $pkg" + lappend ::punkmake::pkg_missing $pkg + } else { + lappend ::punkmake::pkg_loaded $pkg + } +} + + + + + +proc punkmake_gethelp {args} { + set scriptname [file tail [info script]] + append h "Usage:" \n + append h "" \n + append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n + append h " - This help." \n \n + append h " $scriptname project ?-k?" \n + append h " - this is the literal word project - and confirms you want to run the project build" \n + append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n + append h " $scriptname bootsupport" \n + append h " - update the src/bootsupport modules as well as the mixtemplates/layouts//src/bootsupport modules if the folder exists" \n \n + append h " $scriptname get-project-info" \n + append h " - show the name and base folder of the project to be built" \n + append h "" \n + if {[llength $::punkmake::pkg_missing]} { + append h "* ** NOTE ** ***" \n + append h " punkmake has detected that the following packages could not be loaded:" \n + append h " " [join $::punkmake::pkg_missing "\n "] \n + append h "* ** *** *** ***" \n + append h " These packages are required for punk make to function" \n \n + append h "* ** *** *** ***" \n\n + append h "Successfully Loaded packages:" \n + append h " " [join $::punkmake::pkg_loaded "\n "] \n + } + return $h +} +set scriptargs $::argv +set do_help 0 +if {![llength $scriptargs]} { + set do_help 1 +} else { + foreach h $::punkmake::help_flags { + if {[lsearch $scriptargs $h] >= 0} { + set do_help 1 + break + } + } +} +set commands_found [list] +foreach a $scriptargs { + if {![string match -* $a]} { + lappend commands_found $a + } else { + if {$a ni $::punkmake::non_help_flags} { + set do_help 1 + } + } +} +if {[llength $commands_found] != 1 } { + set do_help 1 +} elseif {[lindex $commands_found 0] ni $::punkmake::known_commands} { + puts stderr "Unknown command: [lindex $commands_found 0]\n\n" + set do_help 1 +} +if {$do_help} { + puts stderr [punkmake_gethelp] + exit 0 +} + +set ::punkmake::command [lindex $commands_found 0] + + +if {[lsearch $::argv -k] >= 0} { + set forcekill 1 +} else { + set forcekill 0 +} +#puts stdout "::argv $::argv" +# ---------------------------------------- + +set scriptfolder $::punkmake::scriptfolder + + + +#first look for a project root (something under fossil or git revision control AND matches punk project folder structure) +#If that fails - just look for a 'project shaped folder' ie meets minimum requirements of /src /src/lib /src/modules /lib /modules +if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]} { + if {![string length [set projectroot [punk::repo::find_candidate $scriptfolder]]]} { + puts stderr "punkmake script unable to determine an approprite project root at or above the path '$scriptfolder' ensure the make script is within a project folder structure" + puts stderr " -aborted- " + exit 2 + #todo? + #ask user for a project name and create basic structure? + #call punk::mix::cli::new $projectname on parent folder? + } else { + puts stderr "WARNING punkmake script operating in project space that is not under version control" + } +} else { + +} + +set sourcefolder $projectroot/src + +if {$::punkmake::command eq "get-project-info"} { + puts stdout "- -- --- --- --- --- --- --- --- --- ---" + puts stdout "- -- get-project-info -- -" + puts stdout "- -- --- --- --- --- --- --- --- --- ---" + puts stdout "- projectroot : $projectroot" + if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { + set vc "fossil" + set rev [punk::repo::fossil_revision $scriptfolder] + set rem [punk::repo::fossil_remote $scriptfolder] + } elseif {[punk::repo::find_git $scriptfolder] eq $projectroot} { + set vc "git" + set rev [punk::repo::git_revision $scriptfolder] + set rem [punk::repo::git_remote $scriptfolder] + } else { + set vc " - none found -" + set rev "n/a" + set remotes "n/a" + } + puts stdout "- version control : $vc" + puts stdout "- revision : $rev" + puts stdout "- remote : $rem" + puts stdout "- -- --- --- --- --- --- --- --- --- ---" + + exit 0 +} + +if {$::punkmake::command eq "shell"} { + package require punk + package require punk::repl + puts stderr "make shell not fully implemented - dropping into ordinary punk shell" + repl::start stdin + + exit 1 +} + +if {$::punkmake::command eq "bootsupport"} { + puts "projectroot: $projectroot" + puts "script: [info script]" + #puts "-- [tcl::tm::list] --" + puts stdout "Updating bootsupport from local files" + + proc bootsupport_localupdate {projectroot} { + set bootsupport_modules [list] + set bootsupport_module_folders [list] + set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;# + if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules + source $bootsupport_config ;#populate $bootsupport_modules with project-specific list + if {![llength $bootsupport_modules]} { + puts stderr "No local bootsupport modules configured for updating" + } else { + + if {[catch { + #---------- + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } + + foreach {relpath module} $bootsupport_modules { + set module [string trim $module :] + set module_subpath [string map [list :: /] [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED + } else { + $boot_event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED + } + $boot_event end + } else { + file copy -force $srcfile $tgtfile + } + } + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy + } + } + + if {[llength $bootsupport_module_folders] % 2 != 0} { + #todo - change include_modules.config structure to be line based? we have no way of verifying paired entries because we accept a flat list + puts stderr "WARNING - Skipping bootsupport_module_folders - list should be a list of base subpath pairs" + } else { + foreach {base subfolder} $bootsupport_module_folders { + #user should be careful not to include recursive/cyclic structures e.g module that has a folder which contains other modules from this project + #It will probably work somewhat.. but may make updates confusing.. or worse - start making deeper and deeper copies + set src [file join $projectroot $base $subfolder] + if {![file isdirectory $src]} { + puts stderr "bootsupport folder not found: $src" + continue + } + + #subfolder is the common relative path - so don't include the base in the target path + set tgt [file join $targetroot $subfolder] + file mkdir $tgt + + puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)" + set overwrite "installedsourcechanged-targets" + set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } + } + + } + } + + bootsupport_localupdate $projectroot + + #/modules/punk/mix/templates/layouts only applies if the project has it's own copy of the punk/mix modules. Generally this should only apply to the punkshell project itself. + set layout_bases [list\ + $sourcefolder/project_layouts/custom/_project\ + ] + foreach project_layout_base $layout_bases { + if {[file exists $project_layout_base]} { + set project_layouts [glob -nocomplain -dir $project_layout_base -type d -tail *] + foreach layoutname $project_layouts { + #don't auto-create src/bootsupport - just update it if it exists + if {[file exists [file join $project_layout_base $layoutname/src/bootsupport]]} { + set antipaths [list\ + README.md\ + ] + set sourcemodules $projectroot/src/bootsupport/modules + set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules] + file mkdir $targetroot + + puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" + set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + flush stdout + } + } + } else { + puts stderr "No layout base at $project_layout_base" + } + } + puts stdout " bootsupport done " + flush stderr + flush stdout + #punk86 can hang if calling make.tcl via 'run' without this 'after' delay. punk87 unaffected. cause unknown. + #after 500 + ::exit 0 +} + + + +if {$::punkmake::command ne "project"} { + puts stderr "Command $::punkmake::command not implemented - aborting." + flush stderr + after 100 + exit 1 +} + + + +#only a single consolidated /modules folder used for target +set target_modules_base $projectroot/modules +file mkdir $target_modules_base + +#external libs and modules first - and any supporting files - no 'building' required +if {[file exists $sourcefolder/vendorlib]} { + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + + puts stdout "VENDORLIB: copying from $sourcefolder/vendorlib to $projectroot/lib (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/vendorlib $projectroot/lib -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + +} else { + puts stderr "VENDORLIB: No src/vendorlib folder found." +} + +if {[file exists $sourcefolder/vendormodules]} { + #install .tm *and other files* + puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md}] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] +} else { + puts stderr "VENDORMODULES: No src/vendormodules folder found." +} + +######################################################## +#templates +#e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync +#src to src/modules/punk/mix/templates/layouts/project/src + +set old_layout_update_list [list\ + [list project $sourcefolder/modules/punk/mix/templates]\ + [list basic $sourcefolder/mixtemplates]\ + ] +set layout_bases [list\ + $sourcefolder/project_layouts/custom/_project\ + ] + +foreach layoutbase $layout_bases { + if {![file exists $layoutbase]} { + continue + } + set project_layouts [glob -nocomplain -dir $layoutbase -type d -tail *] + foreach layoutname $project_layouts { + set config [dict create\ + -make-step sync_layouts\ + ] + #---------- + set tpl_installer [punkcheck::installtrack new make.tcl $layoutbase/.punkcheck] + $tpl_installer set_source_target $sourcefolder $layoutbase + set tpl_event [$tpl_installer start_event $config] + #---------- + set pairs [list] + set pairs [list\ + [list $sourcefolder/build.tcl $layoutbase/$layoutname/src/build.tcl]\ + [list $sourcefolder/make.tcl $layoutbase/$layoutname/src/make.tcl]\ + ] + + foreach filepair $pairs { + lassign $filepair srcfile tgtfile + + file mkdir [file dirname $tgtfile] + #---------- + $tpl_event targetset_init INSTALL $tgtfile + $tpl_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$tpl_event targetset_source_changes] changed]]\ + || [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\ + } { + $tpl_event targetset_started + # -- --- --- --- --- --- + puts stdout "PROJECT LAYOUT update - layoutname: $layoutname Copying from $srcfile to $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $tpl_event targetset_end FAILED -note "layout:$layoutname copy failed with err: $errM" + } else { + $tpl_event targetset_end OK -note "layout:$layoutname" + } + # -- --- --- --- --- --- + } else { + puts stderr "." + $tpl_event targetset_end SKIPPED + } + } + + $tpl_event end + $tpl_event destroy + $tpl_installer destroy + } +} +######################################################## + + +#default source module folder is at projectroot/src/modules +#There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) +set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] +foreach src_module_dir $source_module_folderlist { + puts stderr "Processing source module dir: $src_module_dir" + set dirtail [file tail $src_module_dir] + #modules and associated files belonging to this package/app + set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm + #set copied [list] + puts stdout "--------------------------" + puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base " + puts stdout "--------------------------" + + set overwrite "installedsourcechanged-targets" + #set overwrite "ALL-TARGETS" + puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" + set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -antiglob_paths {README.md}] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] +} + +set installername "make.tcl" + +# ---------------------------------------- +if {[punk::repo::is_fossil_root $projectroot]} { + set config [dict create\ + -make-step configure_fossil\ + ] + #---------- + set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] + $installer set_source_target $projectroot $projectroot + + set event [$installer start_event $config] + $event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file + set menufile $projectroot/.fossil-custom/mainmenu + $event targetset_addsource $menufile + #---------- + + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "Configuring fossil setting: mainmenu from: $menufile" + if {[catch { + set fd [open $menufile r] + fconfigure $fd -translation binary + set data [read $fd] + close $fd + exec fossil settings mainmenu $data + } errM]} { + $event targetset_end FAILED -note "fossil update failed: $errM" + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts stderr "." + $event targetset_end SKIPPED + } + $event end + $event destroy + $installer destroy +} + +set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] +if {$buildfolder ne "$sourcefolder/_build"} { + puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure" + puts stdout " -aborted- " + exit 2 +} + + +#find runtimes +set rtfolder $sourcefolder/runtime +set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *] +if {![llength $runtimes]} { + puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." + puts stderr "Add runtimes to $sourcefolder/runtime if required" + exit 0 +} + +if {[catch {exec sdx help} errM]} { + puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" + puts stderr "err: $errM" + exit 1 +} + +# -- --- --- --- --- --- --- --- --- --- +#load mapvfs.config file (if any) in runtime folder to map runtimes to vfs folders. +#build a dict keyed on runtime executable name. +#If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs +#If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. +set mapfile $rtfolder/mapvfs.config +set runtime_vfs_map [dict create] +set vfs_runtime_map [dict create] +if {[file exists $mapfile]} { + set fdmap [open $mapfile r] + fconfigure $fdmap -translation binary + set mapdata [read $fdmap] + close $fdmap + set mapdata [string map [list \r\n \n] $mapdata] + set missing [list] + foreach ln [split $mapdata \n] { + set ln [string trim $ln] + if {$ln eq "" || [string match #* $ln]} { + continue + } + set vfspaths [lassign $ln runtime] + if {[string match *.exe $runtime]} { + #.exe is superfluous but allowed + #drop windows .exe suffix so same config can work cross platform - extension will be re-added if necessary later + set runtime [string range $runtime 0 end-4] + } + if {$runtime ne "-"} { + set runtime_test $runtime + if {"windows" eq $::tcl_platform(platform)} { + set runtime_test $runtime.exe + } + if {![file exists [file join $rtfolder $runtime_test]]} { + puts stderr "WARNING: Missing runtime file $rtfolder/$runtime_test (line in mapvfs.config: $ln)" + lappend missing $runtime + } + } + foreach vfs $vfspaths { + if {![file isdirectory [file join $sourcefolder $vfs]]} { + puts stderr "WARNNING: Missing vfs folder [file join $sourcefolder $vfs] specified in mapvfs.config for runtime $runtime" + lappend missing $vfs + } + dict lappend vfs_runtime_map $vfs $runtime + } + if {[dict exists $runtime_vfs_map $runtime]} { + puts stderr "CONFIG FILE ERROR. runtime: $runtime was specified more than once in $mapfile." + exit 3 + } + dict set runtime_vfs_map $runtime $vfspaths + } + if {[llength $missing]} { + puts stderr "WARNING [llength $missing] missing items from $mapfile. (TODO - prompt user to continue/abort)" + foreach m $missing { + puts stderr " $m" + } + puts stderr "continuing..." + } +} +# -- --- --- --- --- --- --- --- --- --- + +set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] +#add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs) +dict for {vfs -} $vfs_runtime_map { + if {$vfs ni $vfs_folders} { + lappend vfs_folders $vfs + } +} +if {![llength $vfs_folders]} { + puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" + puts stdout " -done- " + exit 0 +} + +set vfs_folder_changes [dict create] ;#cache whether each .vfs folder has changes so we don't re-run tests if building from same .vfs with multiple runtime executables + +# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- +#set runtimefile [lindex $runtimes 0] +foreach runtimefile $runtimes { + #runtimefile e.g tclkit86bi.exe on windows tclkit86bi on other platforms + + #sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh + #sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW) + #if {![file exists $buildfolder/buildruntime.exe]} { + # file copy $rtfolder/$runtimefile $buildfolder/buildruntime.exe + #} + + set basedir $buildfolder + set config [dict create\ + -make-step copy_runtime\ + ] + #---------- + set installer [punkcheck::installtrack new $installername $basedir/.punkcheck] + $installer set_source_target $rtfolder $buildfolder + set event [$installer start_event $config] + $event targetset_init INSTALL $buildfolder/build_$runtimefile + $event targetset_addsource $rtfolder/$runtimefile + #---------- + + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + $event targetset_started + # -- --- --- --- --- --- + puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" + if {[catch { + file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile + } errM]} { + $event targetset_end FAILED + } else { + $event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts stderr "." + $event targetset_end SKIPPED + } + $event end + +} + +# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + +# +# loop over vfs_folders and for each one, loop over configured (or matching) runtimes - build with sdx if source .vfs or source runtime exe has changed. +# we are using punkcheck to install result to buildfolder so we create a .punkcheck file at the target folder to store metadata. +# punkcheck allows us to not rely purely on timestamps (which may be unreliable) +# +set startdir [pwd] +puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." +cd [file dirname $buildfolder] +#root folder mtime is insufficient for change detection. Tree mtime of folders only is a barely passable mechanism for vfs change detection in some circumstances - e.g if files added/removed but never edited in place +#a hash of full tree file & dir mtime may be more reasonable - but it remains to be seen if just tar & checksum is any/much slower. +#Simply rebuilding all the time may be close the speed of detecting change anyway - and almost certainly much faster when there is a change. +#Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source. +set exe_names_seen [list] +foreach vfs $vfs_folders { + + set vfsname [file rootname $vfs] + puts stdout " Processing vfs $sourcefolder/$vfs" + puts stdout " ------------------------------------" + set skipped_vfs_build 0 + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set basedir $buildfolder + set config [dict create\ + -make-step build_vfs\ + ] + + set runtimes [list] + if {[dict exists $vfs_runtime_map $vfs]} { + set runtimes [dict get $vfs_runtime_map $vfs] ;#map dict is unsuffixed (.exe stripped or was not present) + if {"windows" eq $::tcl_platform(platform)} { + set runtimes_raw $runtimes + set runtimes [list] + foreach rt $runtimes_raw { + if {![string match *.exe $rt] && $rt ne "-"} { + set rt $rt.exe + } + lappend runtimes $rt + } + } + } else { + #only match this vfs to a correspondingly named runtime if there was no explicit entry for that runtime + set matchrt [file rootname [file tail $vfs]] ;#e.g project.vfs -> project + if {![dict exists $runtime_vfs_map $matchrt]} { + if {"windows" eq $::tcl_platform(platform)} { + if {[file exists $rtfolder/$matchrt.exe]} { + lappend runtimes $matchrt.exe + } + } else { + lappend runtimes $matchrt + } + } + } + #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config + + + #todo - non kit based - zipkit? + # $runtimes may now include a dash entry "-" (from mapvfs.config file) + foreach rtname $runtimes { + #rtname of "-" indicates build a kit without a runtime + + #first configured runtime will be the one to use the same name as .vfs folder for output executable. Additional runtimes on this .vfs will need to suffix the runtime name to disambiguate. + #review: This mechanism may not be great for multiplatform builds ? We may be better off consistently combining vfsname and rtname and letting a later platform-specific step choose ones to install in bin with simpler names. + if {$rtname eq "-"} { + set targetkit $vfsname.kit + } else { + if {$::tcl_platform(platform) eq "windows"} { + set targetkit ${vfsname}.exe + } else { + set targetkit $vfsname + } + if {$targetkit in $exe_names_seen} { + #more than one runtime for this .vfs + set targetkit ${vfsname}_$rtname + } + } + lappend exe_names_seen $targetkit + # -- ---------- + set vfs_installer [punkcheck::installtrack new $installername $basedir/.punkcheck] + $vfs_installer set_source_target $sourcefolder $buildfolder + set vfs_event [$vfs_installer start_event {-make-step build_vfs}] + $vfs_event targetset_init INSTALL $buildfolder/$targetkit + $vfs_event targetset_addsource $sourcefolder/$vfs + if {$rtname ne "-"} { + $vfs_event targetset_addsource $buildfolder/build_$rtname + } + # -- ---------- + + set changed_unchanged [$vfs_event targetset_source_changes] + + if {[llength [dict get $changed_unchanged changed]] || [llength [$vfs_event get_targets_exist]] < [llength [$vfs_event get_targets]]} { + #source .vfs folder has changes + $vfs_event targetset_started + # -- --- --- --- --- --- + + #use + if {[file exists $buildfolder/$vfsname.new]} { + puts stderr "deleting existing $buildfolder/$vfsname.new" + file delete $buildfolder/$vfsname.new + } + + puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]" + + + if {[catch { + if {$rtname ne "-"} { + exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose + } else { + exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose + } + } result]} { + if {$rtname ne "-"} { + puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose failed with msg: $result" + } else { + puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose failed with msg: $result" + } + } else { + puts stdout "ok - finished sdx" + set separator [string repeat = 40] + puts stdout $separator + puts stdout $result + puts stdout $separator + } + + if {![file exists $buildfolder/$vfsname.new]} { + puts stderr "|err> make.tcl build didn't seem to produce output at $sourcefolder/_build/$vfsname.new" + $vfs_event targetset_end FAILED + exit 2 + } + + # -- --- --- + if {$::tcl_platform(platform) eq "windows"} { + set pscmd "tasklist" + } else { + set pscmd "ps" + } + + #killing process doesn't apply to .kit build + if {$rtname ne "-"} { + if {![catch { + exec $pscmd | grep $vfsname + } still_running]} { + + puts stdout "found $vfsname instances still running\n" + set count_killed 0 + foreach ln [split $still_running \n] { + puts stdout " $ln" + + if {$::tcl_platform(platform) eq "windows"} { + set pid [lindex $ln 1] + if {$forcekill} { + set killcmd [list taskkill /F /PID $pid] + } else { + set killcmd [list taskkill /PID $pid] + } + } else { + set pid [lindex $ln 0] + #review! + if {$forcekill} { + set killcmd [list kill -9 $pid] + } else { + set killcmd [list kill $pid] + } + } + puts stdout " pid: $pid (attempting to kill now using '$killcmd')" + if {[catch { + exec {*}$killcmd + } errMsg]} { + puts stderr "$killcmd returned an error:" + puts stderr $errMsg + if {!$forcekill} { + puts stderr "(try '[info script] -k' option to force kill)" + } + #avoid exiting if the kill failure was because the task has already exited + #review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? + if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { + exit 4 + } + } else { + puts stderr "$killcmd ran without error" + incr count_killed + } + } + if {$count_killed > 0} { + puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" + after 1000 + } + } else { + puts stderr "Ok.. no running '$vfsname' processes found" + } + } + + if {[file exists $buildfolder/$targetkit]} { + puts stderr "deleting existing $buildfolder/$targetkit" + if {[catch { + file delete $buildfolder/$targetkit + } msg]} { + puts stderr "Failed to delete $buildfolder/$targetkit" + exit 4 + } + } + #WINDOWS filesystem 'tunneling' (file replacement within 15secs) could cause targetkit to copy ctime & shortname metadata from previous file! + #This is probably harmless - but worth being aware of. + file rename $buildfolder/$vfsname.new $buildfolder/$targetkit + # -- --- --- --- --- --- + $vfs_event targetset_end OK + + + after 200 + set deployment_folder [file dirname $sourcefolder]/bin + file mkdir $deployment_folder + + # -- ---------- + set bin_installer [punkcheck::installtrack new "make.tcl" $deployment_folder/.punkcheck] + $bin_installer set_source_target $buildfolder $deployment_folder + set bin_event [$bin_installer start_event {-make-step final_kit_install}] + $bin_event targetset_init INSTALL $deployment_folder/$targetkit + #todo - move final deployment step outside of the build vfs loop? (final deployment can fail and then isn't rerun even though _build and deployed versions differ, unless .vfs modified again) + #set last_completion [$bin_event targetset_last_complete] + + $bin_event targetset_addsource $buildfolder/$targetkit + $bin_event targetset_started + # -- ---------- + + + set delete_failed 0 + if {[file exists $deployment_folder/$targetkit]} { + puts stderr "deleting existing deployed at $deployment_folder/$targetkit" + if {[catch { + file delete $deployment_folder/$targetkit + } errMsg]} { + puts stderr "deletion of deployed version at $deployment_folder/$targetkit failed: $errMsg" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$buildfolder/$targetkit" + puts stdout "to:" + puts stdout "$deployment_folder/$targetkit" + after 300 + file copy $buildfolder/$targetkit $deployment_folder/$targetkit + # -- ---------- + $bin_event targetset_end OK + # -- ---------- + } else { + $bin_event targetset_end FAILED -note "could not delete" + exit 5 + } + $bin_event destroy + $bin_installer destroy + + } else { + set skipped_vfs_build 1 + puts stderr "." + puts stdout "Skipping build for vfs $vfs with runtime $rtname - no change detected" + $vfs_event targetset_end SKIPPED + } + $vfs_event destroy + $vfs_installer destroy + } ;#end foreach rtname in runtimes + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- +} +cd $startdir + +puts stdout "done" +exit 0 + + diff --git a/src/modules/punk/mix/templates/modules/template_cli-0.0.1.tm b/src/modules/punk/mix/templates/modules/template_cli-0.0.1.tm index 4c2fad08..8d521a11 100644 --- a/src/modules/punk/mix/templates/modules/template_cli-0.0.1.tm +++ b/src/modules/punk/mix/templates/modules/template_cli-0.0.1.tm @@ -42,12 +42,12 @@ #[para] packages used by %pkg% #[list_begin itemized] -package require Tcl 8.6 +package require Tcl 8.6- package require punk::overlay package require punk::mix::base package require punk::mix::util #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6-}] #[item] [package {punk::overlay}] #[item] [package {punk::mix::base}] #[item] [package {punk::mix::util}] diff --git a/src/modules/punk/mix/templates/modules/template_module-0.0.1.tm b/src/modules/punk/mix/templates/modules/template_module-0.0.1.tm index 3e44c9ff..1be8c160 100644 --- a/src/modules/punk/mix/templates/modules/template_module-0.0.1.tm +++ b/src/modules/punk/mix/templates/modules/template_module-0.0.1.tm @@ -44,9 +44,9 @@ #[para] packages used by %pkg% #[list_begin itemized] -package require Tcl 8.6 +package require Tcl 8.6- #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6-}] # #package require frobz # #*** !doctools diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index b03e5d92..7e594b2b 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -766,8 +766,9 @@ namespace eval punk::ns { set e [a+ yellow bold] set o [a+ cyan bold] set p [a+ white bold] + + set a1 [a][a+ cyan] foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 { - set a1 [a+ cyan] set c1 [a+ white] set c2 [a+ white] set c3 [a+ white] diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index 2df6f488..5d55aded 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -44,9 +44,9 @@ #[para] packages used by punk::path #[list_begin itemized] -package require Tcl 8.6 +package require Tcl 8.6- #*** !doctools -#[item] [package {Tcl 8.6}] +#[item] [package {Tcl 8.6-}] # #package require frobz # #*** !doctools diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index c6fe1e21..2787e5a9 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -37,6 +37,8 @@ package require shellrun package require punk package require punk::ns package require punk::ansi +package require punk::console +package require textblock @@ -95,7 +97,6 @@ namespace eval punk::repl { } } - namespace eval repl { #since we are targeting Tcl 8.6+ - we should be using 'interp bgerror .' #todo - make optional/configurable? @@ -111,6 +112,7 @@ namespace eval repl { } proc bgerror {message} { puts stderr "*> repl background error: $message" + puts stderr "*> [set ::errorInfo]" set stdinreader [fileevent stdin readable] if {![string length $stdinreader]} { puts stderr "*> stdin reader inactive" @@ -147,34 +149,36 @@ if {$::tcl_platform(platform) eq "windows"} { #rputs stderr "* console_control: $args" if {$::punk::console::is_raw} { #how to let rawmode loop handle it? It doesn't seem to get through if we return 0 - puts stderr "ctrl-c while in raw mode" + puts stderr "signal ctrl-c while in raw mode" + after 200 {exit 42} ;#temp + flush stderr return 42 } #note - returning 0 means pass event to other handlers including OS default handler if {$::repl::signal_control_c <= 2} { set remaining [expr {3 - $::repl::signal_control_c}] - puts stderr "ctrl-c (perform $remaining more to quit, enter to return to repl)" + puts stderr "signal ctrl-c (perform $remaining more to quit, enter to return to repl)" flush stderr return 1 } elseif {$::repl::signal_control_c == 3} { - puts stderr "ctrl-c x3 received - quitting" + puts stderr "signal ctrl-c x3 received - quitting" flush stderr after 25 quit return 1 } elseif {$::repl::signal_control_c == 4} { - puts stderr "ctrl-c x4 received - one more to hard exit" + puts stderr "signal ctrl-c x4 received - one more to hard exit" flush stderr return 1 } elseif {$::repl::signal_control_c >= 5} { #a script that allows events to be processed could still be running - puts stderr "ctrl-c x5 received - hard exit" + puts stderr "signal ctrl-c x5 received - hard exit" flush stderr after 25 exit 499 ;# HTTP 'client closed request' - just for the hell of it. } else { - puts stderr "ctrl-c $::repl::signal_control_c received" + puts stderr "signal ctrl-c $::repl::signal_control_c received" flush stderr #return 0 to fall through to default handler return 0 @@ -182,8 +186,8 @@ if {$::tcl_platform(platform) eq "windows"} { } twapi::set_console_control_handler ::repl::term::handler_console_control proc ::repl::term::set_console_title {text} { - #twapi::set_console_title $text - puts -nonewline [term::ansi::code::ctrl::title $text] + #go via console - in case ansi disabled/unavailable + punk::console::titleset $text } proc ::repl::term::set_console_icon {name} { #todo @@ -629,50 +633,13 @@ proc repl::term::reset {} { puts stdout [::term::ansi::code::ctrl::rd] } -proc repl::doprompt {prompt {col {green bold}}} { - #prompt to stderr. - #We can pipe commands into repl's stdin without the prompt interfering with the output. - #Although all command output for each line goes to stdout - not just what is emmited with puts - - if {$::tcl_interactive} { - set last_char_info [screen_last_char_getinfo] - if {![llength $last_char_info]} { - set needs_clearance 1 - } else { - lassign $last_char_info c what why - if {$why eq "prompt"} { - set needs_clearance 0 - } else { - set needs_clearance [screen_needs_clearance] - #puts -nonewline "-->$needs_clearance $last_char_info" - } - } - if {$needs_clearance == 1} { - set c \n - } else { - set c "" - } - - #this sort of works - but steals some of our stdin data ? review - # - #lassign [punk::console::get_cursor_pos_list] column row - #if {$row != 1} { - # set c "\n" - #} - - set o [a= {*}$col] - set r [a=] - puts -nonewline stderr $c$o$prompt$r - screen_last_char_add " " "prompt-stderr" prompt - flush stderr - } -} proc repl::get_prompt_config {} { if {$::tcl_interactive} { - set resultprompt "[a green bold]-[a] " - set nlprompt "[a green bold].[a] " - set infoprompt "[a green bold]*[a] " - set debugprompt "[a purple bold]~[a] " + set RST [a] + set resultprompt "[a green bold]-$RST " + set nlprompt "[a green bold].$RST " + set infoprompt "[a green bold]*$RST " + set debugprompt "[a purple bold]~$RST " } else { set resultprompt "" set nlprompt "" @@ -684,6 +651,13 @@ proc repl::get_prompt_config {} { proc repl::start {inchan args} { variable commandstr variable readingchunk + + # --- + variable editbuf + variable editbuf_list ;#command history + variable editbuf_lineindex_submitted + # --- + variable running variable reading variable done @@ -699,6 +673,20 @@ proc repl::start {inchan args} { set running 1 set commandstr "" set readingchunk "" + + # --- + set editbuf [punk::repl::class::class_editbuf new {}] + lappend editbuf_list $editbuf ;#current editbuf is always in the history + set editbuf_lineindex_submitted -1 + # --- + + if {$::punk::console::ansi_wanted == 2} { + if {[::punk::console::test_can_ansi]} { + set punk::console::ansi_wanted 1 + } else { + set punk::console::ansi_wanted -1 + } + } set prompt_config [get_prompt_config] doprompt "P% " fileevent $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] @@ -743,15 +731,24 @@ proc repl::reopen_stdin {} { } #puts stderr "channels:[chan names]" #flush stderr - catch {chan close stdin} + #catch {chan close stdin} + chan close stdin if {$::tcl_platform(platform) eq "windows"} { - set s [open "CON" r] + #set s [open "CON" r] + set s [open {CONIN$} r] + if {[package provide twapi] ne ""} { + set h [twapi::get_tcl_channel_handle $s in] + twapi::SetStdHandle -10 $h + } + puts stderr "restarting repl on inputchannel:$s" + return [repl::start $s] } else { #/dev/tty - reference to the controlling terminal for a process #review/test set s [open "/dev/tty" r] } + repl::start stdin } @@ -887,6 +884,51 @@ proc repl::newout2 {} { } #-------------------------------------- +proc repl::doprompt {prompt {col {green bold}}} { + #prompt to stderr. + #We can pipe commands into repl's stdin without the prompt interfering with the output. + #Although all command output for each line goes to stdout - not just what is emmited with puts + + if {$::tcl_interactive} { + set last_char_info [screen_last_char_getinfo] + if {![llength $last_char_info]} { + set needs_clearance 1 + } else { + lassign $last_char_info c what why + if {$why eq "prompt"} { + set needs_clearance 0 + } else { + set needs_clearance [screen_needs_clearance] + #puts -nonewline "-->$needs_clearance $last_char_info" + } + } + if {$needs_clearance == 1} { + set c \n + } else { + set c "" + } + set pre "" + if {[string first \n $prompt] >=0} { + set plines [split $prompt \n] + set pre [join [lrange $plines 0 end-1] \n]\n + set prompt [lindex $plines end] + } + + #this sort of works - but steals some of our stdin data ? review + # + #lassign [punk::console::get_cursor_pos_list] column row + #if {$row != 1} { + # set c "\n" + #} + + set o [a {*}$col] + set r [a] + puts -nonewline stderr $c$pre$o$prompt$r + screen_last_char_add " " "prompt-stderr" prompt + flush stderr + } +} + #use rputs in repl_handler instead of puts # - to help ensure we don't emit extra blank lines in info or debug output #rputs expects the standard tcl 'puts' command to be in place. @@ -896,13 +938,22 @@ proc repl::rputs {args} { variable screen_last_chars variable last_out_was_newline variable last_repl_char - + + set pseudo_map [dict create\ + debug stderr\ + debugreport stderr\ + ] + if {[::tcl::mathop::<= 1 [llength $args] 3]} { set out [lindex $args end] append out ""; #copy on write if {([llength $args] > 1) && [lindex $args 0] ne "-nonewline"} { set this_tail \n set rputschan [lindex $args 0] + #map pseudo-channels to real + if {$rputschan in [dict keys $pseudo_map]} { + lset args 0 [dict get $pseudo_map $rputschan] + } } elseif {[llength $args] == 1} { set this_tail \n set rputschan "stdout" @@ -910,15 +961,23 @@ proc repl::rputs {args} { #>1 arg with -nonewline set this_tail [string index $out end] set rputschan [lindex $args 1] + #map pseudo-channels to real + if {$rputschan in [dict keys $pseudo_map]} { + lset args 0 [dict get $pseudo_map $rputschan] + } } - set last_char_info_width 40 + set last_char_info_width 60 #review - string shouldn't be truncated prior to stripcodes - could chop ansi codes! #set summary "[::shellfilter::ansi::stripcodes [string range $out 0 $last_char_info_width]]" - set summary [punk::ansi::stripansi [string range $out 0 $last_char_info_width]] - if {[string length $out] > $last_char_info_width} { + set out_plain_text [punk::ansi::stripansi $out] + set summary [string range $out_plain_text 0 $last_char_info_width] + if {[string length $summary] > $last_char_info_width} { append summary " ..." } + + #make sure we use supplied rputschan in the screen_las_char_add 'what' - which may not be the underlying chan if it was a pseudo screen_last_char_add $this_tail repl-$rputschan $summary + #tailcall? puts {*}$args } else { @@ -982,13 +1041,342 @@ namespace eval repl { variable startinstance 0 variable loopinstance 0 variable loopcomplete 0 + + + variable in_repl_handler [list] } -proc repl::repl_handler {inputchan prompt_config} { - variable loopinstance - variable loopcomplete - incr loopinstance +namespace eval punk::repl::class { + #multiline editing buffer + oo::class create class_editbuf { + variable o_context + variable o_config + + variable o_rendered_lines + variable o_remaining ;#? + + #o_chunk_list & o_chunk_info should make timed viewing of replays possible + variable o_chunk_list + variable o_chunk_info ;#arrival timing etc + variable o_cursor_row + variable o_cursor_col + variable o_insert_mode + constructor {configdict {contextdict {}}} { + my clear + set o_config $configdict + if {[dict exists $configdict rendered_initialchunk]} { + #pre-rendered initial chunk + #-- + set o_chunk_list "" ;#replace empty chunk from 'clear' call + set o_chunk_info [dict create] + #-- + set ch [dict get $configdict rendered_initialchunk] + my add_rendered_chunk $ch + } + + set o_context $contextdict + #error "[self class].constructor Unable to interpret config '$o_config'" + } + method cursor_row {} { + return $o_cursor_row + } + method cursor_column {} { + return $o_cursor_col + } + method insert_mode {} { + return $o_insert_mode + } + method clear {} { + set o_rendered_lines [list ""] + set o_chunk_list [list] + set o_chunk_info [dict create] + set o_cursor_row 1 + set o_cursor_col 1 + set o_insert_mode 1 ;#default to insert mode + lappend o_chunk_list "" + dict set o_chunk_info 0 [dict create micros [clock microseconds] type rendered] + } + method add_chunk {chunk} { + #we still split on lf - but each physical line may contain horizontal or vertical movements so we need to feed each line in and possibly get an overflow_right and unapplied and cursor-movent return info + lappend o_chunk_list $chunk ;#may contain newlines,horizontal/vertical movements etc - all ok + dict set o_chunk_info [expr {[llength $o_chunk_list] -1}] [dict create micros [clock microseconds] type raw] + if {$chunk eq ""} { + return + } + + set firstnl [string first \n $chunk] + set newparts [split $chunk \n] + #attempt to render new 'lines' into the editbuffer - taking account of active cursor row & col & insertmode + + #merge based on current cursor row and col + #set lastrline [lindex $o_rendered_lines end] + #set n0 [lindex $newparts 0] + #set merged0 [string cat $lastrline $n0] + + #we should merge first row of newparts differently in case our chunks split a grapheme-combination? + # + set cursor_row_idx [expr {$o_cursor_row -1}] + set activeline [lindex $o_rendered_lines $cursor_row_idx] + set new0 [lindex $newparts 0] + #set combined [string cat $activeline $new0] + #use -cursor_row to tell renderline it's row context. + if {$firstnl >=0} { + #append combined \n + append new0 \n + } + set underlay $activeline + set line_nextchar_col [expr {[punk::char::string_width $underlay] + 1}] + if {$o_cursor_col > $line_nextchar_col} { + set o_cursor_col $line_nextchar_col + } + + set mergedinfo [overtype::renderline -info 1 -overflow 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $underlay $new0] + + set result [dict get $mergedinfo result] + set o_insert_mode [dict get $mergedinfo insert_mode] + set result_col [dict get $mergedinfo cursor_column] + set cmove [dict get $mergedinfo cursor_row_change] + set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v + set unapplied [dict get $mergedinfo unapplied] + set insert_lines_below [dict get $mergedinfo insert_lines_below] + set insert_lines_above [dict get $mergedinfo insert_lines_above] + + # -- --- --- --- --- --- + set debug_first_row 2 + #puts "merged: $mergedinfo" + set debug "add_chunk0" + append debug \n $mergedinfo + append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $new0] before row:$o_cursor_row after row: $cmove before col:$o_cursor_col after col:$result_col" + package require textblock + set debug [textblock::frame $debug] + catch {punk::console::move_emitblock_return $debug_first_row 1 $debug} + # -- --- --- --- --- --- + + set o_cursor_col $result_col + set cursor_row_idx [expr {$o_cursor_row-1}] + lset o_rendered_lines $cursor_row_idx $result + + if {[string is integer -strict $cmove]} { + #cmove - positive,negative or zero + if {$cmove == 0} { + #set nextrow [expr {$o_cursor_row + 1}] + #set o_cursor_col 1 + } elseif {$cmove == 1} { + #check for overflow_right and unapplied + #leave cursor_column + } elseif {$cmove >= 1} { + + } + } else { + # = - absolute + set nextrow [string range $cmove 1 end] + } + if {$insert_lines_below > 0} { + for {set i 0} {$i < $insert_lines_below} {incr i} { + lappend o_rendered_lines "" + } + set o_cursor_col 1 + } + if {$insert_lines_above > 0} { + #for {set i 0} {$i < $insert_lines_above} {incr i} { + # set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] + # incr nextrow -1 + #} + #set o_cursor_col 1 + } + + set o_cursor_row $nextrow + set cursor_row_idx [expr {$o_cursor_row-1}] + if {$cursor_row_idx < [llength $o_rendered_lines]} { + set activeline [lindex $o_rendered_lines $cursor_row_idx] + } else { + lappend o_rendered_lines "" + set activeline "" + } + + + set i 1 + foreach p [lrange $newparts 1 end] { + if {$i < [llength $newparts]-1} { + append p \n + } else { + if {$p eq ""} { + break + } + } + #puts stderr "overtype::renderline -info 1 -overflow 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $activeline '$p'" + set underlay $activeline + set line_nextchar_col [expr {[punk::char::string_width $underlay] + 1}] + if {$o_cursor_col > $line_nextchar_col} { + set o_cursor_col $line_nextchar_col + } + set mergedinfo [overtype::renderline -info 1 -overflow 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $underlay $p] + set debug "add_chunk$i" + append debug \n $mergedinfo + append debug \n "input:[ansistring VIEW -lf 1 -vt 1 $p]" + package require textblock + set debug [textblock::frame $debug] + #catch {punk::console::move_emitblock_return [expr {$debug_first_row + ($i * 6)}] 1 $debug} + + set result [dict get $mergedinfo result] + set o_insert_mode [dict get $mergedinfo insert_mode] + set o_cursor_col [dict get $mergedinfo cursor_column] + set cmove [dict get $mergedinfo cursor_row_change] + set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v + set unapplied [dict get $mergedinfo unapplied] + set insert_lines_below [dict get $mergedinfo insert_lines_below] + if {[string is integer -strict $cmove]} { + if {$cmove == 0} { + set nextrow [expr {$o_cursor_row + 1}] + set o_cursor_col 1 + } elseif {$cmove == 1} { + #check for overflow_right and unapplied + #leave cursor_column + } elseif {$cmove >= 1} { + + } + + } else { + # = - absolute + set nextrow [string range $cmove 1 end] + } + if {$nextrow eq $o_cursor_row} { + incr nextrow + } + set o_cursor_row $nextrow + if {$insert_lines_below} { + + } + + set cursor_row_idx [expr {$o_cursor_row-1}] + if {$cursor_row_idx < [llength $o_rendered_lines]} { + set activeline [lindex $o_rendered_lines $cursor_row_idx] + } else { + lappend o_rendered_lines "" + set activeline "" + } + lset o_rendered_lines $cursor_row_idx $result + + incr i + } + + } + method add_rendered_chunk {rchunk} { + #split only on lf newlines - movement codes and \b \v \r not expected + #check only for \v \r as chars we don't expect/want in rendered lines + #chunk as been pre-rendered (or is known to be plain ascii without ANSI or \b \v \r) + #but we don't yet have grapheme split info for it + + if {[regexp {[\v\b\r]} $rchunk]} { + error "[self class].add_rendered_chunk chunk contains \\v or \\b or \\r. Rendered chunk shouldn't contain these characters or ANSI movement codes" + } + lappend o_chunk_list $rchunk ;#rchunk may contain newlines - that's ok + dict set o_chunk_info [expr {[llength $o_chunk_list] -1}] [dict create micros [clock microseconds] type rendered] + + set newparts [split $rchunk \n] + #lappend o_chunk_list $rchunk + set lastrline [lindex $o_rendered_lines end] + + #in renderedlines list merge last line of old with first line of new + #we can't just cat the newpart on to existing rendered line - the chunk could have split a grapheme (e.g char+combiner(s)) + #we + #todo - redo grapheme split on merged line + set merged [string cat $lastrline [lindex $newparts 0]] + lset o_rendered_lines end $merged + + #todo + #each newpart needs its grapheme split info to be stored + set o_rendered_lines [concat $o_rendered_lines [lrange $newparts 1 end]] + + } + method linecount {} { + return [llength $o_rendered_lines] + } + method line {idx} { + return [lindex $o_rendered_lines $idx] + } + method lines {args} { + if {![llength $args]} { + set range [list 0 end] + } else { + set range $args + } + return [lrange $o_rendered_lines {*}$range] + } + #min value 1? + method view_lines {} { + set result "" + foreach ln $o_rendered_lines { + append result $ln \n + } + return $result + } + method debugview_lines {} { + set result "" + foreach ln $o_rendered_lines { + append result [ansistring VIEW -lf 1 -vt 1 $ln] \n ;#should be no lf or vt - but if there is.. we'd better show it + } + append result \n "cursor row: $o_cursor_row col: $o_cursor_col" + return $result + } + method last_char {} { + return [string index [lindex $o_chunk_list end] end] + } + #more strictly - last non-ansi? + method last_grapheme {} { + set lastchunk [lindex $o_chunk_list end] + set plaintext_parts [punk::ansi::ta::split_at_codes $lastchunk] + set pt [lindex $plaintext_parts end] + if {$pt eq ""} { + set pt [lindex $plaintext_parts end-1] + } + set graphemes [punk::char::grapheme_split $pt] + return [lindex $graphemes end] + } + method last_ansi {} { + set lastchunk [lindex $o_chunk_list end] + set parts [punk::ansi::ta::split_codes_single $lastchunk] + set lastcode [lindex $parts end-1] + return [ansistring VIEW -lf 1 $lastcode] + } + method chunks {} { + return $o_chunk_list + } + method view_chunks {} { + set result "" + set dashes [string repeat - 20] + foreach arrival_chunk $o_chunk_list chunk_id [dict keys $o_chunk_info] { + set chunk_info [dict get $o_chunk_info $chunk_id] + append result $dashes \n + set micros [dict get $chunk_info micros] + append result "$chunk_id arrival: [clock format [expr {$micros / 1000000}] -format "%Y-%m-%d %H:%M:%S"] ($micros)" \n + append result $dashes \n + append result $arrival_chunk \n + } + return $result + } + + method debugview_chunks {} { + set result "" + foreach ln $o_chunk_list { + append result [ansistring VIEW -lf 1 -vt 1 $ln] \n + } + append result \n "cursor row: $o_cursor_row col: $o_cursor_col" + return $result + } + method view_raw {} { + return [join $o_chunk_list ""] + } + method debugview_raw {} { + set sublf [ansistring VIEW -lf 1 \n] + #set subvt [ansistring VIEW -lvt 1 \v] ;#vt replacement with $subvt\v will not align accurately.. todo ? + return [string map [list $sublf $sublf\n] [ansistring VIEW -lf 1 -vt 0 [join $o_chunk_list ""]]] + } + } + +} +proc repl::repl_handler_checkchannel {inputchan} { if {$::repl::signal_control_c > 0 || [chan eof $inputchan]} { if {[lindex $::errorCode 0] eq "CHILDKILLED"} { @@ -1008,11 +1396,187 @@ proc repl::repl_handler {inputchan prompt_config} { } set [namespace current]::done 1 #test - tailcall repl::reopen_stdin + #tailcall repl::reopen_stdin + } + } +} +proc repl::repl_handler_restorechannel {inputchan previous_input_state} { + if {[chan conf $inputchan] ne $previous_input_state} { + set restore_input_conf [dict remove $previous_input_state -inputmode] ;#Attempting to set input mode often gives permission denied on windows - why? + if {[catch { + chan conf $inputchan {*}$restore_input_conf + } errM]} { + rputs stderr "|repl>original: [ansistring VIEW $previous_input_state]" + rputs stderr "|repl>current : [ansistring VIEW [chan conf $inputchan]]" + rputs stderr "\n|repl> Failed to return $inputchan to original state" + rputs stderr "|repl>ERR: $errM" + } + } + return [chan conf $inputchan] +} +proc repl::repl_handler {inputchan prompt_config} { + variable in_repl_handler + set in_repl_handler [list $inputchan $prompt_config] + + fileevent $inputchan readable {} + upvar ::punk::console::input_chunks_waiting input_chunks_waiting + #note -inputmode not available in Tcl 8.6 for chan configure! + set rawmode 0 + set original_input_conf [chan configure $inputchan] ;#whether repl is in line or raw mode - we restore the stdin state + if {[dict exists $original_input_conf -inputmode]} { + if {[dict get $original_input_conf -inputmode] eq "raw"} { + #user or script has apparently put stdin into raw mode - update punk::console::is_raw to match + set rawmode 1 + set ::punk::console::is_raw 1 + } else { + set ::punk::console::is_raw 0 + } + #what about enable/disable virtualTerminal ? + #using stdin -inputmode to switch modes won't set virtualterminal input state appropriately + #we expect the state of -inputmode to be 'normal' even though we flip it during the read part of our repl loop + #if it's been set to raw - assume it is deliberately done this way as the user could have alternatively called punk::mode raw or punk::console::enableVirtualTerminal + #by not doing this automatically - we assume the caller has a reason. + } else { + set rawmode [set ::punk::console::is_raw] + } + + if {!$rawmode} { + #stdin with line-mode readable events (at least on windows for Tcl 8.7a6 to 9.0a) can get stuck with bytes pending when input longer than 100chars - even though there is a linefeed further on than that. + #This potentially affects a reasonable number of Tcl8.7 kit/tclsh binaries out in the wild. + #see bug https://core.tcl-lang.org/tcl/tktview/bda99f2393 (gets stdin problem when non-blocking - Windows) + #when in non-blocking mode we will have to read that in to get further - but we don't know if that was the end of line or if there is more - and we may not get a newline even though one was present originally on stdin. + #presence of 8.7 buffering bug will result in unrecoverable situation - even switching to raw and using read will not be able to retrieve tail data. + #the readable event only gives us 200 bytes (same problem may be at 4k/8k in other versions) + #This occurs whether we use gets or read - + set stdinlines [list] + set linemax 5 ;#not an absolute.. + set lc 0 + if {[dict get $original_input_conf -blocking] ne "0"} { + chan configure $inputchan -blocking 0 + } + + set waitingchunk "" + #review - input_chunks_waiting in line mode - + if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { + #puts stderr "repl_handler input_chunks_waiting($inputchan) while in line mode. Had data:[ansistring VIEW -lf 1 $input_chunks_waiting($inputchan)]" + set allwaiting [join $input_chunks_waiting($inputchan) ""] + set input_chunks_waiting($inputchan) [list] + set yellow [punk::ansi::a+ yellow bold] + set waitinglines [split $allwaiting \n] + foreach ln [lrange $waitinglines 0 end-1] { + lappend stdinlines $ln + incr lc + } + set waitingchunk [lindex $waitinglines end] + # -- + #set chunksize [gets $inputchan chunk] + set chunk [read $inputchan] + set chunksize [string length $chunk] + # -- + if {$chunksize > 0} { + if {[string index $chunk end] eq "\n"} { + lappend stdinlines $waitingchunk[string range $chunk 0 end-1] + punk::console::cursorsave_move_emitblock_return 30 30 "repl_handler num_stdinlines [llength $stdinlines] chunk:$yellow[ansistring VIEW -lf 1 $chunk][a] fblocked:[fblocked $inputchan] pending:[chan pending input stdin]" + + if {![chan eof $inputchan]} { + repl_handler_restorechannel $inputchan $original_input_conf + } + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + } else { + set input_chunks_waiting($inputchan) [list $allwaiting] + lappend input_chunks_waiting($inputchan) $chunk + } + } else { + if {[fblocked $inputchan]} { + #set screeninfo [punk::console::get_size] + #lassign $screeninfo _c cols _r rows + set rows 0 + set cols 3 + if {[string is integer -strict $rows]} { + set RED [punk::ansi::a+ red bold]; set RST [punk::ansi::a] + set msg "${RED}line-length Tcl windows channel bug? Hit enter to continue$RST" + set msglen [ansistring length $msg] + punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg + } + after 100 + } + set input_chunks_waiting($inputchan) [list $allwaiting] + } + + } else { + repl_handler_checkchannel $inputchan + # -- --- --- + #set chunksize [gets $inputchan chunk] + # -- --- --- + set chunk [read $inputchan] + set chunksize [string length $chunk] + # -- --- --- + if {$chunksize > 0} { + punk::console::cursorsave_move_emitblock_return 35 120 "chunk: [ansistring VIEW -lf 1 "...[string range $chunk end-10 end]"]" + set ln $chunk ;#temp + punk::console::cursorsave_move_emitblock_return 25 30 [textblock::frame -title line "[a+ green]$waitingchunk[a][a+ red][ansistring VIEW -lf 1 $ln][a+ green]pending:[chan pending input stdin][a]"] + if {[string index $ln end] eq "\n"} { + lappend stdinlines [string range $ln 0 end-1] + incr lc + if {![chan eof $inputchan]} { + repl_handler_restorechannel $inputchan $original_input_conf + } + uplevel #0 [list repl::repl_process_data $inputchan line "" $stdinlines $prompt_config] + } else { + lappend input_chunks_waiting($inputchan) $ln + } + } + } + + } else { + if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { + #we could concat and process as if one chunk - but for now at least - we want to preserve the 'chunkiness' + set wchunks $input_chunks_waiting($inputchan) + set ch [lindex $wchunks 0] + set input_chunks_waiting($inputchan) [lrange $wchunks 1 end] + + uplevel #0 [list repl::repl_process_data $inputchan raw-waiting $ch [list] $prompt_config] + + } else { + repl_handler_checkchannel $inputchan + if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { + chan configure $inputchan -blocking 0 + chan configure $inputchan -translation lf + } + set chunk [read $inputchan] + + if {![chan eof $inputchan]} { + repl_handler_restorechannel $inputchan $original_input_conf + } + uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] + } + } + + + + if {![chan eof $inputchan]} { + + ################################################################################## + #Re-enable channel read handler only if no waiting chunks - must process in order + ################################################################################## + if {![llength $input_chunks_waiting($inputchan)]} { + fileevent $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] + } else { + after idle [list ::repl::repl_handler $inputchan $prompt_config] } + #################################################### + } else { + catch {rputs stderr "repl_handler EOF $inputchannel:[chan conf $inputchan]"} } + set in_repl_handler [list] +} +proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} { + variable loopinstance + variable loopcomplete + incr loopinstance + - if {[catch { + try { variable prompt_reset_flag #catch {puts stderr "xx--->[rep $::arglej]"} if {$prompt_reset_flag == 1} { @@ -1022,7 +1586,13 @@ proc repl::repl_handler {inputchan prompt_config} { variable last_repl_char "" ;#last char emitted by this handler to stdout/stderr variable lastoutchar "" variable lasterrchar "" + variable cursorcolumn "" variable commandstr + # --- + variable editbuf + variable editbuf_list + variable editbuf_lineindex_submitted + # --- variable readingchunk variable running variable reading @@ -1032,77 +1602,45 @@ proc repl::repl_handler {inputchan prompt_config} { upvar ::punk::config::running running_config - if 0 { - set chunksize [gets $inputchan line] - if {$chunksize < 0} { - if {[chan eof $inputchan]} { - fileevent $inputchan readable {} - set reading 0 - set running 0 - if {$::tcl_interactive} { - rputs stderr "\n|repl> EOF on $inputchan." - } - set [namespace current]::done 1 - #test - #JMN - #tailcall repl::reopen_stdin - } - } - } - set resultprompt [dict get $prompt_config resultprompt] set nlprompt [dict get $prompt_config nlprompt] set infoprompt [dict get $prompt_config infoprompt] set debugprompt [dict get $prompt_config debugprompt] + #JMN #fileevent $inputchan readable {} + #According to DKF - -buffering option doesn't affect input channels + if {$cursorcolumn eq ""} { + set cursorcolumn 1 + } - set stdinlines [list] - chan configure stdin -blocking 0 - set linemax 40 + # -- --- --- + #for raw mode + set chunkreadsize 1024 + set maxreads 4 + set linemax 40 ;#max number of lines received for us to read another chunk in same loop - *not a limit on number of lines in a round* + #Note - we could read for example 1024 lines if they fit in our chunk read size - and we'll have to process them all, but if 1024 > $linemax we won't read more available data in this round. + # -- --- --- - #note -inputmode not available in Tcl 8.6! - set rawmode 0 - if {[dict exists [chan configure stdin] -inputmode]} { - if {[chan configure stdin -inputmode] eq "raw"} { - set rawmode 1 - } - } else { - set rawmode [set ::punk::console::is_raw] - } + set rawmode [set ::punk::console::is_raw] if {!$rawmode} { - set lc 0 - while {[set chunksize [gets $inputchan ln]] >= 0 && $lc < $linemax} { - lappend stdinlines $ln - incr lc - } - if {$chunksize < 0 && [chan eof $inputchan]} { - fileevent $inputchan readable {} - set reading 0 - set running 0 - if {$::tcl_interactive} { - rputs stderr "\n|repl> EOF on $inputchan." - } - set [namespace current]::done 1 - #test - #JMN - #tailcall repl::reopen_stdin - } + #puts stderr "-->got [ansistring VIEW -lf 1 $stdinlines]<--" + } else { #raw - chan conf stdin -translation lf - #rputs stderr "-->chan conf stdin: [chan conf stdin]<--" - set lc 0 - set maxreads 4 set numreads 0 - while {[string length [set chunk [read $inputchan 1024]]] >= 0 && $lc < $linemax & $numreads < $maxreads} { + set lc 0 + set onetime 1 + while {$onetime && [string length $chunk] >= 0 } { + set onetime 0 set chunklen [string length $chunk] + #punk::console::move_emitblock_return 20 120 $chunklen-->[chan conf stdin]<-- if {$chunklen > 0} { set info1 "read $chunklen bytes->[ansistring VIEW -lf 1 -vt 1 $chunk]" #it's strange - but apparently terminals use a lone cr to represent enter @@ -1127,6 +1665,10 @@ proc repl::repl_handler {inputchan prompt_config} { #could be a sequence of cr's from holding enter key } + #review - we can receive chars such as escapes or arrow inline with other data even from keyboard if keys are pushed quickly (or automated?) + # - so we probably shouldn't really rely on whether a char arrives alone in a chunk as a factor in its behaviour + #On the other hand - timing of keystrokes could be legitimate indications of intention in a cli ? + #esc or ctrl-lb if {$chunk eq "\x1b"} { #return @@ -1135,19 +1677,16 @@ proc repl::repl_handler {inputchan prompt_config} { set commandstr "" set chunk "" screen_last_char_add \x1b stdin escape - break - } - if {$chunk eq "\x1b\[D"} { - rputs stderr "${debugprompt}arrow-left D" - #set commandstr "" - #punk::console::move_back 1 + break } + #if ProcessedInput is disabled - we can get ctrl-c + #e.g with punk::console::disableProcessedInput #if we get just ctrl-c in one chunk #ctrl-c if {$chunk eq "\x03"} { #::repl::term::handler_console_control "ctrl-c_via_rawloop" - return + error "character 03 -> ctrl-c" } #for now - exit with small delay for tidyup #ctrl-z @@ -1162,22 +1701,105 @@ proc repl::repl_handler {inputchan prompt_config} { #try to brutally terminate process #attempt to leave terminal in a reasonable state punk::mode line - after 200 - exit 42 + after 200 {exit 42} } - append readingchunk $chunk - #rputs stderr "$info1 readingchunk [string length $readingchunk] bytes ->[ansistring VIEW -lf 1 -vt 1 $readingchunk]" - punk::console::rhs_prompt 80 "$info1 readingchunk [string length $readingchunk] bytes ->[ansistring VIEW -lf 1 -vt 1 -bs 1 $readingchunk]" - puts -nonewline $chunk + if {$chunk eq "\x1b\[D"} { + #move cursor record within our buffer + #rputs stderr "${debugprompt}arrow-left D" + #set commandstr "" + #punk::console::move_back 1 ;#terminal does it anyway? + } + + $editbuf add_chunk $chunk + + #-------------------------- + if {[set ::punk::console::ansi_available]} { + package require textblock + if {$::punk::repl::debug_repl > 0} { + set lastc [string index $chunk end] + set lastc [ansistring VIEW -lf 1 -vt 1 $lastc] + if {[string length $lastc]} { + #set info [textblock::frame [textblock::block 10 10 $lastc]] + } + if {[catch { + set info [$editbuf debugview_raw] + if {$type eq "raw-waiting"} { + set info [a+ bold yellow]$info[a] + } else { + set info [a+ green]$info[a] + } + set lines [lines_as_list -ansiresets 1 $info] + if {[llength $lines] > 20} { + set lines [lrange $lines end-19 end] + set info [list_as_lines $lines] + } + } errM]} { + set info [textblock::frame -title [a red]error[a] $errM] + } else { + set info [textblock::frame -ansiborder [a+ green bold] -title "[a cyan]debugview_raw[a]" $info] + } + set w [textblock::width $info] + set spacepatch [textblock::block $w 2 " "] + puts -nonewline [punk::ansi::cursor_off] + #use non cursorsave versions as test + punk::console::move_emitblock_return 8 120 $spacepatch + punk::console::move_emitblock_return 10 120 $info + puts -nonewline [punk::ansi::cursor_on] + } + if {[catch { + set info [$editbuf view_lines] + set lines [lines_as_list -ansiresets 1 $info] + if {[llength $lines] > 20} { + set lines [lrange $lines end-19 end] + set info [list_as_lines $lines] + } + }]} { + set info [textblock::frame -title [a red]error[a] $errM] + } else { + set title "[a cyan]editbuf lines [$editbuf linecount][a]" + append title "[a+ yellow bold] col:[$editbuf cursor_column] row:[$editbuf cursor_row][a]" + set row1 " lastchar:[ansistring VIEW -lf 1 [$editbuf last_char]] lastgrapheme:[ansistring VIEW -lf 1 [$editbuf last_grapheme]]" + set row2 " lastansi:[ansistring VIEW -lf 1 [$editbuf last_ansi]]" + set info [a+ green bold]$row1\n$row2[a]\n$info + set info [textblock::frame -ansiborder [a+ green bold] -title $title $info] + } + set w [textblock::width $info] + set spacepatch [textblock::block $w 2 " "] + punk::console::cursorsave_move_emitblock_return 8 40 $spacepatch + punk::console::cursorsave_move_emitblock_return 10 40 $info + } + + + set lines_unsubmitted [expr {[$editbuf linecount] - $editbuf_lineindex_submitted + 1}] + #there is always one 'line' unsubmitted - although it may be the current one being built, which may be empty string + if {$lines_unsubmitted < 1} { + puts stderr "repl editbuf_lineindex_submitted out of sync with editbuf" + } + + set activeline_index [expr {[$editbuf linecount] -1}] + set nextsubmit_index [expr {$editbuf_lineindex_submitted + 1}] + if {$editbuf_lineindex_submitted == -1} { + if {[$editbuf last_char] eq "\n"} { + lappend stdinlines [$editbuf line 0] + incr lc + set editbuf_lineindex_submitted 0 + } + } else { + if {$nextsubmit_index < $activeline_index} { + foreach ln [$editbuf lines $nextsubmit_index end-1] { + lappend stdinlines $ln + incr lc + incr editbuf_lineindex_submitted + } + } + } + puts -nonewline stdout $chunk flush stdout - - while {[set lep [string first \n $readingchunk]] >=0} { - set ln [string range $readingchunk 0 $lep-1] - lappend stdinlines $ln - set readingchunk [string range $readingchunk $lep+1 end] - incr lc + if {[string index $chunk end] eq "\n"} { + screen_last_char_add "\n" input inputline } + } else { #rputs stderr "->0byte read stdin" if {[chan eof $inputchan]} { @@ -1192,20 +1814,17 @@ proc repl::repl_handler {inputchan prompt_config} { #JMN #tailcall repl::reopen_stdin } - break + #break } - incr numreads } - } - set xinfo [chan pending input stdin] - set maxlinenum [expr {[llength $stdinlines] -1}] set linenum 0 foreach line $stdinlines { + #puts stderr "----->line: [ansistring VIEW -lf 1 $line] commandstr:[ansistring VIEW -lf 1 $commandstr]" set last_repl_char "" ;#last char emitted by this handler to stdout/stderr set lastoutchar "" set lasterrchar "" @@ -1222,6 +1841,7 @@ proc repl::repl_handler {inputchan prompt_config} { #abort current command if {$linenum == 0} { doprompt "E% " {yellow bold} + set line "" #screen_last_char_add " " empty empty } else { doprompt "\nE% " {yellow bold} @@ -1255,7 +1875,7 @@ proc repl::repl_handler {inputchan prompt_config} { append commandstr \n } - set stdinconf [fconfigure stdin] + set stdinconf [fconfigure $inputchan] if {$::tcl_platform(platform) eq "windows" && [dict get $stdinconf -encoding] ni [list unicode utf-16]} { #some long console inputs are split weirdly when -encoding and -translation are left at defaults - requiring extra enter-key to get repl to process. #experiment to see if using binary and handling line endings manually gives insight. @@ -1268,7 +1888,7 @@ proc repl::repl_handler {inputchan prompt_config} { # it breaks copy-paste (encoding issue?) - #puts "--stdin> [fconfigure stdin]" + #puts "--inputchan:$inputchan> [fconfigure $inputchan]" append commandstr $line puts "1=============>[string length $commandstr] bytes , [ansistring VIEW $commandstr] , info complete:[info complete $line]" @@ -1291,7 +1911,7 @@ proc repl::repl_handler {inputchan prompt_config} { #append commandstr \n - if {[info complete $commandstr]} { + if {[info complete $commandstr] && [string index $commandstr end] ne "\\"} { #set commandstr [overtype::renderline -overflow 1 "" $commandstr] @@ -1305,14 +1925,18 @@ proc repl::repl_handler {inputchan prompt_config} { set wordparts [regexp -inline -all {\S+} $commandstr] lassign $wordparts cmd_firstword cmd_secondword if {$cmd_firstword eq "debugrepl"} { - if {[string is integer -strict $cmd_secondword]} { - incr ::punk::repl::debug_repl $cmd_secondword + if {$cmd_secondword in [list 0 cancel]} { + set ::punk::repl::debug_repl 0 } else { - incr ::punk::repl::debug_repl + if {[string is integer -strict $cmd_secondword]} { + incr ::punk::repl::debug_repl $cmd_secondword + } else { + incr ::punk::repl::debug_repl + } } set commandstr "set ::punk::repl::debug_repl" } - if {$::punk::repl::debug_repl > 0} { + if {$::punk::repl::debug_repl > 100} { proc debug_repl_emit {msg} [string map [list %p% [list $debugprompt]] { set p %p% #don't auto-append \n even if missing. @@ -1327,10 +1951,11 @@ proc repl::repl_handler {inputchan prompt_config} { } else { set clearance "" } - rputs stderr $clearance$p[string map [list \n \n$p] $msg] + #use pseudo-channel debugreport + rputs debugreport $clearance$p[string map [list \n \n$p] $msg] }] set info "" - append info "repl loopinstance: $loopinstance\n" + append info "repl loopinstance: $loopinstance debugrepl remaining: [expr {[set ::punk::repl::debug_repl]-1}]\n" append info "commandstr: [punk::ansi::ansistring::VIEW $commandstr]\n" append info "last_run_info\n" append info "length: [llength $::punk::last_run_display]\n" @@ -1381,7 +2006,7 @@ proc repl::repl_handler {inputchan prompt_config} { #pass unevaluated command to runraw set status [catch {uplevel #0 [list runraw $commandstr]} raw_result] } else { - #puts stderr "repl uplevel 0 '$command'" + #puts stderr "repl uplevel 0 '$run_command_string'" set status [catch { #uplevel 1 $run_command_string #uplevel 1 {namespace eval $punk::ns::ns_current $run_command_string} @@ -1402,10 +2027,14 @@ proc repl::repl_handler {inputchan prompt_config} { } } raw_result] } + #puts stderr "repl raw_result: $raw_result" #set result $raw_result #append result ""; #copy on write #copy on write - append result $raw_result "" + + #append result $raw_result "" + set result [string cat $raw_result ""] + #puts stderr "-->>$result<--" #=============================================================================== flush stdout flush stderr @@ -1461,19 +2090,29 @@ proc repl::repl_handler {inputchan prompt_config} { #ok to use repl::screen_needs_clearance from here down.. (code smell proc only valid use in narrow context) #*********************************************************** #rputs -nonewline stderr $unknown_clearance - set lastcharinfo "\n" - set whatcol [string repeat " " 12] - foreach cinfo $::repl::screen_last_char_list { - lassign $cinfo c whatinfo whyinfo - set cdisplay [string map [list \r "-r-" \n "-n-"] $c] - if {[string length $cdisplay] == 1} { - set cdisplay "$cdisplay " ;#make 3 wide to match -n- and -r- + if {$::punk::repl::debug_repl > 0} { + set lastcharinfo "\n" + set whatcol [string repeat " " 12] + foreach cinfo $::repl::screen_last_char_list { + lassign $cinfo c whatinfo whyinfo + set cdisplay [punk::ansi::ansistring::VIEW -lf 1 -vt 1 $c] + #assert cdisplay has no raw newlines + if {[punk::char::ansifreestring_width $cdisplay] == 1} { + set cdisplay "$cdisplay " ;#make 2 wide + } + if {[string match repl-debugreport* $whatinfo]} { + #exclude noise debug_repl_emit - but still show the last_char + set whysummary "" + } else { + #set whysummary [string map [list \n "-n-"] $whyinfo] + set whysummary [punk::ansi::ansistring::VIEW -lf 1 -vt 1 $whyinfo] + } + set whatinfo [string range $whatinfo$whatcol 0 [string length $whatcol]] + append lastcharinfo "$cdisplay $whatinfo $whysummary\n" } - set whatinfo [string range $whatinfo$whatcol 0 [string length $whatcol]] - set whysummary [string map [list \n "-n-"] $whyinfo] - append lastcharinfo "$cdisplay $whatinfo $whysummary\n" + debug_repl_emit "screen_last_chars: $lastcharinfo" } - debug_repl_emit "screen_last_chars: $lastcharinfo" + debug_repl_emit "lastoutchar:'$lastoutchar' lasterrchar: '$lasterrchar'" if {$status == 0} { debug_repl_emit "command call status: $status OK" @@ -1548,7 +2187,12 @@ proc repl::repl_handler {inputchan prompt_config} { lassign $c termchan text if {[string length $text]} { if {$termchan eq "result"} { - rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] + #rputs stdout $resultprompt[string map [list \n "\n$resultprompt"] $text] + set h [textblock::height $text] + set promptcol [string repeat $resultprompt\n $h] + set promptcol [string range $promptcol 0 end-1] + rputs [textblock::join -- $promptcol $text] + #puts -nonewline stdout $text } elseif {$termchan eq "resulterr"} { rputs stderr $resultprompt[string map [list \n "\n$resultprompt"] $text] @@ -1592,7 +2236,14 @@ proc repl::repl_handler {inputchan prompt_config} { set result [string range $result 0 end-1] } } - rputs $resultprompt[string map [list \r\n "\n$resultprompt" \n "\n$resultprompt"] $result] + #NOTE - textblock::height is the line height - not reflective of height of data with ansi-moves or things like sixels + set h [textblock::height $result] + set promptcol [string repeat $resultprompt\n $h] + set promptcol [string range $promptcol 0 end-1] + rputs [textblock::join -- $promptcol $result] + + #orig + #rputs $resultprompt[string map [list \r\n "\n$resultprompt" \n "\n$resultprompt"] $result] } } doprompt "P% " @@ -1625,11 +2276,9 @@ proc repl::repl_handler {inputchan prompt_config} { } else { #doprompt "P% " "green nobold" if {$linenum == 0} { - #doprompt "$loopinstance,$linenum-$xinfo " "green nobold" doprompt "P% " "green nobold" screen_last_char_add " " empty empty } else { - #doprompt "\n$loopinstance,$linenum-$xinfo " "green nobold" doprompt "\nP% " "green nobold" screen_last_char_add "\n" empty empty ;#add \n to indicate noclearance required } @@ -1641,6 +2290,10 @@ proc repl::repl_handler {inputchan prompt_config} { } set commandstr "" #catch {puts stderr "zz2---->[rep $::arglej]"} + + + #editbuf + } else { #append commandstr \n if {$::repl::signal_control_c} { @@ -1672,7 +2325,8 @@ proc repl::repl_handler {inputchan prompt_config} { if {[llength $waiting]} { set c [lindex $waiting end] } else { - set c " " + #set c " " + set c \u240a } doprompt ">$c " } @@ -1686,35 +2340,38 @@ proc repl::repl_handler {inputchan prompt_config} { if {$maxlinenum == -1} { #when in raw mode - no linefeed yet received #rputs stderr "repl: no complete input line: $commandstr" - #doprompt "$loopinstance-$xinfo " #screen_last_char_add "\n" empty empty screen_last_char_add [string index $readingchunk end] stdinchunk stdinchunk } - fileevent $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] + #fileevent $inputchan readable [list repl::repl_handler $inputchan $prompt_config] #catch {puts stderr "zend--->[rep $::arglej]"} - #flush stdout - #update idletasks - - - } repl_error]} { - puts stderr "error in repl_handler: $repl_error" - puts stderr "-------------" - puts stderr "$::errorInfo" - puts stderr "-------------" + } trap {POSIX} {e eopts} { + rputs stderr "trap POSIX '$e' eopts:'$eopts" + flush stderr + } on error {repl_error erropts} { + rputs stderr "error in repl_handler: $repl_error" + rputs stderr "-------------" + rputs stderr "$::errorInfo" + rputs stderr "-------------" set stdinreader [fileevent $inputchan readable] if {![string length $stdinreader]} { - puts stderr "*> stdin reader inactive" + rputs stderr "*> $inputchan reader inactive" } else { - puts stderr "*> stdin reader active" + rputs stderr "*> $inputchan reader active" + } + if {[chan eof $inputchan]} { + rputs stderr "will attempt restart of repl on input channel: $inputchan in next loop" + catch {set ::punk::ns::ns_current "::"} + } else { + rputs stderr "continuing.." } - puts stderr "Attempting restart of repl on input channel: $inputchan" - catch {set ::punk::ns::ns_current "::"} - tailcall repl::start $inputchan + flush stderr + #tailcall repl::start $inputchan } } diff --git a/src/modules/punkapp-0.1.tm b/src/modules/punkapp-0.1.tm index baf01254..4db2a3ef 100644 --- a/src/modules/punkapp-0.1.tm +++ b/src/modules/punkapp-0.1.tm @@ -203,7 +203,8 @@ namespace eval punkapp { set pinfo [twapi::get_process_info $pid -name] set pname [dict get $pinfo -name] set wstyle [twapi::get_window_style $h] - if {$pname in [list cmd.exe pwsh.exe powershell.exe] && "popup" ni $wstyle} { + #tclkitsh/tclsh? + if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { twapi::hide_window $h return 1 } else { diff --git a/src/modules/shellrun-0.1.1.tm b/src/modules/shellrun-0.1.1.tm index 18a40201..ac895e84 100644 --- a/src/modules/shellrun-0.1.1.tm +++ b/src/modules/shellrun-0.1.1.tm @@ -184,6 +184,7 @@ namespace eval shellrun { variable runerr set runout "" set runerr "" + set RST [a] set splitargs [get_run_opts $args] set runopts [dict get $splitargs runopts] @@ -245,7 +246,7 @@ namespace eval shellrun { set chunklist [list] #exitcode not part of return value for runout - colourcode appropriately - set n [a] + set n $RST set c "" if [dict exists $exitinfo exitcode] { set code [dict get $exitinfo exitcode] @@ -268,7 +269,7 @@ namespace eval shellrun { } - set chunk "[a+ red bold]stderr[a]" + set chunk "[a+ red bold]stderr$RST" lappend chunklist [list "info" $chunk] set chunk "" @@ -278,15 +279,15 @@ namespace eval shellrun { } else { set e $::shellrun::runerr } - #append chunk "[a+ red light]$e[a]\n" - append chunk "[a+ red light]$e[a]" + #append chunk "[a+ red light]$e$RST\n" + append chunk "[a+ red light]$e$RST" } lappend chunklist [list stderr $chunk] - lappend chunklist [list "info" "[a+ white bold]stdout[a]"] + lappend chunklist [list "info" "[a+ white bold]stdout$RST"] set chunk "" if {[string length $::shellrun::runout]} { if {$nonewline} { diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 9ee31e3f..80a50cf6 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -82,9 +82,9 @@ namespace eval textblock { set textblock [textutil::tabify::untabify2 $textblock] if {[string first \n $textblock] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::string_width [stripansi $v]}]] + return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width [stripansi $v]}]] } - return [punk::char::string_width [stripansi $textblock]] + return [punk::char::ansifreestring_width [stripansi $textblock]] } proc width_naive {textblock} { # doesn't deal with backspaces, vertical tabs,carriage returns, ansi movements @@ -119,9 +119,9 @@ namespace eval 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}]] + set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] } else { - set width [punk::char::string_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } set num_le [expr {[string length $textblock]-[string length [string map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -206,8 +206,9 @@ namespace eval textblock { >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| >} punk::lib::list_as_lines -- } .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| >} punk::lib::list_as_lines punk . rhs] + set pright [>punk . lhs] + set prightair [>punk . lhs_air] + set red [a+ red]; set redb [a+ red bold] + set green [a+ green]; set greenb [a+ green bold] + set cyan [a+ cyan];set cyanb [a+ cyan bold] + set blue [a+ blue];set blueb [a+ blue bold] + set RST [a] + set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] + set punks [textblock::join $pleft $pright] + set pleft_greenb $greenb$pleft$RST + set pright_redb $redb$pright$RST + set prightair_cyanb $cyanb$prightair$RST + set cpunks [textblock::join $pleft_greenb $pright_redb] + set out "" + append out $punks \n + append out $cpunks \n + append out [textblock::join $punks $cpunks] \n + set 2frames_a [textblock::join [textblock::frame $cpunks] [textblock::frame $punks]] + append out $2frames_a \n + set 2frames_b [textblock::join [textblock::frame -ansiborder $cyanb -title "plainpunks" $punks] [textblock::frame -ansiborder $greenb -title "fancypunks" $cpunks]] + append out [textblock::frame -title "punks" $2frames_b\n$RST$2frames_a] \n + append out [overtype::right [overtype::left [textblock::frame -ansiborder [a+ green bold] -type unicode_box_heavy -title ${redb}PATTERN$RST -subtitle ${redb}PUNK$RST $prightair_cyanb] "$blueb\n\n\P\nU\nN\nK$RST"] "$blueb\n\nL\nI\nF\nE"] \n + return $out + } + + proc example3 {{text "test\netc\nmore text"}} { package require patternpunk .= textblock::join [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join " " |> .=>1 textblock::join $text |> .=>1 textblock::join [>punk . rhs] |> .=>1 textblock::join [punk::lib::list_as_lines -- [lrepeat 7 " | "]] } @@ -263,47 +316,270 @@ namespace eval textblock { set contents [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] % 2 != 0} { - error "Usage frame ?-ansi 0|1? " + error "Usage frame ?-type unicode|altg|ascii|? ?-title ? ?-subtitle ? ?-width ? ?-ansiborder ? " } #todo args -justify left|centre|right (center) set defaults [dict create\ - -ansi 0\ + -type unicode_box\ + -title ""\ + -subtitle ""\ + -width ""\ + -ansiborder ""\ + -align "left"\ ] set opts [dict merge $defaults $arglist] + foreach {k v} $opts { + if {$k ni [dict keys $defaults]} { + error "frame option '$k' not understood. Valid options are [dict keys $defaults]" + } + } # -- --- --- --- --- --- - set ansi [dict get $opts -ansi] + set opt_type [dict get $opts -type] + set known_types [list unicode_box unicode_box_heavy unicode_arc unicode_double ascii altg] + set default_custom [dict create hl " " vl " " tlc " " trc " " blc " " brc " "] + set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] + if {$opt_type ni $known_types} { + set is_custom_dict_ok 1 + if {[llength $opt_type] %2 == 0} { + #custom dict may leave out keys - but cannot have unknown keys + dict for {k v} $opt_type { + if {$k ni $custom_keys} { + set is_custom_dict_ok 0 + break + } + } + } else { + set is_custom_dict_ok 0 + } + if {!$is_custom_dict_ok} { + error "frame option -type must be one of known types: $known_types or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + set custom_frame [dict merge $default_custom $opt_type] + } + # -- --- --- --- --- --- + set opt_title [dict get $opts -title] + set opt_subtitle [dict get $opts -subtitle] + set opt_width [dict get $opts -width] + # -- --- --- --- --- --- + set opt_align [dict get $opts -align] + set opt_align [string tolower $opt_align] + if {$opt_align ni [list left right centre center]} { + #these are all valid commands for overtype:: + error "frame option -align must be left|right|centre|center - received: $$opt_align" + } # -- --- --- --- --- --- + set opt_ansiborder [dict get $opts -ansiborder] + # -- --- --- --- --- --- set contents [textutil::tabify::untabify2 $contents] set contents [string map [list \r\n \n] $contents] - if {[string first \n $contents] >= 0} { - set width [width $contents] + + set actual_contentwidth [width $contents] + if {$opt_title ne ""} { + set titlewidth [punk::ansi::printing_length $opt_title] + set content_or_title_width [expr {max($actual_contentwidth,$titlewidth)}] } else { - set width [width [list $contents]] + set titlewith 0 + set content_or_title_width $actual_contentwidth } - set lines [split $contents \n] - if {$ansi} { - #old style ansi escape sequences with alternate graphics page G0 - append fs [cd::tlc][string repeat [cd::hl] $width][cd::trc]\n - foreach l $lines { - append fs [cd::vl]${l}[string repeat " " [expr {$width-[::punk::char::string_width [stripansi $l]]}]][cd::vl]\n - } - append fs [cd::blc][string repeat [cd::hl] $width][cd::brc] - return [cd::groptim $fs] + if {[$opt_width eq ""]} { + set contentwidth $content_or_title_width } else { + set contentwidth [expr {$opt_width -2}] ;#default + } + + #todo - render it with vertical overflow so we can process ansi moves? + set linecount [textblock::height $contents] + set rst [a] + set column [string repeat " " $contentwidth] ;#default - may need to override for custom frame + if {$opt_type eq "altg"} { + #old style ansi escape sequences with alternate graphics page G0 + set hl [cd::hl] + set hlt $hl + set hlb $hl + set vl [cd::vl] + set vll $vl + set vlr $vl + set tlc [cd::tlc] + set trc [cd::trc] + set blc [cd::blc] + set brc [cd::brc] + set tbar [string repeat $hl $contentwidth] + set tbar [cd::groptim $tbar] + set bbar $tbar + } elseif {$opt_type eq "ascii"} { + set hl - + set hlt - + set hlb - + set vl | + set vll | + set vlr | + set tlc + + set trc + + set blc + + set brc + + set tbar [string repeat - $contentwidth] + set bbar $tbar + } elseif {$opt_type eq "unicode_box"} { + #unicode box drawing set + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_lv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ldr] + set trc [punk::char::charshort boxd_ldl] + set blc [punk::char::charshort boxd_lur] + set brc [punk::char::charshort boxd_lul] + set tbar [string repeat $hl $contentwidth] + set bbar $tbar + } elseif {$opt_type eq "unicode_box_heavy"} { + #unicode box drawing set + set hl [punk::char::charshort boxd_hhz] ;# light horizontal + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_hv] ;#light vertical + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_hdr] + set trc [punk::char::charshort boxd_hdl] + set blc [punk::char::charshort boxd_hur] + set brc [punk::char::charshort boxd_hul] + set tbar [string repeat $hl $contentwidth] + set bbar $tbar + } elseif {$opt_type eq "unicode_double"} { #unicode box drawing set - set hz [punk::char::charshort boxd_lhz] ;# light horizontal - append fs [punk::char::charshort boxd_ldr][string repeat $hz $width][punk::char::charshort boxd_ldl]\n + set hl [punk::char::charshort boxd_dhz] ;# double horizontal \U2550 + set hlt $hl + set hlb $hl + set vl [punk::char::charshort boxd_dv] ;#double vertical \U2551 + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ddr] ;#double down and right \U2554 + set trc [punk::char::charshort boxd_ddl] ;#double down and left \U2557 + set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A + set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D + set tbar [string repeat $hl $contentwidth] + set bbar $tbar + } elseif {$opt_type eq "unicode_arc"} { + #unicode box drawing set + set hl [punk::char::charshort boxd_lhz] ;# light horizontal + set hlt $hl + set hlb $hl set vl [punk::char::charshort boxd_lv] ;#light vertical - foreach l $lines { - append fs $vl${l}[string repeat " " [expr {$width-[::punk::char::string_width [stripansi $l]]}]]$vl\n + set vll $vl + set vlr $vl + set tlc [punk::char::charshort boxd_ladr] ;#light arc down and right \U256D + set trc [punk::char::charshort boxd_ladl] ;#light arc down and left \U256E + set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 + set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F + set tbar [string repeat $hl $contentwidth] + set bbar $tbar + } else { + dict with custom_frame {} ;#extract keys as vars + if {[dict exists $custom_frame hlt]} { + set hlt [dict get $custom_frame hlt] + } else { + set hlt $hl + } + set hlt_width [punk::ansi::printing_length $hlt] + if {[dict exists $custom_frame hlb]} { + set hlb [dict get $custom_frame hlb] + } else { + set hlb $hl + } + set hlb_width [punk::ansi::printing_length $hlb] + + if {[dict exists $custom_frame vll]} { + set vll [dict get $custom_frame vll] + } else { + set vll $vl + } + set vll_width [punk::ansi::printing_length $vll] + if {[dict exists $custom_frame vlr]} { + set vlr [dict get $custom_frame vlr] + } else { + set vlr $vl + } + set vlr_width [punk::ansi::printing_length $vlr] + + set tlc_width [punk::ansi::printing_length $tlc] + set trc_width [punk::ansi::printing_length $trc] + set blc_width [punk::ansi::printing_length $blc] + set brc_width [punk::ansi::printing_length $brc] + + + set framewidth [expr {$contentwidth + 2}] ;#reverse default assumption + if {$opt_width eq ""} { + #width wasn't specified - so user is expecting frame to adapt to title/contents + #content shouldn't truncate because of extra wide frame + set contentwidth $content_or_title_width + set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width + set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] + } else { + set contentwidth [expr $opt_width - $vll_width - $vlr_width] ;#content may be truncated + set tbarwidth [expr {$opt_width - $tlc_width - $trc_width}] + set bbarwidth [expr {$opt_width - $blc_width - $brc_width}] + } + set column [string repeat " " $contentwidth] + + if {$hlt_width == 1} { + set tbar [string repeat $hlt $tbarwidth] + } else { + #possibly mixed width chars that make up hlt - string range won't get width right + set blank [string repeat " " $tbarwidth] + set count [expr {($tbarwidth / $hlt_width) + 1}] + set tbar [string repeat $hlt $count] + #set tbar [string range $tbar 0 $tbarwidth-1] + set tbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $tbar];#spaces for exposed halves of 2w chars instead of default replacement character } - append fs [punk::char::charshort boxd_lur][string repeat $hz $width][punk::char::charshort boxd_lul] - return $fs + if {$hlb_width == 1} { + set bbar [string repeat $hlb $bbarwidth] + } else { + set blank [string repeat " " $bbarwidth] + set count [expr {($bbarwidth / $hlb_width) + 1}] + set bbar [string repeat $hlb $count] + #set bbar [string range $bbar 0 $bbarwidth-1] + set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] + } + } + #keep lhs/rhs separate? can we do vertical text on sidebars? + set lhs [string repeat $vll\n $linecount] + set lhs [string range $lhs 0 end-1] + set rhs [string repeat $vlr\n $linecount] + set rhs [string range $rhs 0 end-1] + if {$opt_ansiborder ne ""} { + set tbar $opt_ansiborder$tbar$rst + set bbar $opt_ansiborder$bbar$rst + set tlc $opt_ansiborder$tlc$rst + set trc $opt_ansiborder$trc$rst + set blc $opt_ansiborder$blc$rst + set brc $opt_ansiborder$brc$rst + set lhs $opt_ansiborder$lhs$rst ;#wrap the whole block and let textblock::join figure it out + set rhs $opt_ansiborder$rhs$rst } + if {$opt_title ne ""} { + set topbar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $tbar $opt_title] ;#overtype supports gx0 on/off + } else { + set topbar $tbar + } + if {$opt_subtitle ne ""} { + set bottombar [overtype::centre -overflow 0 -exposed1 " " -exposed2 " " -ellipsis 1 -bias left $bbar $opt_subtitle] ;#overtype supports gx0 on/off + } else { + set bottombar $bbar + } + append fs $tlc$topbar$trc\n + set inner [overtype::$opt_align -ellipsis 1 $column $contents] + set body [textblock::join -- $lhs $inner $rhs] + append fs $body + append fs \n $blc$bottombar$brc + + return $fs + } proc gcross {{size 1} args} { if {$size == 0} { @@ -395,7 +671,8 @@ namespace eval textblock { set b2 [a= green]a\nb\nc[a=] set result [textblock::join $b1 $b2] puts $result - return [list $b1 $b2 $result] + #return [list $b1 $b2 $result] + return [ansistring VIEW $result] } namespace import ::punk::ansi::stripansi } @@ -404,7 +681,7 @@ namespace eval textblock { namespace eval ::textblock::piper { namespace export * proc join {rhs pipelinedata} { - tailcall ::textblock::join $pipelinedata $rhs + tailcall ::textblock::join -- $pipelinedata $rhs } } interp alias {} piper_blockjoin {} ::textblock::piper::join diff --git a/src/vendorlib/base64/ascii85.tcl b/src/vendorlib/base64/ascii85.tcl new file mode 100644 index 00000000..e05e3430 --- /dev/null +++ b/src/vendorlib/base64/ascii85.tcl @@ -0,0 +1,271 @@ +# ascii85.tcl -- +# +# Encode/Decode ascii85 for a string +# +# Copyright (c) Emiliano Gavilan +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.4 + +namespace eval ascii85 { + namespace export encode encodefile decode + # default values for encode options + variable options + array set options [list -wrapchar \n -maxlen 76] +} + +# ::ascii85::encode -- +# +# Ascii85 encode a given string. +# +# Arguments: +# args ?-maxlen maxlen? ?-wrapchar wrapchar? string +# +# If maxlen is 0, the output is not wrapped. +# +# Results: +# A Ascii85 encoded version of $string, wrapped at $maxlen characters +# by $wrapchar. + +proc ascii85::encode {args} { + variable options + + set alen [llength $args] + if {$alen != 1 && $alen != 3 && $alen != 5} { + return -code error "wrong # args:\ + should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen?\ + ?-wrapchar wrapchar? string\"" + } + + set data [lindex $args end] + array set opts [array get options] + array set opts [lrange $args 0 end-1] + foreach key [array names opts] { + if {[lsearch -exact [array names options] $key] == -1} { + return -code error "unknown option \"$key\":\ + must be -maxlen or -wrapchar" + } + } + + if {![string is integer -strict $opts(-maxlen)] + || $opts(-maxlen) < 0} { + return -code error "expected positive integer but got\ + \"$opts(-maxlen)\"" + } + + # perform this check early + if {[string length $data] == 0} { + return "" + } + + # shorten the names + set ml $opts(-maxlen) + set wc $opts(-wrapchar) + + # if maxlen is zero, don't wrap the output + if {$ml == 0} { + set wc "" + } + + set encoded {} + + binary scan $data c* X + set len [llength $X] + set rest [expr {$len % 4}] + set lastidx [expr {$len - $rest - 1}] + + foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] { + # calculate the 32 bit value + # this is an inlined version of the [encode4bytes] proc + # included here for performance reasons + set val [expr { + ( (($b1 & 0xff) << 24) + |(($b2 & 0xff) << 16) + |(($b3 & 0xff) << 8) + | ($b4 & 0xff) + ) & 0xffffffff }] + + if {$val == 0} { + # four \0 bytes encodes as "z" instead of "!!!!!" + append current "z" + } else { + # no magic numbers here. + # 52200625 -> 85 ** 4 + # 614125 -> 85 ** 3 + # 7225 -> 85 ** 2 + append current [binary format ccccc \ + [expr { ( $val / 52200625) + 33 }] \ + [expr { (($val % 52200625) / 614125) + 33 }] \ + [expr { (($val % 614125) / 7225) + 33 }] \ + [expr { (($val % 7225) / 85) + 33 }] \ + [expr { ( $val % 85) + 33 }]] + } + + if {[string length $current] >= $ml} { + append encoded [string range $current 0 [expr {$ml - 1}]] $wc + set current [string range $current $ml end] + } + } + + if { $rest } { + # there are remaining bytes. + # pad with \0 and encode not using the "z" convention. + # finally, add ($rest + 1) chars. + set val 0 + foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break + append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest] + } + append encoded [regsub -all -- ".{$ml}" $current "&$wc"] + + return $encoded +} + +proc ascii85::encode4bytes {b1 b2 b3 b4} { + set val [expr { + ( (($b1 & 0xff) << 24) + |(($b2 & 0xff) << 16) + |(($b3 & 0xff) << 8) + | ($b4 & 0xff) + ) & 0xffffffff }] + return [binary format ccccc \ + [expr { ( $val / 52200625) + 33 }] \ + [expr { (($val % 52200625) / 614125) + 33 }] \ + [expr { (($val % 614125) / 7225) + 33 }] \ + [expr { (($val % 7225) / 85) + 33 }] \ + [expr { ( $val % 85) + 33 }]] +} + +# ::ascii85::encodefile -- +# +# Ascii85 encode the contents of a file using default values +# for maxlen and wrapchar parameters. +# +# Arguments: +# fname The name of the file to encode. +# +# Results: +# An Ascii85 encoded version of the contents of the file. +# This is a convenience command + +proc ascii85::encodefile {fname} { + set fd [open $fname] + fconfigure $fd -encoding binary -translation binary + return [encode [read $fd]][close $fd] +} + +# ::ascii85::decode -- +# +# Ascii85 decode a given string. +# +# Arguments: +# string The string to decode. +# Leading spaces and tabs are removed, along with trailing newlines +# +# Results: +# The decoded value. + +proc ascii85::decode {data} { + # get rid of leading spaces/tabs and trailing newlines + set data [string map [list \n {} \t {} { } {}] $data] + set len [string length $data] + + # perform this ckeck early + if {! $len} { + return "" + } + + set decoded {} + set count 0 + set group [list] + binary scan $data c* X + + foreach char $X { + # we must check that every char is in the allowed range + if {$char < 33 || $char > 117 } { + # "z" is an exception + if {$char == 122} { + if {$count == 0} { + # if a "z" char appears at the beggining of a group, + # it decodes as four null bytes + append decoded \x00\x00\x00\x00 + continue + } else { + # if not, is an error + return -code error \ + "error decoding data: \"z\" char misplaced" + } + } + # char is not in range and not a "z" at the beggining of a group + return -code error \ + "error decoding data: chars outside the allowed range" + } + + lappend group $char + incr count + if {$count == 5} { + # this is an inlined version of the [decode5chars] proc + # included here for performance reasons + set val [expr { + ([lindex $group 0] - 33) * wide(52200625) + + ([lindex $group 1] - 33) * 614125 + + ([lindex $group 2] - 33) * 7225 + + ([lindex $group 3] - 33) * 85 + + ([lindex $group 4] - 33) }] + if {$val > 0xffffffff} { + return -code error "error decoding data: decoded group overflow" + } else { + append decoded [binary format I $val] + incr count -5 + set group [list] + } + } + } + + set len [llength $group] + switch -- $len { + 0 { + # all input has been consumed + # do nothing + } + 1 { + # a single char is a condition error, there should be at least 2 + return -code error \ + "error decoding data: trailing char" + } + default { + # pad with "u"s, decode and add ($len - 1) bytes + append decoded [string range \ + [decode5chars [pad $group 5 122]] \ + 0 \ + [expr {$len - 2}]] + } + } + + return $decoded +} + +proc ascii85::decode5chars {group} { + set val [expr { + ([lindex $group 0] - 33) * wide(52200625) + + ([lindex $group 1] - 33) * 614125 + + ([lindex $group 2] - 33) * 7225 + + ([lindex $group 3] - 33) * 85 + + ([lindex $group 4] - 33) }] + if {$val > 0xffffffff} { + return -code error "error decoding data: decoded group overflow" + } + + return [binary format I $val] +} + +proc ascii85::pad {chars len padchar} { + while {[llength $chars] < $len} { + lappend chars $padchar + } + + return $chars +} + +package provide ascii85 1.0 diff --git a/src/vendorlib/base64/base64.tcl b/src/vendorlib/base64/base64.tcl new file mode 100644 index 00000000..fa52c1c3 --- /dev/null +++ b/src/vendorlib/base64/base64.tcl @@ -0,0 +1,410 @@ +# base64.tcl -- +# +# Encode/Decode base64 for a string +# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems +# The decoder was done for exmh by Chris Garrigues +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# Version 1.0 implemented Base64_Encode, Base64_Decode +# Version 2.0 uses the base64 namespace +# Version 2.1 fixes various decode bugs and adds options to encode +# Version 2.2 is much faster, Tcl8.0 compatible +# Version 2.2.1 bugfixes +# Version 2.2.2 bugfixes +# Version 2.3 bugfixes and extended to support Trf +# Version 2.4.x bugfixes + +# @mdgen EXCLUDE: base64c.tcl + +package require Tcl 8.2 +namespace eval ::base64 { + namespace export encode decode +} + +package provide base64 2.5 + +if {[package vsatisfies [package require Tcl] 8.6]} { + proc ::base64::encode {args} { + binary encode base64 -maxlen 76 {*}$args + } + + proc ::base64::decode {string} { + # Tcllib is strict with respect to end of input, yet lax for + # invalid characters outside of that. + regsub -all -- {[^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/]} $string {} string + binary decode base64 -strict $string + } + + return +} + +if {![catch {package require Trf 2.0}]} { + # Trf is available, so implement the functionality provided here + # in terms of calls to Trf for speed. + + # ::base64::encode -- + # + # Base64 encode a given string. + # + # Arguments: + # args ?-maxlen maxlen? ?-wrapchar wrapchar? string + # + # If maxlen is 0, the output is not wrapped. + # + # Results: + # A Base64 encoded version of $string, wrapped at $maxlen characters + # by $wrapchar. + + proc ::base64::encode {args} { + # Set the default wrapchar and maximum line length to match + # the settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. + set wrapchar "\n" + set maxlen 76 + + if { [llength $args] == 0 } { + error "wrong # args: should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" + } + + set optionStrings [list "-maxlen" "-wrapchar"] + for {set i 0} {$i < [llength $args] - 1} {incr i} { + set arg [lindex $args $i] + set index [lsearch -glob $optionStrings "${arg}*"] + if { $index == -1 } { + error "unknown option \"$arg\": must be -maxlen or -wrapchar" + } + incr i + if { $i >= [llength $args] - 1 } { + error "value for \"$arg\" missing" + } + set val [lindex $args $i] + + # The name of the variable to assign the value to is extracted + # from the list of known options, all of which have an + # associated variable of the same name as the option without + # a leading "-". The [string range] command is used to strip + # of the leading "-" from the name of the option. + # + # FRINK: nocheck + set [string range [lindex $optionStrings $index] 1 end] $val + } + + # [string is] requires Tcl8.2; this works with 8.0 too + if {[catch {expr {$maxlen % 2}}]} { + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive integer but got \"$maxlen\"" + } + + set string [lindex $args end] + set result [::base64 -mode encode -- $string] + + # Trf's encoder implicitly uses the settings -maxlen 76, + # -wrapchar \n for its output. We may have to reflow this for + # the settings chosen by the user. A second difference is that + # Trf closes the output with the wrap char sequence, + # always. The code here doesn't. Therefore 'trimright' is + # needed in the fast cases. + + if {($maxlen == 76) && [string equal $wrapchar \n]} { + # Both maxlen and wrapchar are identical to Trf's + # settings. This is the super-fast case, because nearly + # nothing has to be done. Only thing to do is strip a + # terminating wrapchar. + set result [string trimright $result] + } elseif {$maxlen == 76} { + # wrapchar has to be different here, length is the + # same. We can use 'string map' to transform the wrap + # information. + set result [string map [list \n $wrapchar] \ + [string trimright $result]] + } elseif {$maxlen == 0} { + # Have to reflow the output to no wrapping. Another fast + # case using only 'string map'. 'trimright' is not needed + # here. + + set result [string map [list \n ""] $result] + } else { + # Have to reflow the output from 76 to the chosen maxlen, + # and possibly change the wrap sequence as well. + + # Note: After getting rid of the old wrap sequence we + # extract the relevant segments from the string without + # modifying the string. Modification, i.e. removal of the + # processed part, means 'shifting down characters in + # memory', making the algorithm O(n^2). By avoiding the + # modification we stay in O(n). + + set result [string map [list \n ""] $result] + set l [expr {[string length $result]-$maxlen}] + for {set off 0} {$off < $l} {incr off $maxlen} { + append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar + } + append res [string range $result $off end] + set result $res + } + + return $result + } + + # ::base64::decode -- + # + # Base64 decode a given string. + # + # Arguments: + # string The string to decode. Characters not in the base64 + # alphabet are ignored (e.g., newlines) + # + # Results: + # The decoded value. + + proc ::base64::decode {string} { + regsub -all {\s} $string {} string + ::base64 -mode decode -- $string + } + +} else { + # Without Trf use a pure tcl implementation + + namespace eval base64 { + variable base64 {} + variable base64_en {} + + # We create the auxiliary array base64_tmp, it will be unset later. + variable base64_tmp + variable i + + set i 0 + foreach char {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 \ + 0 1 2 3 4 5 6 7 8 9 + /} { + set base64_tmp($char) $i + lappend base64_en $char + incr i + } + + # + # Create base64 as list: to code for instance C<->3, specify + # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded + # ascii chars get a {}. we later use the fact that lindex on a + # non-existing index returns {}, and that [expr {} < 0] is true + # + + # the last ascii char is 'z' + variable char + variable len + variable val + + scan z %c len + for {set i 0} {$i <= $len} {incr i} { + set char [format %c $i] + set val {} + if {[info exists base64_tmp($char)]} { + set val $base64_tmp($char) + } else { + set val {} + } + lappend base64 $val + } + + # code the character "=" as -1; used to signal end of message + scan = %c i + set base64 [lreplace $base64 $i $i -1] + + # remove unneeded variables + unset base64_tmp i char len val + + namespace export encode decode + } + + # ::base64::encode -- + # + # Base64 encode a given string. + # + # Arguments: + # args ?-maxlen maxlen? ?-wrapchar wrapchar? string + # + # If maxlen is 0, the output is not wrapped. + # + # Results: + # A Base64 encoded version of $string, wrapped at $maxlen characters + # by $wrapchar. + + proc ::base64::encode {args} { + set base64_en $::base64::base64_en + + # Set the default wrapchar and maximum line length to match + # the settings for MIME encoding (RFC 3548, RFC 2045). These + # are the settings used by Trf as well. Various RFCs allow for + # different wrapping characters and wraplengths, so these may + # be overridden by command line options. + set wrapchar "\n" + set maxlen 76 + + if { [llength $args] == 0 } { + error "wrong # args: should be \"[lindex [info level 0] 0]\ + ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" + } + + set optionStrings [list "-maxlen" "-wrapchar"] + for {set i 0} {$i < [llength $args] - 1} {incr i} { + set arg [lindex $args $i] + set index [lsearch -glob $optionStrings "${arg}*"] + if { $index == -1 } { + error "unknown option \"$arg\": must be -maxlen or -wrapchar" + } + incr i + if { $i >= [llength $args] - 1 } { + error "value for \"$arg\" missing" + } + set val [lindex $args $i] + + # The name of the variable to assign the value to is extracted + # from the list of known options, all of which have an + # associated variable of the same name as the option without + # a leading "-". The [string range] command is used to strip + # of the leading "-" from the name of the option. + # + # FRINK: nocheck + set [string range [lindex $optionStrings $index] 1 end] $val + } + + # [string is] requires Tcl8.2; this works with 8.0 too + if {[catch {expr {$maxlen % 2}}]} { + return -code error "expected integer but got \"$maxlen\"" + } elseif {$maxlen < 0} { + return -code error "expected positive integer but got \"$maxlen\"" + } + + set string [lindex $args end] + + set result {} + set state 0 + set length 0 + + + # Process the input bytes 3-by-3 + + binary scan $string c* X + + foreach {x y z} $X { + ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]] + if {$y != {}} { + ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] + if {$z != {}} { + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] + ADD [lindex $base64_en [expr {($z & 0x3F)}]] + } else { + set state 2 + break + } + } else { + set state 1 + break + } + } + if {$state == 1} { + ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]] + ADD = + ADD = + } elseif {$state == 2} { + ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]] + ADD = + } + return $result + } + + proc ::base64::ADD {x} { + # The line length check is always done before appending so + # that we don't get an extra newline if the output is a + # multiple of $maxlen chars long. + + upvar 1 maxlen maxlen length length result result wrapchar wrapchar + if {$maxlen && $length >= $maxlen} { + append result $wrapchar + set length 0 + } + append result $x + incr length + return + } + + # ::base64::decode -- + # + # Base64 decode a given string. + # + # Arguments: + # string The string to decode. Characters not in the base64 + # alphabet are ignored (e.g., newlines) + # + # Results: + # The decoded value. + + proc ::base64::decode {string} { + if {[string length $string] == 0} {return ""} + + set base64 $::base64::base64 + set output "" ; # Fix for [Bug 821126] + set nums {} + + binary scan $string c* X + lappend X 61 ;# force a terminator + foreach x $X { + set bits [lindex $base64 $x] + if {$bits >= 0} { + if {[llength [lappend nums $bits]] == 4} { + foreach {v w z y} $nums break + set a [expr {($v << 2) | ($w >> 4)}] + set b [expr {(($w & 0xF) << 4) | ($z >> 2)}] + set c [expr {(($z & 0x3) << 6) | $y}] + append output [binary format ccc $a $b $c] + set nums {} + } + } elseif {$bits == -1} { + # = indicates end of data. Output whatever chars are + # left, if any. + if {![llength $nums]} break + # The encoding algorithm dictates that we can only + # have 1 or 2 padding characters. If x=={}, we must + # (*) have 12 bits of input (enough for 1 8-bit + # output). If x!={}, we have 18 bits of input (enough + # for 2 8-bit outputs). + # + # (*) If we don't then the input is broken (bug 2976290). + + foreach {v w z} $nums break + + # Bug 2976290 + if {$w == {}} { + return -code error "Not enough data to process padding" + } + + set a [expr {($v << 2) | (($w & 0x30) >> 4)}] + if {$z == {}} { + append output [binary format c $a ] + } else { + set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}] + append output [binary format cc $a $b] + } + break + } else { + # RFC 2045 says that line breaks and other characters not part + # of the Base64 alphabet must be ignored, and that the decoder + # can optionally emit a warning or reject the message. We opt + # not to do so, but to just ignore the character. + continue + } + } + return $output + } +} + +# # ## ### ##### ######## ############# ##################### +return + diff --git a/src/vendorlib/base64/base64c.tcl b/src/vendorlib/base64/base64c.tcl new file mode 100644 index 00000000..29e501df --- /dev/null +++ b/src/vendorlib/base64/base64c.tcl @@ -0,0 +1,19 @@ +# base64c - Copyright (C) 2003 Pat Thoyts +# +# This package is a place-holder for the critcl enhanced code present in +# the tcllib base64 module. +# +# Normally this code will become part of the tcllibc library. +# + +# @sak notprovided base64c +package require critcl +package provide base64c 0.1.0 + +namespace eval ::base64c { + variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $} + + critcl::ccode { + /* no code required in this file */ + } +} diff --git a/src/vendorlib/base64/pkgIndex.tcl b/src/vendorlib/base64/pkgIndex.tcl new file mode 100644 index 00000000..c8528f59 --- /dev/null +++ b/src/vendorlib/base64/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} {return} +package ifneeded base64 2.5 [list source [file join $dir base64.tcl]] +package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] +package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] +package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]] diff --git a/src/vendorlib/base64/uuencode.tcl b/src/vendorlib/base64/uuencode.tcl new file mode 100644 index 00000000..5e26422d --- /dev/null +++ b/src/vendorlib/base64/uuencode.tcl @@ -0,0 +1,335 @@ +# uuencode - Copyright (C) 2002 Pat Thoyts +# +# Provide a Tcl only implementation of uuencode and uudecode. +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +package require Tcl 8.2; # tcl minimum version + +# Try and get some compiled helper package. +if {[catch {package require tcllibc}]} { + catch {package require Trf} +} + +namespace eval ::uuencode { + namespace export encode decode uuencode uudecode +} + +proc ::uuencode::Enc {c} { + return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]] +} + +proc ::uuencode::Encode {s} { + set r {} + binary scan $s c* d + foreach {c1 c2 c3} $d { + if {$c1 == {}} {set c1 0} + if {$c2 == {}} {set c2 0} + if {$c3 == {}} {set c3 0} + append r [Enc [expr {$c1 >> 2}]] + append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]] + append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] + append r [Enc [expr {($c3 & 077)}]] + } + return $r +} + + +proc ::uuencode::Decode {s} { + if {[string length $s] == 0} {return ""} + set r {} + binary scan [pad $s] c* d + + foreach {c0 c1 c2 c3} $d { + append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF + | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]] + append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF + | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]] + append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF + | (($c3-0x20)&0x3F) & 0xFF}]] + } + return $r +} + +# ------------------------------------------------------------------------- +# C coded version of the Encode/Decode functions for base64c package. +# ------------------------------------------------------------------------- +if {[package provide critcl] != {}} { + namespace eval ::uuencode { + critcl::ccode { + #include + static unsigned char Enc(unsigned char c) { + return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60; + } + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (3 - (len % 3))) != 3) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + rlen = (len / 3) * 4; + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 3) { + char a, b, c; + a = *p; b = *(p+1), c = *(p+2); + *r++ = Enc(a >> 2); + *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017)); + *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003)); + *r++ = Enc(c & 077); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* if input is not mod 4, extend it with nuls */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + if ((xtra = (4 - (len % 4))) != 4) { + if (Tcl_IsShared(inputPtr)) + inputPtr = Tcl_DuplicateObj(inputPtr); + input = Tcl_SetByteArrayLength(inputPtr, len + xtra); + memset(input + len, 0, xtra); + len += xtra; + } + + /* output will be 1/3 smaller than input and a multiple of 3 */ + rlen = (len / 4) * 3; + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + memset(r, 0, rlen); + + for (p = input; p < input + len; p += 4) { + char a, b, c, d; + a = *p; b = *(p+1), c = *(p+2), d = *(p+3); + *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4); + *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2); + *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) ); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + } +} + +# ------------------------------------------------------------------------- + +# Description: +# Permit more tolerant decoding of invalid input strings by padding to +# a multiple of 4 bytes with nulls. +# Result: +# Returns the input string - possibly padded with uuencoded null chars. +# +proc ::uuencode::pad {s} { + if {[set mod [expr {[string length $s] % 4}]] != 0} { + append s [string repeat "`" [expr {4 - $mod}]] + } + return $s +} + +# ------------------------------------------------------------------------- + +# If the Trf package is available then we shall use this by default but the +# Tcllib implementations are always visible if needed (ie: for testing) +if {[info commands ::uuencode::CDecode] != {}} { + # tcllib critcl package + interp alias {} ::uuencode::encode {} ::uuencode::CEncode + interp alias {} ::uuencode::decode {} ::uuencode::CDecode +} elseif {[package provide Trf] != {}} { + proc ::uuencode::encode {s} { + return [::uuencode -mode encode -- $s] + } + proc ::uuencode::decode {s} { + return [::uuencode -mode decode -- [pad $s]] + } +} else { + # pure-tcl then + interp alias {} ::uuencode::encode {} ::uuencode::Encode + interp alias {} ::uuencode::decode {} ::uuencode::Decode +} + +# ------------------------------------------------------------------------- + +proc ::uuencode::uuencode {args} { + array set opts {mode 0644 filename {} name {}} + set wrongargs "wrong \# args: should be\ + \"uuencode ?-name string? ?-mode octal?\ + (-file filename | ?--? string)\"" + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(filename) [lindex $args 1] + set args [lreplace $args 0 0] + } + -m* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(mode) [lindex $args 1] + set args [lreplace $args 0 0] + } + -n* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(name) [lindex $args 1] + set args [lreplace $args 0 0] + } + -- { + set args [lreplace $args 0 0] + break + } + default { + return -code error "bad option [lindex $args 0]:\ + must be -file, -mode, or -name" + } + } + set args [lreplace $args 0 0] + } + + if {$opts(name) == {}} { + set opts(name) $opts(filename) + } + if {$opts(name) == {}} { + set opts(name) "data.dat" + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + fconfigure $f -translation binary + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error $wrongargs + } + set data [lindex $args 0] + } + + set r {} + append r [format "begin %o %s" $opts(mode) $opts(name)] "\n" + for {set n 0} {$n < [string length $data]} {incr n 45} { + set s [string range $data $n [expr {$n + 44}]] + append r [Enc [string length $s]] + append r [encode $s] "\n" + } + append r "`\nend" + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Perform uudecoding of a file or data. A file may contain more than one +# encoded data section so the result is a list where each element is a +# three element list of the provided filename, the suggested mode and the +# data itself. +# +proc ::uuencode::uudecode {args} { + array set opts {mode 0644 filename {}} + set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\"" + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { + if {[llength $args] < 2} { + return -code error $wrongargs + } + set opts(filename) [lindex $args 1] + set args [lreplace $args 0 0] + } + -- { + set args [lreplace $args 0 0] + break + } + default { + return -code error "bad option [lindex $args 0]:\ + must be -file" + } + } + set args [lreplace $args 0 0] + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error $wrongargs + } + set data [lindex $args 0] + } + + set state false + set result {} + + foreach {line} [split $data "\n"] { + switch -exact -- $state { + false { + if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \ + -> opts(mode) opts(name)]} { + set state true + set r {} + } + } + + true { + if {[string match "end" $line]} { + set state false + lappend result [list $opts(name) $opts(mode) $r] + } else { + scan $line %c c + set n [expr {($c - 0x21)}] + append r [string range \ + [decode [string range $line 1 end]] 0 $n] + } + } + } + } + + return $result +} + +# ------------------------------------------------------------------------- + +package provide uuencode 1.1.5 + +# ------------------------------------------------------------------------- +# +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: + diff --git a/src/vendorlib/base64/yencode.tcl b/src/vendorlib/base64/yencode.tcl new file mode 100644 index 00000000..0d4554c0 --- /dev/null +++ b/src/vendorlib/base64/yencode.tcl @@ -0,0 +1,307 @@ +# yencode.tcl - Copyright (C) 2002 Pat Thoyts +# +# Provide a Tcl only implementation of yEnc encoding algorithm +# +# ------------------------------------------------------------------------- +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# ------------------------------------------------------------------------- + +# FUTURE: Rework to allow switching between the tcl/critcl implementations. + +package require Tcl 8.2; # tcl minimum version +catch {package require crc32}; # tcllib 1.1 +catch {package require tcllibc}; # critcl enhancements for tcllib + +namespace eval ::yencode { + namespace export encode decode yencode ydecode +} + +# ------------------------------------------------------------------------- + +proc ::yencode::Encode {s} { + set r {} + binary scan $s c* d + foreach {c} $d { + set v [expr {($c + 42) % 256}] + if {$v == 0x00 || $v == 0x09 || $v == 0x0A + || $v == 0x0D || $v == 0x3D} { + append r "=" + set v [expr {($v + 64) % 256}] + } + append r [format %c $v] + } + return $r +} + +proc ::yencode::Decode {s} { + if {[string length $s] == 0} {return ""} + set r {} + set esc 0 + binary scan $s c* d + foreach c $d { + if {$c == 61 && $esc == 0} { + set esc 1 + continue + } + set v [expr {($c - 42) % 256}] + if {$esc} { + set v [expr {($v - 64) % 256}] + set esc 0 + } + append r [format %c $v] + } + return $r +} + +# ------------------------------------------------------------------------- +# C coded versions for critcl built base64c package +# ------------------------------------------------------------------------- + +if {[package provide critcl] != {}} { + namespace eval ::yencode { + critcl::ccode { + #include + } + critcl::ccommand CEncode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, xtra; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* calculate the length of the encoded result */ + rlen = len; + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) + rlen++; + } + + /* allocate the output buffer */ + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, rlen); + + /* encode the input */ + for (p = input; p < input + len; p++) { + v = (*p + 42) % 256; + if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) { + *r++ = '='; + v = (v + 64) % 256; + } + *r++ = v; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + critcl::ccommand CDecode {dummy interp objc objv} { + Tcl_Obj *inputPtr, *resultPtr; + int len, rlen, esc; + unsigned char *input, *p, *r, v; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "data"); + return TCL_ERROR; + } + + /* fetch the input data */ + inputPtr = objv[1]; + input = Tcl_GetByteArrayFromObj(inputPtr, &len); + + /* allocate the output buffer */ + resultPtr = Tcl_NewObj(); + r = Tcl_SetByteArrayLength(resultPtr, len); + + /* encode the input */ + for (p = input, esc = 0, rlen = 0; p < input + len; p++) { + if (*p == 61 && esc == 0) { + esc = 1; + continue; + } + v = (*p - 42) % 256; + if (esc) { + v = (v - 64) % 256; + esc = 0; + } + *r++ = v; + rlen++; + } + Tcl_SetByteArrayLength(resultPtr, rlen); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + } +} + +if {[info commands ::yencode::CEncode] != {}} { + interp alias {} ::yencode::encode {} ::yencode::CEncode + interp alias {} ::yencode::decode {} ::yencode::CDecode +} else { + interp alias {} ::yencode::encode {} ::yencode::Encode + interp alias {} ::yencode::decode {} ::yencode::Decode +} + +# ------------------------------------------------------------------------- +# Description: +# Pop the nth element off a list. Used in options processing. +# +proc ::yencode::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- + +proc ::yencode::yencode {args} { + array set opts {mode 0644 filename {} name {} line 128 crc32 1} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { set opts(filename) [Pop args 1] } + -m* { set opts(mode) [Pop args 1] } + -n* { set opts(name) [Pop args 1] } + -l* { set opts(line) [Pop args 1] } + -c* { set opts(crc32) [Pop args 1] } + -- { Pop args ; break } + default { + set options [join [lsort [array names opts]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be -$options" + } + } + Pop args + } + + if {$opts(name) == {}} { + set opts(name) $opts(filename) + } + if {$opts(name) == {}} { + set opts(name) "data.dat" + } + if {! [string is boolean $opts(crc32)]} { + return -code error "bad option -crc32: argument must be true or false" + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + fconfigure $f -translation binary + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be\ + \"yencode ?options? -file name | data\"" + } + set data [lindex $args 0] + } + + set opts(size) [string length $data] + + set r {} + append r [format "=ybegin line=%d size=%d name=%s" \ + $opts(line) $opts(size) $opts(name)] "\n" + + set ndx 0 + while {$ndx < $opts(size)} { + set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]] + set enc [encode $pln] + incr ndx [string length $pln] + append r $enc "\r\n" + } + + append r [format "=yend size=%d" $ndx] + if {$opts(crc32)} { + append r " crc32=" [crc::crc32 -format %x $data] + } + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Perform ydecoding of a file or data. A file may contain more than one +# encoded data section so the result is a list where each element is a +# three element list of the provided filename, the file size and the +# data itself. +# +proc ::yencode::ydecode {args} { + array set opts {mode 0644 filename {} name default.bin} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { set opts(filename) [Pop args 1] } + -- { Pop args ; break; } + default { + set options [join [lsort [array names opts]] ", -"] + return -code error "bad option [lindex $args 0]:\ + must be -$opts" + } + } + Pop args + } + + if {$opts(filename) != {}} { + set f [open $opts(filename) r] + set data [read $f] + close $f + } else { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be\ + \"ydecode ?options? -file name | data\"" + } + set data [lindex $args 0] + } + + set state false + set result {} + + foreach {line} [split $data "\n"] { + set line [string trimright $line "\r\n"] + switch -exact -- $state { + false { + if {[string match "=ybegin*" $line]} { + regexp {line=(\d+)} $line -> opts(line) + regexp {size=(\d+)} $line -> opts(size) + regexp {name=(\d+)} $line -> opts(name) + + if {$opts(name) == {}} { + set opts(name) default.bin + } + + set state true + set r {} + } + } + + true { + if {[string match "=yend*" $line]} { + set state false + lappend result [list $opts(name) $opts(size) $r] + } else { + append r [decode $line] + } + } + } + } + + return $result +} + +# ------------------------------------------------------------------------- + +package provide yencode 1.1.3 + +# ------------------------------------------------------------------------- +# +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: + diff --git a/src/vendorlib/control/ascaller.tcl b/src/vendorlib/control/ascaller.tcl new file mode 100644 index 00000000..6c864bb5 --- /dev/null +++ b/src/vendorlib/control/ascaller.tcl @@ -0,0 +1,72 @@ +# ascaller.tcl - +# +# A few utility procs that manage the evaluation of a command +# or a script in the context of a caller, taking care of all +# the ugly details of proper return codes, errorcodes, and +# a good stack trace in ::errorInfo as appropriate. +# ------------------------------------------------------------------------- +# +# RCS: @(#) $Id: ascaller.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ + +namespace eval ::control { + + proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} { + set x [expr {[string equal "" $where] + ? {} : [subst -nobackslashes {\n ($where)}]}] + set script [subst -nobackslashes -nocommands { + set $codeVar [catch {uplevel 1 $$cmdVar} $resultVar] + if {$$codeVar > 1} { + return -code $$codeVar $$resultVar + } + if {$$codeVar == 1} { + if {[string equal {"uplevel 1 $$cmdVar"} \ + [lindex [split [set ::errorInfo] \n] end]]} { + set $codeVar [join \ + [lrange [split [set ::errorInfo] \n] 0 \ + end-[expr {4+[llength [split $$cmdVar \n]]}]] \n] + } else { + set $codeVar [join \ + [lrange [split [set ::errorInfo] \n] 0 end-1] \n] + } + return -code error -errorcode [set ::errorCode] \ + -errorinfo "$$codeVar$x" $$resultVar + } + }] + return $script + } + + proc BodyAsCaller {bodyVar resultVar codeVar {where {}}} { + set x [expr {[string equal "" $where] + ? {} : [subst -nobackslashes -nocommands \ + {\n ($where[string map {{ ("uplevel"} {}} \ + [lindex [split [set ::errorInfo] \n] end]]}]}] + set script [subst -nobackslashes -nocommands { + set $codeVar [catch {uplevel 1 $$bodyVar} $resultVar] + if {$$codeVar == 1} { + if {[string equal {"uplevel 1 $$bodyVar"} \ + [lindex [split [set ::errorInfo] \n] end]]} { + set ::errorInfo [join \ + [lrange [split [set ::errorInfo] \n] 0 end-2] \n] + } + set $codeVar [join \ + [lrange [split [set ::errorInfo] \n] 0 end-1] \n] + return -code error -errorcode [set ::errorCode] \ + -errorinfo "$$codeVar$x" $$resultVar + } + }] + return $script + } + + proc ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result + } + +} diff --git a/src/vendorlib/control/assert.tcl b/src/vendorlib/control/assert.tcl new file mode 100644 index 00000000..8aac408d --- /dev/null +++ b/src/vendorlib/control/assert.tcl @@ -0,0 +1,91 @@ +# assert.tcl -- +# +# The [assert] command of the package "control". +# +# RCS: @(#) $Id: assert.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ + +namespace eval ::control { + + namespace eval assert { + namespace export EnabledAssert DisabledAssert + variable CallbackCmd [list return -code error] + + namespace import [namespace parent]::no-op + rename no-op DisabledAssert + + proc EnabledAssert {expr args} { + variable CallbackCmd + + set code [catch {uplevel 1 [list expr $expr]} res] + if {$code} { + return -code $code $res + } + if {![string is boolean -strict $res]} { + return -code error "invalid boolean expression: $expr" + } + if {$res} {return} + if {[llength $args]} { + set msg [join $args] + } else { + set msg "assertion failed: $expr" + } + # Might want to catch this + namespace eval :: $CallbackCmd [list $msg] + } + + proc enabled {args} { + set n [llength $args] + if {$n > 1} { + return -code error "wrong # args: should be\ + \"[lindex [info level 0] 0] ?boolean?\"" + } + if {$n} { + set val [lindex $args 0] + if {![string is boolean -strict $val]} { + return -code error "invalid boolean value: $val" + } + if {$val} { + [namespace parent]::AssertSwitch Disabled Enabled + } else { + [namespace parent]::AssertSwitch Enabled Disabled + } + } else { + return [string equal [namespace origin EnabledAssert] \ + [namespace origin [namespace parent]::assert]] + } + return "" + } + + proc callback {args} { + set n [llength $args] + if {$n > 1} { + return -code error "wrong # args: should be\ + \"[lindex [info level 0] 0] ?command?\"" + } + if {$n} { + return [variable CallbackCmd [lindex $args 0]] + } + variable CallbackCmd + return $CallbackCmd + } + + } + + proc AssertSwitch {old new} { + if {[string equal [namespace origin assert] \ + [namespace origin assert::${new}Assert]]} {return} + rename assert ${old}Assert + rename ${new}Assert assert + } + + namespace import assert::DisabledAssert assert::EnabledAssert + + # For indexer + proc assert args # + rename assert {} + + # Initial default: disabled asserts + rename DisabledAssert assert + +} + diff --git a/src/vendorlib/control/control.tcl b/src/vendorlib/control/control.tcl new file mode 100644 index 00000000..6cdf08a0 --- /dev/null +++ b/src/vendorlib/control/control.tcl @@ -0,0 +1,24 @@ +# control.tcl -- +# +# This is the main package provide script for the package +# "control". It provides commands that govern the flow of +# control of a program. + +package require Tcl 8.2 + +namespace eval ::control { + namespace export assert control do no-op rswitch + + proc control {command args} { + # Need to add error handling here + namespace eval [list $command] $args + } + + # Set up for auto-loading the commands + variable home [file join [pwd] [file dirname [info script]]] + if {[lsearch -exact $::auto_path $home] == -1} { + lappend ::auto_path $home + } + + package provide [namespace tail [namespace current]] 0.1.3 +} diff --git a/src/vendorlib/control/do.tcl b/src/vendorlib/control/do.tcl new file mode 100644 index 00000000..aa5c1af5 --- /dev/null +++ b/src/vendorlib/control/do.tcl @@ -0,0 +1,81 @@ +# do.tcl -- +# +# Tcl implementation of a "do ... while|until" loop. +# +# Originally written for the "Texas Tcl Shootout" programming contest +# at the 2000 Tcl Conference in Austin/Texas. +# +# Copyright (c) 2001 by Reinhard Max +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: do.tcl,v 1.6 2004/01/15 06:36:12 andreas_kupries Exp $ +# +namespace eval ::control { + + proc do {body args} { + + # + # Implements a "do body while|until test" loop + # + # It is almost as fast as builtin "while" command for loops with + # more than just a few iterations. + # + + set len [llength $args] + if {$len !=2 && $len != 0} { + set proc [namespace current]::[lindex [info level 0] 0] + return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\"" + } + set test 0 + foreach {whileOrUntil test} $args { + switch -exact -- $whileOrUntil { + "while" {} + "until" { set test !($test) } + default { + return -code error \ + "bad option \"$whileOrUntil\": must be until, or while" + } + } + break + } + + # the first invocation of the body + set code [catch { uplevel 1 $body } result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel do] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return + } + 4 {} + default { + return -code $code $result + } + } + # the rest of the loop + set code [catch {uplevel 1 [list while $test $body]} result] + if {$code == 1} { + return -errorinfo [ErrorInfoAsCaller while do] \ + -errorcode $::errorCode -code error $result + } + return -code $code $result + + } + +} diff --git a/src/vendorlib/control/no-op.tcl b/src/vendorlib/control/no-op.tcl new file mode 100644 index 00000000..2400303f --- /dev/null +++ b/src/vendorlib/control/no-op.tcl @@ -0,0 +1,14 @@ +# no-op.tcl -- +# +# The [no-op] command of the package "control". +# It accepts any number of arguments and does nothing. +# It returns an empty string. +# +# RCS: @(#) $Id: no-op.tcl,v 1.2 2004/01/15 06:36:12 andreas_kupries Exp $ + +namespace eval ::control { + + proc no-op args {} + +} + diff --git a/src/vendorlib/control/pkgIndex.tcl b/src/vendorlib/control/pkgIndex.tcl new file mode 100644 index 00000000..3b432db7 --- /dev/null +++ b/src/vendorlib/control/pkgIndex.tcl @@ -0,0 +1,2 @@ +if {![package vsatisfies [package provide Tcl] 8.2]} {return} +package ifneeded control 0.1.3 [list source [file join $dir control.tcl]] diff --git a/src/vendorlib/control/tclIndex b/src/vendorlib/control/tclIndex new file mode 100644 index 00000000..614d932f --- /dev/null +++ b/src/vendorlib/control/tclIndex @@ -0,0 +1,18 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(::control::CommandAsCaller) [list source [file join $dir ascaller.tcl]] +set auto_index(::control::BodyAsCaller) [list source [file join $dir ascaller.tcl]] +set auto_index(::control::ErrorInfoAsCaller) [list source [file join $dir ascaller.tcl]] +set auto_index(::control::assert::EnabledAssert) [list source [file join $dir assert.tcl]] +set auto_index(::control::assert::enabled) [list source [file join $dir assert.tcl]] +set auto_index(::control::assert::callback) [list source [file join $dir assert.tcl]] +set auto_index(::control::AssertSwitch) [list source [file join $dir assert.tcl]] +set auto_index(::control::assert) [list source [file join $dir assert.tcl]] +set auto_index(::control::do) [list source [file join $dir do.tcl]] +set auto_index(::control::no-op) [list source [file join $dir no-op.tcl]] diff --git a/src/vendorlib/debug/caller.tcl b/src/vendorlib/debug/caller.tcl new file mode 100644 index 00000000..e85a9f08 --- /dev/null +++ b/src/vendorlib/debug/caller.tcl @@ -0,0 +1,97 @@ +## -*- tcl -*- +# ### ### ### ######### ######### ######### + +## Utility command for use as debug prefix command to un-mangle snit +## and TclOO method calls. + +# ### ### ### ######### ######### ######### +## Requisites + +package require Tcl 8.5 +package require debug + +namespace eval ::debug { + namespace export caller + namespace ensemble create +} + +# ### ### ### ######### ######### ######### +## API & Implementation + +proc ::debug::caller {args} { + # For snit (type)methods, rework the command line to be more + # legible and in line with what the user would expect. To this end + # we pull the primary command out of the arguments, be it type or + # object, massage the command to match the original (type)method + # name, then resort and expand the words to match the call before + # the snit got its claws into it. + + set a [lassign [info level -1] m] + regsub {.*Snit_} $m {} m + + if {[string match ::oo::Obj*::my $m]} { + # TclOO call. + set m [uplevel 1 self] + return [list $m {*}[Filter $a $args]] + } + if {$m eq "my"} { + # TclOO call. + set m [uplevel 1 self] + return [list $m {*}[Filter $a $args]] + } + + switch -glob -- $m { + htypemethod* { + # primary = type, a = type + set a [lassign $a primary] + set m [string map {_ { }} [string range $m 11 end]] + } + typemethod* { + # primary = type, a = type + set a [lassign $a primary] + set m [string range $m 10 end] + } + hmethod* { + # primary = self, a = type selfns self win ... + set a [lassign $a _ _ primary _] + set m [string map {_ { }} [string range $m 7 end]] + } + method* { + # primary = self, a = type selfns self win ... + set a [lassign $a _ _ primary _] + set m [string range $m 6 end] + } + destructor - + constructor { + # primary = self, a = type selfns self win ... + set a [lassign $a _ _ primary _] + } + typeconstructor { + return [list {*}$a $m] + } + default { + # Unknown + return [list $m {*}[Filter $a $args]] + } + } + return [list $primary {*}$m {*}[Filter $a $args]] +} + +proc ::debug::Filter {args droplist} { + if {[llength $droplist]} { + # Replace unwanted arguments with '*'. This is usually done + # for arguments which can be large Tcl values. These would + # screw up formatting and, to add insult to this injury, also + # repeat for each debug output in the same proc, method, etc. + foreach i [lsort -integer $droplist] { + set args [lreplace $args $i $i *] + } + } + return $args +} + +# ### ######### ########################### +## Ready for use + +package provide debug::caller 1.1 +return diff --git a/src/vendorlib/debug/debug.tcl b/src/vendorlib/debug/debug.tcl new file mode 100644 index 00000000..4ce60808 --- /dev/null +++ b/src/vendorlib/debug/debug.tcl @@ -0,0 +1,306 @@ +# Debug - a debug narrative logger. +# -- Colin McCormack / originally Wub server utilities +# +# Debugging areas of interest are represented by 'tokens' which have +# independantly settable levels of interest (an integer, higher is more detailed) +# +# Debug narrative is provided as a tcl script whose value is [subst]ed in the +# caller's scope if and only if the current level of interest matches or exceeds +# the Debug call's level of detail. This is useful, as one can place arbitrarily +# complex narrative in code without unnecessarily evaluating it. +# +# TODO: potentially different streams for different areas of interest. +# (currently only stderr is used. there is some complexity in efficient +# cross-threaded streams.) + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 + +namespace eval ::debug { + namespace export -clear \ + define on off prefix suffix header trailer \ + names 2array level setting parray pdict \ + nl tab hexl + namespace ensemble create -subcommands {} +} + +# # ## ### ##### ######## ############# ##################### +## API & Implementation + +proc ::debug::noop {args} {} + +proc ::debug::debug {tag message {level 1}} { + variable detail + if {$detail($tag) < $level} { + #puts stderr "$tag @@@ $detail($tag) >= $level" + return + } + + variable prefix + variable suffix + variable header + variable trailer + variable fds + + if {[info exists fds($tag)]} { + set fd $fds($tag) + } else { + set fd stderr + } + + # Assemble the shown text from the user message and the various + # prefixes and suffices (global + per-tag). + + set themessage "" + if {[info exists prefix(::)]} { append themessage $prefix(::) } + if {[info exists prefix($tag)]} { append themessage $prefix($tag) } + append themessage $message + if {[info exists suffix($tag)]} { append themessage $suffix($tag) } + if {[info exists suffix(::)]} { append themessage $suffix(::) } + + # Resolve variables references and command invokations embedded + # into the message with plain text. + set code [catch { + set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] + set sheader [uplevel 1 [list ::subst -nobackslashes $header]] + set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] + } __ eo] + + # And dump an internal error if that resolution failed. + if {$code} { + if {[catch { + set caller [info level -1] + }]} { set caller GLOBAL } + if {[string length $caller] >= 1000} { + set caller "[string range $caller 0 200]...[string range $caller end-200 end]" + } + foreach line [split $caller \n] { + puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" + } + return + } + + # From here we have a good message to show. We only shorten it a + # bit if its a bit excessive in size. + + if {[string length $smessage] > 4096} { + set head [string range $smessage 0 2048] + set tail [string range $smessage end-2048 end] + set smessage "${head}...(truncated)...$tail" + } + + foreach line [split $smessage \n] { + puts $fd "$sheader$tag | $line$strailer" + } + return +} + +# names - return names of debug tags +proc ::debug::names {} { + variable detail + return [lsort [array names detail]] +} + +proc ::debug::2array {} { + variable detail + set result {} + foreach n [lsort [array names detail]] { + if {[interp alias {} debug.$n] ne "::debug::noop"} { + lappend result $n $detail($n) + } else { + lappend result $n -$detail($n) + } + } + return $result +} + +# level - set level and fd for tag +proc ::debug::level {tag {level ""} {fd {}}} { + variable detail + # TODO: Force level >=0. + if {$level ne ""} { + set detail($tag) $level + } + + if {![info exists detail($tag)]} { + set detail($tag) 1 + } + + variable fds + if {$fd ne {}} { + set fds($tag) $fd + } + + return $detail($tag) +} + +proc ::debug::header {text} { variable header $text } +proc ::debug::trailer {text} { variable trailer $text } + +proc ::debug::define {tag} { + if {[interp alias {} debug.$tag] ne {}} return + off $tag + return +} + +# Set a prefix/suffix to use for tag. +# The global (tag-independent) prefix/suffix is adressed through tag '::'. +# This works because colon (:) is an illegal character for user-specified tags. + +proc ::debug::prefix {tag {theprefix {}}} { + variable prefix + set prefix($tag) $theprefix + + if {[interp alias {} debug.$tag] ne {}} return + off $tag + return +} + +proc ::debug::suffix {tag {theprefix {}}} { + variable suffix + set suffix($tag) $theprefix + + if {[interp alias {} debug.$tag] ne {}} return + off $tag + return +} + +# turn on debugging for tag +proc ::debug::on {tag {level ""} {fd {}}} { + variable active + set active($tag) 1 + level $tag $level $fd + interp alias {} debug.$tag {} ::debug::debug $tag + return +} + +# turn off debugging for tag +proc ::debug::off {tag {level ""} {fd {}}} { + variable active + set active($tag) 1 + level $tag $level $fd + interp alias {} debug.$tag {} ::debug::noop + return +} + +proc ::debug::setting {args} { + if {[llength $args] == 1} { + set args [lindex $args 0] + } + set fd stderr + if {[llength $args] % 2} { + set fd [lindex $args end] + set args [lrange $args 0 end-1] + } + foreach {tag level} $args { + if {$level > 0} { + level $tag $level $fd + interp alias {} debug.$tag {} ::debug::debug $tag + } else { + level $tag [expr {-$level}] $fd + interp alias {} debug.$tag {} ::debug::noop + } + } + return +} + +# # ## ### ##### ######## ############# ##################### +## Convenience commands. +# Format arrays and dicts as multi-line message. +# Insert newlines and tabs. + +proc ::debug::nl {} { return \n } +proc ::debug::tab {} { return \t } + +proc ::debug::parray {a {pattern *}} { + upvar 1 $a array + if {![array exists array]} { + error "\"$a\" isn't an array" + } + pdict [array get array] $pattern +} + +proc ::debug::pdict {dict {pattern *}} { + set maxl 0 + set names [lsort -dict [dict keys $dict $pattern]] + foreach name $names { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + set maxl [expr {$maxl + 2}] + set lines {} + foreach name $names { + set nameString [format (%s) $name] + lappend lines [format "%-*s = %s" \ + $maxl $nameString \ + [dict get $dict $name]] + } + return [join $lines \n] +} + +proc ::debug::hexl {data {prefix {}}} { + set r {} + + # Convert the data to hex and to characters. + binary scan $data H*@0a* hexa asciia + + # Replace non-printing characters in the data with dots. + regsub -all -- {[^[:graph:] ]} $asciia {.} asciia + + # Pad with spaces to a full multiple of 32/16. + set n [expr {[string length $hexa] % 32}] + if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } + #puts "pad H [expr {32-$n}]" + + set n [expr {[string length $asciia] % 32}] + if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } + #puts "pad A [expr {32-$n}]" + + # Reassemble formatted, in groups of 16 bytes/characters. + # The hex part is handled in groups of 32 nibbles. + set addr 0 + while {[string length $hexa]} { + # Get front group of 16 bytes each. + set hex [string range $hexa 0 31] + set ascii [string range $asciia 0 15] + # Prep for next iteration + set hexa [string range $hexa 32 end] + set asciia [string range $asciia 16 end] + + # Convert the hex to pairs of hex digits + regsub -all -- {..} $hex {& } hex + + # Add the hex and latin-1 data to the result buffer + append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n + incr addr 16 + } + + # And done + return $r +} + +# # ## ### ##### ######## ############# ##################### + +namespace eval debug { + variable detail ; # map: TAG -> level of interest + variable prefix ; # map: TAG -> message prefix to use + variable suffix ; # map: TAG -> message suffix to use + variable fds ; # map: TAG -> handle of open channel to log to. + variable header {} ; # per-line heading, subst'ed + variable trailer {} ; # per-line ending, subst'ed + + # Notes: + # - The tag '::' is reserved. "prefix" and "suffix" use it to store + # the global message prefix / suffix. + # - prefix and suffix are applied per message. + # - header and trailer are per line. And should not generate multiple lines! +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide debug 1.0.6 +return diff --git a/src/vendorlib/debug/heartbeat.tcl b/src/vendorlib/debug/heartbeat.tcl new file mode 100644 index 00000000..a00ecd94 --- /dev/null +++ b/src/vendorlib/debug/heartbeat.tcl @@ -0,0 +1,68 @@ +# -*- tcl -* +# Debug -- Heartbeat. Track operation of Tcl's eventloop. +# -- Colin McCormack / originally Wub server utilities + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 +package require debug + +namespace eval ::debug { + namespace export heartbeat + namespace ensemble create +} + +# # ## ### ##### ######## ############# ##################### +## API & Implementation + +proc ::debug::heartbeat {{delta 500}} { + variable duration $delta + variable timer + + if {$duration > 0} { + # stop a previous heartbeat before starting the next + catch { after cancel $timer } + on heartbeat + ::debug::every $duration { + debug.heartbeat {[::debug::pulse]} + } + } else { + catch { after cancel $timer } + off heartbeat + } +} + +proc ::debug::every {ms body} { + eval $body + variable timer [after $ms [info level 0]] + return +} + +proc ::debug::pulse {} { + variable duration + variable hbtimer + variable heartbeat + + set now [::tcl::clock::milliseconds] + set diff [expr {$now - $hbtimer - $duration}] + + set hbtimer $now + + return [list [incr heartbeat] $diff] +} + +# # ## ### ##### ######## ############# ##################### + +namespace eval ::debug { + variable duration 0 ; # milliseconds between heart-beats + variable heartbeat 0 ; # beat counter + variable hbtimer [::tcl::clock::milliseconds] + variable timer +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide debug::heartbeat 1.0.1 +return diff --git a/src/vendorlib/debug/pkgIndex.tcl b/src/vendorlib/debug/pkgIndex.tcl new file mode 100644 index 00000000..065cc9e7 --- /dev/null +++ b/src/vendorlib/debug/pkgIndex.tcl @@ -0,0 +1,5 @@ +if {![package vsatisfies [package require Tcl] 8.5]} return +package ifneeded debug 1.0.6 [list source [file join $dir debug.tcl]] +package ifneeded debug::heartbeat 1.0.1 [list source [file join $dir heartbeat.tcl]] +package ifneeded debug::timestamp 1 [list source [file join $dir timestamp.tcl]] +package ifneeded debug::caller 1.1 [list source [file join $dir caller.tcl]] diff --git a/src/vendorlib/debug/timestamp.tcl b/src/vendorlib/debug/timestamp.tcl new file mode 100644 index 00000000..5fec019e --- /dev/null +++ b/src/vendorlib/debug/timestamp.tcl @@ -0,0 +1,47 @@ +# -*- tcl -* +# Debug -- Timestamps. +# -- Colin McCormack / originally Wub server utilities +# +# Generate timestamps for debug messages. +# The provided commands are for use in prefixes and headers. + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 +package require debug + +namespace eval ::debug { + namespace export timestamp + namespace ensemble create +} + +# # ## ### ##### ######## ############# ##################### +## API & Implementation + +proc ::debug::timestamp {} { + variable timestamp::delta + variable timestamp::baseline + + set now [::tcl::clock::milliseconds] + if {$delta} { + set time "${now}-[expr {$now - $delta}]mS " + } else { + set time "${now}mS " + } + set delta $now + return $time +} + +# # ## ### ##### ######## ############# ##################### + +namespace eval ::debug::timestamp { + variable delta 0 + variable baseline [::tcl::clock::milliseconds] +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide debug::timestamp 1 +return diff --git a/src/vendorlib/term/ansi/code.tcl b/src/vendorlib/term/ansi/code.tcl new file mode 100644 index 00000000..a8f7d3e9 --- /dev/null +++ b/src/vendorlib/term/ansi/code.tcl @@ -0,0 +1,56 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI +## Generic commands to define commands for code sequences. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::ansi::code {} + +# ### ### ### ######### ######### ######### +## API. Escape clauses, plain and bracket +## Used by 'define'd commands. + +proc ::term::ansi::code::esc {str} {return \033$str} +proc ::term::ansi::code::escb {str} {esc \[$str} + +# ### ### ### ######### ######### ######### +## API. Define command for named control code, or constant. +## (Simple definitions without arguments) + +proc ::term::ansi::code::define {name escape code} { + proc [Qualified $name] {} [list ::term::ansi::code::$escape $code] +} + +proc ::term::ansi::code::const {name code} { + proc [Qualified $name] {} [list return $code] +} + +# ### ### ### ######### ######### ######### +## Internal helper to construct fully-qualified names. + +proc ::term::ansi::code::Qualified {name} { + if {![string match ::* $name]} { + # Get the caller's namespace; append :: if it is not the + # global namespace, for separation from the actual name. + set ns [uplevel 2 [list namespace current]] + if {$ns ne "::"} {append ns ::} + set name $ns$name + } + return $name +} + +# ### ### ### ######### ######### ######### + +namespace eval ::term::ansi::code { + namespace export esc escb define const +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/ansi/code/attr.tcl b/src/vendorlib/term/ansi/code/attr.tcl new file mode 100644 index 00000000..d7d062b8 --- /dev/null +++ b/src/vendorlib/term/ansi/code/attr.tcl @@ -0,0 +1,108 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Attribute codes + +# ### ### ### ######### ######### ######### +## Requirements + +package require term::ansi::code ; # Constants + +namespace eval ::term::ansi::code::attr {} + +# ### ### ### ######### ######### ######### +## API. Symbolic names. + +proc ::term::ansi::code::attr::names {} { + variable attr + return $attr +} + +proc ::term::ansi::code::attr::import {{ns attr} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::code::attr::[join $args " ::term::ansi::code::attr::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## Internal - Setup + +proc ::term::ansi::code::attr::DEF {name value} { + variable attr + const $name $value + lappend attr $name + namespace export $name + return +} + +proc ::term::ansi::code::attr::INIT {} { + # ### ### ### ######### ######### ######### + ## + + # Colors. Foreground <=> Text + DEF fgblack 30 ; # Black + DEF fgred 31 ; # Red + DEF fggreen 32 ; # Green + DEF fgyellow 33 ; # Yellow + DEF fgblue 34 ; # Blue + DEF fgmagenta 35 ; # Magenta + DEF fgcyan 36 ; # Cyan + DEF fgwhite 37 ; # White + DEF fgdefault 39 ; # Default (Black) + + # Colors. Background. + DEF bgblack 40 ; # Black + DEF bgred 41 ; # Red + DEF bggreen 42 ; # Green + DEF bgyellow 43 ; # Yellow + DEF bgblue 44 ; # Blue + DEF bgmagenta 45 ; # Magenta + DEF bgcyan 46 ; # Cyan + DEF bgwhite 47 ; # White + DEF bgdefault 49 ; # Default (Transparent) + + # Non-color attributes. Activation. + DEF bold 1 ; # Bold + DEF dim 2 ; # Dim + DEF italic 3 ; # Italics + DEF underline 4 ; # Underscore + DEF blink 5 ; # Blink + DEF revers 7 ; # Reverse + DEF hidden 8 ; # Hidden + DEF strike 9 ; # StrikeThrough + + # Non-color attributes. Deactivation. + DEF nobold 22 ; # Bold + DEF nodim __ ; # Dim + DEF noitalic 23 ; # Italics + DEF nounderline 24 ; # Underscore + DEF noblink 25 ; # Blink + DEF norevers 27 ; # Reverse + DEF nohidden 28 ; # Hidden + DEF nostrike 29 ; # StrikeThrough + + # Remainder + DEF reset 0 ; # Reset + + ## + # ### ### ### ######### ######### ######### + return +} + +# ### ### ### ######### ######### ######### +## Data structures. + +namespace eval ::term::ansi::code::attr { + namespace import ::term::ansi::code::const + variable attr {} +} + +::term::ansi::code::attr::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code::attr 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/ansi/code/ctrl.tcl b/src/vendorlib/term/ansi/code/ctrl.tcl new file mode 100644 index 00000000..eb2e3b24 --- /dev/null +++ b/src/vendorlib/term/ansi/code/ctrl.tcl @@ -0,0 +1,272 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Control codes + +## References +# [0] Google: ansi terminal control +# [1] http://vt100.net/docs/vt100-ug/chapter3.html +# [2] http://www.termsys.demon.co.uk/vtansi.htm +# [3] http://rrbrandt.dyndns.org:60000/docs/tut/redes/ansi.php +# [4] http://www.dee.ufcg.edu.br/~rrbrandt/tools/ansi.html +# [5] http://www.ecma-international.org/publications/standards/Ecma-048.htm + +# ### ### ### ######### ######### ######### +## Requirements + +package require term::ansi::code +package require term::ansi::code::attr + +namespace eval ::term::ansi::code::ctrl {} + +# ### ### ### ######### ######### ######### +## API. Symbolic names. + +proc ::term::ansi::code::ctrl::names {} { + variable ctrl + return $ctrl +} + +proc ::term::ansi::code::ctrl::import {{ns ctrl} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::code::ctrl::[join $args " ::term::ansi::code::ctrl::"] + uplevel 1 [list namespace eval $ns [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### + +## TODO = symbolic key codes for skd. + +# ### ### ### ######### ######### ######### +## Internal - Setup + +proc ::term::ansi::code::ctrl::DEF {name esc value} { + variable ctrl + define $name $esc $value + lappend ctrl $name + namespace export $name + return +} + +proc ::term::ansi::code::ctrl::DEFC {name arguments script} { + variable ctrl + proc $name $arguments $script + lappend ctrl $name + namespace export $name + return +} + +proc ::term::ansi::code::ctrl::INIT {} { + # ### ### ### ######### ######### ######### + ## + + # Erasing + + DEF eeol escb K ; # Erase (to) End Of Line + DEF esol escb 1K ; # Erase (to) Start Of Line + DEF el escb 2K ; # Erase (current) Line + DEF ed escb J ; # Erase Down (to bottom) + DEF eu escb 1J ; # Erase Up (to top) + DEF es escb 2J ; # Erase Screen + + # Scrolling + + DEF sd esc D ; # Scroll Down + DEF su esc M ; # Scroll Up + + # Cursor Handling + + DEF ch escb H ; # Cursor Home + DEF sc escb s ; # Save Cursor + DEF rc escb u ; # Restore Cursor (Unsave) + DEF sca esc 7 ; # Save Cursor + Attributes + DEF rca esc 8 ; # Restore Cursor + Attributes + + # Tabbing + + DEF st esc H ; # Set Tab (@ current position) + DEF ct escb g ; # Clear Tab (@ current position) + DEF cat escb 3g ; # Clear All Tabs + + # Device Introspection + + DEF qdc escb c ; # Query Device Code + DEF qds escb 5n ; # Query Device Status + DEF qcp escb 6n ; # Query Cursor Position + DEF rd esc c ; # Reset Device + + # Linewrap on/off + + DEF elw escb 7h ; # Enable Line Wrap + DEF dlw escb 7l ; # Disable Line Wrap + + # Graphics Mode (aka use alternate font on/off) + + DEF eg esc F ; # Enter Graphics Mode + DEF lg esc G ; # Exit Graphics Mode + + ## + # ### ### ### ######### ######### ######### + + # ### ### ### ######### ######### ######### + ## Complex, parameterized codes + + # Select Character Set + # Choose which char set is used for default and + # alternate font. This does not change whether + # default or alternate font are used + + DEFC scs0 {tag} {esc ($tag} ; # Set default character set + DEFC scs1 {tag} {esc )$tag} ; # Set alternate character set + + # tags in A : United Kingdom Set + # B : ASCII Set + # 0 : Special Graphics + # 1 : Alternate Character ROM Standard Character Set + # 2 : Alternate Character ROM Special Graphics + + # Set Display Attributes + + DEFC sda {args} {escb [join $args \;]m} + + # Force Cursor Position (aka Go To) + + DEFC fcp {r c} {escb ${r}\;${c}f} + + # Cursor Up, Down, Forward, Backward + + DEFC cu {{n 1}} {escb [expr {$n == 1 ? "A" : "${n}A"}]} + DEFC cd {{n 1}} {escb [expr {$n == 1 ? "B" : "${n}B"}]} + DEFC cf {{n 1}} {escb [expr {$n == 1 ? "C" : "${n}C"}]} + DEFC cb {{n 1}} {escb [expr {$n == 1 ? "D" : "${n}D"}]} + + # Scroll Screen (entire display, or between rows start end, inclusive). + + DEFC ss {args} { + if {[llength $args] == 0} {return [escb r]} + if {[llength $args] == 2} {foreach {s e} $args break ; return [escb ${s};${e}r]} + return -code error "wrong\#args" + } + + # Set Key Definition + + DEFC skd {code str} {escb $code\;\"$str\"p} + + # Terminal title + + DEFC title {str} {esc \]0\;$str\007} + + # Switch to and from character/box graphics. + + DEFC gron {} {esc (0} + DEFC groff {} {esc (B} + + # Character graphics, box symbols + # - 4 corners, 4 t-junctions, + # one 4-way junction, 2 lines + + DEFC tlc {} {return [gron]l[groff]} ; # Top Left Corner + DEFC trc {} {return [gron]k[groff]} ; # Top Right Corner + DEFC brc {} {return [gron]j[groff]} ; # Bottom Right Corner + DEFC blc {} {return [gron]m[groff]} ; # Bottom Left Corner + + DEFC ltj {} {return [gron]t[groff]} ; # Left T Junction + DEFC ttj {} {return [gron]w[groff]} ; # Top T Junction + DEFC rtj {} {return [gron]u[groff]} ; # Right T Junction + DEFC btj {} {return [gron]v[groff]} ; # Bottom T Junction + + DEFC fwj {} {return [gron]n[groff]} ; # Four-Way Junction + + DEFC hl {} {return [gron]q[groff]} ; # Horizontal Line + DEFC vl {} {return [gron]x[groff]} ; # Vertical Line + + # Optimize character graphics. The generator commands above create + # way to many superfluous commands shifting into and out of the + # graphics mode. The command below removes all shifts which are + # not needed. To this end it also knows which characters will look + # the same in both modes, to handle strings created outside this + # package. + + DEFC groptim {string} { + variable grforw + variable grback + set offon [groff][gron] + set onoff [gron][groff] + while {![string equal $string [set new [string map \ + [list $offon {} $onoff {}] [string map \ + $grback [string map \ + $grforw $string]]]]]} { + set string $new + } + return $string + } + + ## + # ### ### ### ######### ######### ######### + + # ### ### ### ######### ######### ######### + ## Higher level operations + + # Clear screen <=> CursorHome + EraseDown + # Init (Fonts): Default ASCII, Alternate Graphics + # Show a block of text at a specific location. + + DEFC clear {} {return [ch][ed]} + DEFC init {} {return [scs0 B][scs1 0]} + + DEFC showat {r c text} { + if {![string length $text]} {return {}} + return [fcp $r $c][sca][join \ + [split $text \n] \ + [rca][cd][sca]][rca][cd] + } + + ## + # ### ### ### ######### ######### ######### + + # ### ### ### ######### ######### ######### + ## Attribute control (single attributes) + + foreach a [::term::ansi::code::attr::names] { + DEF sda_$a escb [::term::ansi::code::attr::$a]m + } + + ## + # ### ### ### ######### ######### ######### + return +} + +# ### ### ### ######### ######### ######### +## Data structures. + +namespace eval ::term::ansi::code::ctrl { + namespace import ::term::ansi::code::define + namespace import ::term::ansi::code::esc + namespace import ::term::ansi::code::escb + + variable grforw + variable grback + variable _ + + foreach _ { + ! \" # $ % & ' ( ) * + , - . / + 0 1 2 3 4 5 6 7 8 9 : ; < = > + ? @ 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 [ ^ + \\ ] + } { + lappend grforw \016$_ $_\016 + lappend grback $_\017 \017$_ + } + unset _ +} + +::term::ansi::code::ctrl::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code::ctrl 0.3 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/ansi/code/macros.tcl b/src/vendorlib/term/ansi/code/macros.tcl new file mode 100644 index 00000000..1f1d47d3 --- /dev/null +++ b/src/vendorlib/term/ansi/code/macros.tcl @@ -0,0 +1,93 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Higher level macros + +# ### ### ### ######### ######### ######### +## Requirements + +package require textutil::repeat +package require textutil::tabify +package require term::ansi::code::ctrl + +namespace eval ::term::ansi::code::macros {} + +# ### ### ### ######### ######### ######### +## API. Symbolic names. + +proc ::term::ansi::code::macros::import {{ns macros} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::code::macros::[join $args " ::term::ansi::code::macros::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## Higher level operations + +# Format a menu / framed block of text + +proc ::term::ansi::code::macros::menu {menu} { + # Menu = dict (label => char) + array set _ {} + set shift 0 + foreach {label c} $menu { + if {[string first $c $label] < 0} { + set shift 1 + break + } + } + set max 0 + foreach {label c} $menu { + set pos [string first $c $label] + if {$shift || ($pos < 0)} { + set xlabel "$c $label" + set pos 0 + } else { + set xlabel $label + } + set len [string length $xlabel] + if {$len > $max} {set max $len} + set _($label) " [string replace $xlabel $pos $pos \ + [cd::sda_fgred][cd::sda_bold][string index $xlabel $pos][cd::sda_reset]]" + } + + append ms [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n + foreach {l c} $menu {append ms $_($l)\n} + append ms [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] + + return [cd::groptim $ms] +} + +proc ::term::ansi::code::macros::frame {string} { + set lines [split [textutil::tabify::untabify2 $string] \n] + set max 0 + foreach l $lines { + if {[set len [string length $l]] > $max} {set max $len} + } + append fs [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n + foreach l $lines { + append fs [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl]\n + } + append fs [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] + return [cd::groptim $fs] +} + +## +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### +## Data structures. + +namespace eval ::term::ansi::code::macros { + term::ansi::code::ctrl::import cd + + namespace export menu frame +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::code::macros 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/ansi/ctrlunix.tcl b/src/vendorlib/term/ansi/ctrlunix.tcl new file mode 100644 index 00000000..675348c7 --- /dev/null +++ b/src/vendorlib/term/ansi/ctrlunix.tcl @@ -0,0 +1,91 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Control operations +## (Unix specific implementation). + +## This was originally taken from page 11820 (Pure Tcl Console Editor) +## of the Tcler's Wiki, however page 14693 (Reading a single character +## ...) is the same in a more self-contained manner. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::ansi::ctrl::unix {} + +# ### ### ### ######### ######### ######### +## Make command easily available + +proc ::term::ansi::ctrl::unix::import {{ns ctrl} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::ctrl::unix::[join $args " ::term::ansi::ctrl::unix::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## API + +# We use the <@stdin because stty works out what terminal to work with +# using standard input on some platforms. On others it prefers +# /dev/tty instead, but putting in the redirection makes the code more +# portable + +proc ::term::ansi::ctrl::unix::raw {} { + variable stty + exec $stty raw -echo <@stdin + return +} + +proc ::term::ansi::ctrl::unix::cooked {} { + variable stty + exec $stty -raw echo <@stdin + return +} + +proc ::term::ansi::ctrl::unix::columns {} { + variable tput + return [exec $tput cols <@stdin] +} + +proc ::term::ansi::ctrl::unix::rows {} { + variable tput + return [exec $tput lines <@stdin] +} + +# ### ### ### ######### ######### ######### +## Package setup + +proc ::term::ansi::ctrl::unix::INIT {} { + variable tput [auto_execok tput] + variable stty [auto_execok stty] + + if {($stty eq "/usr/ucb/stty") && + ($::tcl_platform(os) eq "SunOS")} { + set stty /usr/bin/stty + } + + if {($tput eq "") || ($stty eq "")} { + return -code error \ + "The external requirements for the \ + use of this package (tput, stty in \ + \$PATH) are not met." + } + return +} + +namespace eval ::term::ansi::ctrl::unix { + variable tput {} + variable stty {} + + namespace export columns rows raw cooked +} + +::term::ansi::ctrl::unix::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::ctrl::unix 0.1.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/ansi/send.tcl b/src/vendorlib/term/ansi/send.tcl new file mode 100644 index 00000000..d47f834a --- /dev/null +++ b/src/vendorlib/term/ansi/send.tcl @@ -0,0 +1,92 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - ANSI - Control codes + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.4 +package require term::send +package require term::ansi::code::ctrl + +namespace eval ::term::ansi::send {} + +# ### ### ### ######### ######### ######### +## Make command easily available + +proc ::term::ansi::send::import {{ns send} args} { + if {![llength $args]} {set args *} + set args ::term::ansi::send::[join $args " ::term::ansi::send::"] + uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] + return +} + +# ### ### ### ######### ######### ######### +## Internal - Setup. + +proc ::term::ansi::send::ChName {n} { + if {![string match *-* $n]} { + return ${n}ch + } + set nl [split $n -] + set stem [lindex $nl 0] + set sfx [join [lrange $nl 1 end] -] + return ${stem}ch-$sfx +} + +proc ::term::ansi::send::Args {n -> arv achv avv} { + upvar 1 $arv a $achv ach $avv av + set code ::term::ansi::code::ctrl::$n + set a [info args $code] + set av [expr { + [llength $a] + ? " \$[join $a { $}]" + : $a + }] + foreach a1 $a[set a {}] { + if {[info default $code $a1 default]} { + lappend a [list $a1 $default] + } else { + lappend a $a1 + } + } + set ach [linsert $a 0 ch] + return $code +} + +proc ::term::ansi::send::INIT {} { + foreach n [::term::ansi::code::ctrl::names] { + set nch [ChName $n] + set code [Args $n -> a ach av] + + if {[lindex $a end] eq "args"} { + # An args argument requires more care, and an eval + set av [lrange $av 0 end-1] + if {$av ne {}} {set av " $av"} + set gen "eval \[linsert \$args 0 $code$av\]" + #8.5: (written for clarity): set gen "$code$av {*}\$args" + } else { + set gen $code$av + } + + proc $n $a "wr \[$gen\]" ; namespace export $n + proc $nch $ach "wrch \$ch \[$gen\]" ; namespace export $nch + } + return +} + +namespace eval ::term::ansi::send { + namespace import ::term::send::wr + namespace import ::term::send::wrch + namespace export wr wrch +} + +::term::ansi::send::INIT + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::ansi::send 0.2 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/bind.tcl b/src/vendorlib/term/bind.tcl new file mode 100644 index 00000000..8342442d --- /dev/null +++ b/src/vendorlib/term/bind.tcl @@ -0,0 +1,132 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - string -> action mappings +## (bind objects). For use with 'receive listen'. +## In essence a DFA with tree structure. + +# ### ### ### ######### ######### ######### +## Requirements + +package require snit +package require term::receive +namespace eval ::term::receive::bind {} + +# ### ### ### ######### ######### ######### + +snit::type ::term::receive::bind { + + constructor {{dict {}}} { + foreach {str cmd} $dict {Register $str $cmd} + return + } + + method map {str cmd} { + Register $str $cmd + return + } + + method default {cmd} { + set default $cmd + return + } + + # ### ### ### ######### ######### ######### + ## + + method listen {{chan stdin}} { + #parray dfa + ::term::receive::listen $self $chan + return + } + + method unlisten {{chan stdin}} { + ::term::receive::unlisten $chan + return + } + + # ### ### ### ######### ######### ######### + ## + + variable default {} + variable state {} + + method reset {} { + set state {} + return + } + + method next {c} {Next $c ; return} + method process {str} { + foreach c [split $str {}] {Next $c} + return + } + + method eof {} {Eof ; return} + + proc Next {c} { + upvar 1 dfa dfa state state default default + set key [list $state $c] + + #puts -nonewline stderr "('$state' x '$c')" + + if {![info exists dfa($key)]} { + # Unknown sequence. Reset. Restart. + # Run it through the default action. + + if {$default ne ""} { + uplevel #0 [linsert $default end $state$c] + } + + #puts stderr =\ RESET + set state {} + } else { + foreach {what detail} $dfa($key) break + #puts -nonewline stderr "= $what '$detail'" + if {$what eq "t"} { + # Incomplete sequence. Next state. + set state $detail + #puts stderr " goto ('$state')" + } elseif {$what eq "a"} { + # Action, then reset. + set state {} + #puts stderr " run ($detail)" + uplevel #0 [linsert $detail end $state$c] + } else { + return -code error \ + "Internal error. Bad DFA." + } + } + return + } + + proc Eof {} {} + + # ### ### ### ######### ######### ######### + ## + + proc Register {str cmd} { + upvar 1 dfa dfa + set prefix {} + set last {{} {}} + foreach c [split $str {}] { + set key [list $prefix $c] + set next $prefix$c + set dfa($key) [list t $next] + set last $key + set prefix $next + } + set dfa($last) [list a $cmd] + } + variable dfa -array {} + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::receive::bind 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/imenu.tcl b/src/vendorlib/term/imenu.tcl new file mode 100644 index 00000000..42a7fab5 --- /dev/null +++ b/src/vendorlib/term/imenu.tcl @@ -0,0 +1,202 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - string -> action mappings +## (menu objects). For use with 'receive listen'. +## In essence a DFA with tree structure. + +# ### ### ### ######### ######### ######### +## Requirements + +package require snit +package require textutil::repeat +package require textutil::tabify +package require term::ansi::send +package require term::receive::bind +package require term::ansi::code::ctrl + +namespace eval ::term::receive::menu {} + +# ### ### ### ######### ######### ######### + +snit::type ::term::interact::menu { + + option -in -default stdin + option -out -default stdout + option -column -default 0 + option -line -default 0 + option -height -default 25 + option -actions -default {} + option -hilitleft -default 0 + option -hilitright -default end + option -framed -default 0 -readonly 1 + + # ### ### ### ######### ######### ######### + ## + + constructor {dict args} { + $self configurelist $args + Save $dict + + install bind using ::term::receive::bind \ + ${selfns}::bind $options(-actions) + + $bind map [cd::cu] [mymethod Up] + $bind map [cd::cd] [mymethod Down] + $bind map \n [mymethod Select] + #$bind default [mymethod DEF] + + return + } + + # ### ### ### ######### ######### ######### + ## + + method interact {} { + Show + $bind listen $options(-in) + vwait [myvar done] + $bind unlisten $options(-in) + return $map($done) + } + + method done {} {set done $at ; return} + method clear {} {Clear ; return} + + # ### ### ### ######### ######### ######### + ## + + component bind + + # ### ### ### ######### ######### ######### + ## + + variable map -array {} + variable header + variable labels + variable footer + variable empty + + proc Save {dict} { + upvar 1 header header labels labels footer footer + upvar 1 empty empty at at map map top top + upvar 1 options(-height) height + + set max 0 + foreach {l code} $dict { + if {[set len [string length $l]] > $max} {set max $len} + } + + set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]] + set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]] + + set labels {} + set at 0 + foreach {l code} $dict { + set map($at) $code + lappend labels ${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]] + incr at + } + + set h $height + if {$h > [llength $labels]} {set h [llength $labels]} + + set eline " [textutil::repeat::strRepeat { } $max]" + set empty $eline + for {set i 0} {$i <= $h} {incr i} { + append empty \n$eline + } + + set at 0 + set top 0 + return + } + + variable top 0 + variable at 0 + variable done . + + proc Show {} { + upvar 1 header header labels labels footer footer at at + upvar 1 options(-in) in options(-column) col top top + upvar 1 options(-out) out options(-line) row + upvar 1 options(-height) height options(-framed) framed + upvar 1 options(-hilitleft) left + upvar 1 options(-hilitright) right + + set bot [expr {$top + $height - 1}] + set fr [expr {$framed ? [cd::vl] : { }}] + + set text $header\n + set i $top + foreach l [lrange $labels $top $bot] { + append text $fr + if {$i != $at} { + append text $l + } else { + append text [string replace $l $left $right \ + [cd::sda_revers][string range $l $left $right][cd::sda_reset]] + } + append text $fr \n + incr i + } + append text $footer + + vt::wrch $out [cd::showat $row $col $text] + return + } + + proc Clear {} { + upvar 1 empty empty options(-column) col + upvar 1 options(-out) out options(-line) row + + vt::wrch $out [cd::showat $row $col $empty] + return + } + + # ### ### ### ######### ######### ######### + ## + + method Up {str} { + if {$at == 0} return + incr at -1 + if {$at < $top} {incr top -1} + Show + return + } + + method Down {str} { + upvar 0 options(-height) height + if {$at == ([llength $labels]-1)} return + incr at + set bot [expr {$top + $height - 1}] + if {$at > $bot} {incr top} + Show + return + } + + method Select {str} { + $self done + return + } + + method DEF {str} { + puts stderr "($str)" + exit + } + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::term::interact::menu { + term::ansi::code::ctrl::import cd + term::ansi::send::import vt +} + +package provide term::interact::menu 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/ipager.tcl b/src/vendorlib/term/ipager.tcl new file mode 100644 index 00000000..59c1c580 --- /dev/null +++ b/src/vendorlib/term/ipager.tcl @@ -0,0 +1,206 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - string -> action mappings +## (pager objects). For use with 'receive listen'. +## In essence a DFA with tree structure. + +# ### ### ### ######### ######### ######### +## Requirements + +package require snit +package require textutil::repeat +package require textutil::tabify +package require term::ansi::send +package require term::receive::bind +package require term::ansi::code::ctrl + +namespace eval ::term::receive::pager {} + +# ### ### ### ######### ######### ######### + +snit::type ::term::interact::pager { + + option -in -default stdin + option -out -default stdout + option -column -default 0 + option -line -default 0 + option -height -default 25 + option -actions -default {} + + # ### ### ### ######### ######### ######### + ## + + constructor {str args} { + $self configurelist $args + Save $str + + install bind using ::term::receive::bind \ + ${selfns}::bind $options(-actions) + + $bind map [cd::cu] [mymethod Up] + $bind map [cd::cd] [mymethod Down] + $bind map \033\[5~ [mymethod PageUp] + $bind map \033\[6~ [mymethod PageDown] + $bind map \n [mymethod Done] + #$bind default [mymethod DEF] + + return + } + + # ### ### ### ######### ######### ######### + ## + + method interact {} { + Show + $bind listen $options(-in) + set interacting 1 + vwait [myvar done] + set interacting 0 + $bind unlisten $options(-in) + return + } + + method done {} {set done . ; return} + method clear {} {Clear ; return} + + method text {str} { + if {$interacting} {Clear} + Save $str + if {$interacting} {Show} + return + } + + # ### ### ### ######### ######### ######### + ## + + component bind + + # ### ### ### ######### ######### ######### + ## + + variable header + variable text + variable footer + variable empty + + proc Save {str} { + upvar 1 header header text text footer footer maxline maxline + upvar 1 options(-height) height empty empty at at + + set lines [split [textutil::tabify::untabify2 $str] \n] + + set max 0 + foreach l $lines { + if {[set len [string length $l]] > $max} {set max $len} + } + + set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]] + set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]] + + set text {} + foreach l $lines { + lappend text [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl] + } + + set h $height + if {$h > [llength $text]} {set h [llength $text]} + + set eline " [textutil::repeat::strRepeat { } $max]" + set empty $eline + for {set i 0} {$i <= $h} {incr i} { + append empty \n$eline + } + + set maxline [expr {[llength $text] - $height}] + if {$maxline < 0} {set maxline 0} + set at 0 + return + } + + variable interacting 0 + variable at 0 + variable maxline -1 + variable done . + + proc Show {} { + upvar 1 header header text text footer footer at at + upvar 1 options(-in) in options(-column) col + upvar 1 options(-out) out options(-line) row + upvar 1 options(-height) height + + set to [expr {$at + $height -1}] + + vt::wrch $out [cd::showat $row $col \ + $header\n[join [lrange $text $at $to] \n]\n$footer] + return + } + + proc Clear {} { + upvar 1 empty empty options(-column) col + upvar 1 options(-out) out options(-line) row + + vt::wrch $out [cd::showat $row $col $empty] + return + } + + # ### ### ### ######### ######### ######### + ## + + method Up {str} { + if {$at == 0} return + incr at -1 + Show + return + } + + method Down {str} { + if {$at >= $maxline} return + incr at + Show + return + } + + method PageUp {str} { + set newat [expr {$at - $options(-height) + 1}] + if {$newat < 0} {set newat 0} + if {$newat == $at} return + set at $newat + Show + return + } + + method PageDown {str} { + set newat [expr {$at + $options(-height) - 1}] + if {$newat >= $maxline} {set newat $maxline} + if {$newat == $at} return + set at $newat + Show + return + } + + method Done {str} { + $self done + return + } + + method DEF {str} { + puts stderr "($str)" + exit + } + + ## + # ### ### ### ######### ######### ######### +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::term::interact::pager { + term::ansi::code::ctrl::import cd + term::ansi::send::import vt +} + +package provide term::interact::pager 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/pkgIndex.tcl b/src/vendorlib/term/pkgIndex.tcl new file mode 100644 index 00000000..bd06c3a8 --- /dev/null +++ b/src/vendorlib/term/pkgIndex.tcl @@ -0,0 +1,13 @@ +if {![package vsatisfies [package provide Tcl] 8.4]} return +package ifneeded term 0.1 [list source [file join $dir term.tcl]] +package ifneeded term::ansi::code 0.2 [list source [file join $dir ansi/code.tcl]] +package ifneeded term::ansi::code::attr 0.1 [list source [file join $dir ansi/code/attr.tcl]] +package ifneeded term::ansi::code::ctrl 0.3 [list source [file join $dir ansi/code/ctrl.tcl]] +package ifneeded term::ansi::code::macros 0.1 [list source [file join $dir ansi/code/macros.tcl]] +package ifneeded term::ansi::ctrl::unix 0.1.1 [list source [file join $dir ansi/ctrlunix.tcl]] +package ifneeded term::ansi::send 0.2 [list source [file join $dir ansi/send.tcl]] +package ifneeded term::interact::menu 0.1 [list source [file join $dir imenu.tcl]] +package ifneeded term::interact::pager 0.1 [list source [file join $dir ipager.tcl]] +package ifneeded term::receive 0.1 [list source [file join $dir receive.tcl]] +package ifneeded term::receive::bind 0.1 [list source [file join $dir bind.tcl]] +package ifneeded term::send 0.1 [list source [file join $dir send.tcl]] diff --git a/src/vendorlib/term/receive.tcl b/src/vendorlib/term/receive.tcl new file mode 100644 index 00000000..393549c2 --- /dev/null +++ b/src/vendorlib/term/receive.tcl @@ -0,0 +1,60 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - Generic receiver operations + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::receive {} + +# ### ### ### ######### ######### ######### +## API. Read character from specific channel, +## or default (stdin). Processing of +## character sequences. + +proc ::term::receive::getch {{chan stdin}} { + return [read $chan 1] +} + +proc ::term::receive::listen {cmd {chan stdin}} { + fconfigure $chan -blocking 0 + fileevent $chan readable \ + [list ::term::receive::Foreach $chan $cmd] + return +} + +proc ::term::receive::unlisten {{chan stdin}} { + fileevent $chan readable {} + return +} + +# ### ### ### ######### ######### ######### +## Internals + +proc ::term::receive::Foreach {chan cmd} { + set string [read $chan] + if {[string length $string]} { + #puts stderr "F($string)" + uplevel #0 [linsert $cmd end process $string] + } + if {[eof $chan]} { + close $chan + uplevel #0 [linsert $cmd end eof] + } + return +} + +# ### ### ### ######### ######### ######### +## Initialization + +namespace eval ::term::receive { + namespace export getch listen +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::receive 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/send.tcl b/src/vendorlib/term/send.tcl new file mode 100644 index 00000000..c3e235de --- /dev/null +++ b/src/vendorlib/term/send.tcl @@ -0,0 +1,34 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - Generic sender operations + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term::send {} + +# ### ### ### ######### ######### ######### +## API. Write to channel, or default (stdout) + +proc ::term::send::wr {str} { + wrch stdout $str + return +} + +proc ::term::send::wrch {ch str} { + puts -nonewline $ch $str + flush $ch + return +} + +namespace eval ::term::send { + namespace export wr wrch +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term::send 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendorlib/term/term.tcl b/src/vendorlib/term/term.tcl new file mode 100644 index 00000000..01d4630c --- /dev/null +++ b/src/vendorlib/term/term.tcl @@ -0,0 +1,19 @@ +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Terminal packages - Main :: Generic operations + +# Currently we have no generica at all. We make the package, but it +# provides nothing for now. + +# ### ### ### ######### ######### ######### +## Requirements + +namespace eval ::term {} + +# ### ### ### ######### ######### ######### +## Ready + +package provide term 0.1 + +## +# ### ### ### ######### ######### ######### diff --git a/src/vendormodules/cmdline-1.5.2.tm b/src/vendormodules/cmdline-1.5.2.tm new file mode 100644 index 00000000..4e5e1df9 --- /dev/null +++ b/src/vendormodules/cmdline-1.5.2.tm @@ -0,0 +1,933 @@ +# cmdline.tcl -- +# +# This package provides a utility for parsing command line +# arguments that are processed by our various applications. +# It also includes a utility routine to determine the +# application name for use in command line errors. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2001-2015 by Andreas Kupries . +# Copyright (c) 2003 by David N. Welton +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5- +package provide cmdline 1.5.2 + +namespace eval ::cmdline { + namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ + getKnownOptions usage +} + +# ::cmdline::getopt -- +# +# The cmdline::getopt works in a fashion like the standard +# C based getopt function. Given an option string and a +# pointer to an array or args this command will process the +# first argument and return info on how to proceed. +# +# Arguments: +# argvVar Name of the argv list that you +# want to process. If options are found the +# arg list is modified and the processed arguments +# are removed from the start of the list. +# optstring A list of command options that the application +# will accept. If the option ends in ".arg" the +# getopt routine will use the next argument as +# an argument to the option. Otherwise the option +# is a boolean that is set to 1 if present. +# optVar The variable pointed to by optVar +# contains the option that was found (without the +# leading '-' and without the .arg extension). +# valVar Upon success, the variable pointed to by valVar +# contains the value for the specified option. +# This value comes from the command line for .arg +# options, otherwise the value is 1. +# If getopt fails, the valVar is filled with an +# error message. +# +# Results: +# The getopt function returns 1 if an option was found, 0 if no more +# options were found, and -1 if an error occurred. + +proc ::cmdline::getopt {argvVar optstring optVar valVar} { + upvar 1 $argvVar argsList + upvar 1 $optVar option + upvar 1 $valVar value + + set result [getKnownOpt argsList $optstring option value] + + if {$result < 0} { + # Collapse unknown-option error into any-other-error result. + set result -1 + } + return $result +} + +# ::cmdline::getKnownOpt -- +# +# The cmdline::getKnownOpt works in a fashion like the standard +# C based getopt function. Given an option string and a +# pointer to an array or args this command will process the +# first argument and return info on how to proceed. +# +# Arguments: +# argvVar Name of the argv list that you +# want to process. If options are found the +# arg list is modified and the processed arguments +# are removed from the start of the list. Note that +# unknown options and the args that follow them are +# left in this list. +# optstring A list of command options that the application +# will accept. If the option ends in ".arg" the +# getopt routine will use the next argument as +# an argument to the option. Otherwise the option +# is a boolean that is set to 1 if present. +# optVar The variable pointed to by optVar +# contains the option that was found (without the +# leading '-' and without the .arg extension). +# valVar Upon success, the variable pointed to by valVar +# contains the value for the specified option. +# This value comes from the command line for .arg +# options, otherwise the value is 1. +# If getopt fails, the valVar is filled with an +# error message. +# +# Results: +# The getKnownOpt function returns 1 if an option was found, +# 0 if no more options were found, -1 if an unknown option was +# encountered, and -2 if any other error occurred. + +proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { + upvar 1 $argvVar argsList + upvar 1 $optVar option + upvar 1 $valVar value + + # default settings for a normal return + set value "" + set option "" + set result 0 + + # check if we're past the end of the args list + if {[llength $argsList] != 0} { + + # if we got -- or an option that doesn't begin with -, return (skipping + # the --). otherwise process the option arg. + switch -glob -- [set arg [lindex $argsList 0]] { + "--" { + set argsList [lrange $argsList 1 end] + } + "--*" - + "-*" { + set option [string range $arg 1 end] + if {[string equal [string range $option 0 0] "-"]} { + set option [string range $arg 2 end] + } + + # support for format: [-]-option=value + set idx [string first "=" $option 1] + if {$idx != -1} { + set _val [string range $option [expr {$idx+1}] end] + set option [string range $option 0 [expr {$idx-1}]] + } + + if {[lsearch -exact $optstring $option] != -1} { + # Booleans are set to 1 when present + set value 1 + set result 1 + set argsList [lrange $argsList 1 end] + } elseif {[lsearch -exact $optstring "$option.arg"] != -1} { + set result 1 + set argsList [lrange $argsList 1 end] + + if {[info exists _val]} { + set value $_val + } elseif {[llength $argsList]} { + set value [lindex $argsList 0] + set argsList [lrange $argsList 1 end] + } else { + set value "Option \"$option\" requires an argument" + set result -2 + } + } else { + # Unknown option. + set value "Illegal option \"-$option\"" + set result -1 + } + } + default { + # Skip ahead + } + } + } + + return $result +} + +# ::cmdline::getoptions -- +# +# Process a set of command line options, filling in defaults +# for those not specified. This also generates an error message +# that lists the allowed flags if an incorrect flag is specified. +# +# Arguments: +# argvVar The name of the argument list, typically argv. +# We remove all known options and their args from it. +# In other words, after the call to this command the +# referenced variable contains only the non-options, +# and unknown options. +# optlist A list-of-lists where each element specifies an option +# in the form: +# (where flag takes no argument) +# flag comment +# +# (or where flag takes an argument) +# flag default comment +# +# If flag ends in ".arg" then the value is taken from the +# command line. Otherwise it is a boolean and appears in +# the result if present on the command line. If flag ends +# in ".secret", it will not be displayed in the usage. +# usage Text to include in the usage display. Defaults to +# "options:" +# +# Results +# Name value pairs suitable for using with array set. +# A modified `argvVar`. + +proc ::cmdline::getoptions {argvVar optlist {usage options:}} { + upvar 1 $argvVar argv + + set opts [GetOptionDefaults $optlist result] + + set argc [llength $argv] + while {[set err [getopt argv $opts opt arg]]} { + if {$err < 0} { + set result(?) "" + break + } + set result($opt) $arg + } + if {[info exist result(?)] || [info exists result(help)]} { + Error [usage $optlist $usage] USAGE + } + return [array get result] +} + +# ::cmdline::getKnownOptions -- +# +# Process a set of command line options, filling in defaults +# for those not specified. This ignores unknown flags, but generates +# an error message that lists the correct usage if a known option +# is used incorrectly. +# +# Arguments: +# argvVar The name of the argument list, typically argv. This +# We remove all known options and their args from it. +# In other words, after the call to this command the +# referenced variable contains only the non-options, +# and unknown options. +# optlist A list-of-lists where each element specifies an option +# in the form: +# flag default comment +# If flag ends in ".arg" then the value is taken from the +# command line. Otherwise it is a boolean and appears in +# the result if present on the command line. If flag ends +# in ".secret", it will not be displayed in the usage. +# usage Text to include in the usage display. Defaults to +# "options:" +# +# Results +# Name value pairs suitable for using with array set. +# A modified `argvVar`. + +proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { + upvar 1 $argvVar argv + + set opts [GetOptionDefaults $optlist result] + + # As we encounter them, keep the unknown options and their + # arguments in this list. Before we return from this procedure, + # we'll prepend these args to the argList so that the application + # doesn't lose them. + + set unknownOptions [list] + + set argc [llength $argv] + while {[set err [getKnownOpt argv $opts opt arg]]} { + if {$err == -1} { + # Unknown option. + + # Skip over any non-option items that follow it. + # For now, add them to the list of unknownOptions. + lappend unknownOptions [lindex $argv 0] + set argv [lrange $argv 1 end] + while {([llength $argv] != 0) \ + && ![string match "-*" [lindex $argv 0]]} { + lappend unknownOptions [lindex $argv 0] + set argv [lrange $argv 1 end] + } + } elseif {$err == -2} { + set result(?) "" + break + } else { + set result($opt) $arg + } + } + + # Before returning, prepend the any unknown args back onto the + # argList so that the application doesn't lose them. + set argv [concat $unknownOptions $argv] + + if {[info exist result(?)] || [info exists result(help)]} { + Error [usage $optlist $usage] USAGE + } + return [array get result] +} + +# ::cmdline::GetOptionDefaults -- +# +# This internal procedure processes the option list (that was passed to +# the getopt or getKnownOpt procedure). The defaultArray gets an index +# for each option in the option list, the value of which is the option's +# default value. +# +# Arguments: +# optlist A list-of-lists where each element specifies an option +# in the form: +# flag default comment +# If flag ends in ".arg" then the value is taken from the +# command line. Otherwise it is a boolean and appears in +# the result if present on the command line. If flag ends +# in ".secret", it will not be displayed in the usage. +# defaultArrayVar The name of the array in which to put argument defaults. +# +# Results +# Name value pairs suitable for using with array set. + +proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { + upvar 1 $defaultArrayVar result + + set opts {? help} + foreach opt $optlist { + set name [lindex $opt 0] + if {[regsub -- {\.secret$} $name {} name] == 1} { + # Need to hide this from the usage display and getopt + } + lappend opts $name + if {[regsub -- {\.arg$} $name {} name] == 1} { + + # Set defaults for those that take values. + + set default [lindex $opt 1] + set result($name) $default + } else { + # The default for booleans is false + set result($name) 0 + } + } + return $opts +} + +# ::cmdline::usage -- +# +# Generate an error message that lists the allowed flags. +# +# Arguments: +# optlist As for cmdline::getoptions +# usage Text to include in the usage display. Defaults to +# "options:" +# +# Results +# A formatted usage message + +proc ::cmdline::usage {optlist {usage {options:}}} { + set str "[getArgv0] $usage\n" + set longest 20 + set lines {} + foreach opt [concat $optlist \ + {{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { + set name "-[lindex $opt 0]" + if {[regsub -- {\.secret$} $name {} name] == 1} { + # Hidden option + continue + } + if {[regsub -- {\.arg$} $name {} name] == 1} { + append name " value" + set desc "[lindex $opt 2] <[lindex $opt 1]>" + } else { + set desc "[lindex $opt 1]" + } + set n [string length $name] + if {$n > $longest} { set longest $n } + # max not available before 8.5 - set longest [expr {max($longest, )}] + lappend lines $name $desc + } + foreach {name desc} $lines { + append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" + } + + return $str +} + +# ::cmdline::getfiles -- +# +# Given a list of file arguments from the command line, compute +# the set of valid files. On windows, file globbing is performed +# on each argument. On Unix, only file existence is tested. If +# a file argument produces no valid files, a warning is optionally +# generated. +# +# This code also uses the full path for each file. If not +# given it prepends [pwd] to the filename. This ensures that +# these files will never conflict with files in our zip file. +# +# Arguments: +# patterns The file patterns specified by the user. +# quiet If this flag is set, no warnings will be generated. +# +# Results: +# Returns the list of files that match the input patterns. + +proc ::cmdline::getfiles {patterns quiet} { + set result {} + if {$::tcl_platform(platform) == "windows"} { + foreach pattern $patterns { + set pat [file join $pattern] + set files [glob -nocomplain -- $pat] + if {$files == {}} { + if {! $quiet} { + puts stdout "warning: no files match \"$pattern\"" + } + } else { + foreach file $files { + lappend result $file + } + } + } + } else { + set result $patterns + } + set files {} + foreach file $result { + # Make file an absolute path so that we will never conflict + # with files that might be contained in our zip file. + set fullPath [file join [pwd] $file] + + if {[file isfile $fullPath]} { + lappend files $fullPath + } elseif {! $quiet} { + puts stdout "warning: no files match \"$file\"" + } + } + return $files +} + +# ::cmdline::getArgv0 -- +# +# This command returns the "sanitized" version of argv0. It will strip +# off the leading path and remove the ".bin" extensions that our apps +# use because they must be wrapped by a shell script. +# +# Arguments: +# None. +# +# Results: +# The application name that can be used in error messages. + +proc ::cmdline::getArgv0 {} { + global argv0 + + set name [file tail $argv0] + return [file rootname $name] +} + +## +# ### ### ### ######### ######### ######### +## +# Now the typed versions of the above commands. +## +# ### ### ### ######### ######### ######### +## + +# typedCmdline.tcl -- +# +# This package provides a utility for parsing typed command +# line arguments that may be processed by various applications. +# +# Copyright (c) 2000 by Ross Palmer Mohn. +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ + +namespace eval ::cmdline { + namespace export typedGetopt typedGetoptions typedUsage + + # variable cmdline::charclasses -- + # + # Create regexp list of allowable character classes + # from "string is" error message. + # + # Results: + # String of character class names separated by "|" characters. + + variable charclasses + #checker exclude badKey + catch {string is . .} charclasses + variable dummy + regexp -- {must be (.+)$} $charclasses dummy charclasses + regsub -all -- {, (or )?} $charclasses {|} charclasses + unset dummy +} + +# ::cmdline::typedGetopt -- +# +# The cmdline::typedGetopt works in a fashion like the standard +# C based getopt function. Given an option string and a +# pointer to a list of args this command will process the +# first argument and return info on how to proceed. In addition, +# you may specify a type for the argument to each option. +# +# Arguments: +# argvVar Name of the argv list that you want to process. +# If options are found, the arg list is modified +# and the processed arguments are removed from the +# start of the list. +# +# optstring A list of command options that the application +# will accept. If the option ends in ".xxx", where +# xxx is any valid character class to the tcl +# command "string is", then typedGetopt routine will +# use the next argument as a typed argument to the +# option. The argument must match the specified +# character classes (e.g. integer, double, boolean, +# xdigit, etc.). Alternatively, you may specify +# ".arg" for an untyped argument. +# +# optVar Upon success, the variable pointed to by optVar +# contains the option that was found (without the +# leading '-' and without the .xxx extension). If +# typedGetopt fails the variable is set to the empty +# string. SOMETIMES! Different for each -value! +# +# argVar Upon success, the variable pointed to by argVar +# contains the argument for the specified option. +# If typedGetopt fails, the variable is filled with +# an error message. +# +# Argument type syntax: +# Option that takes no argument. +# foo +# +# Option that takes a typeless argument. +# foo.arg +# +# Option that takes a typed argument. Allowable types are all +# valid character classes to the tcl command "string is". +# Currently must be one of alnum, alpha, ascii, control, +# boolean, digit, double, false, graph, integer, lower, print, +# punct, space, true, upper, wordchar, or xdigit. +# foo.double +# +# Option that takes an argument from a list. +# foo.(bar|blat) +# +# Argument quantifier syntax: +# Option that takes an optional argument. +# foo.arg? +# +# Option that takes a list of arguments terminated by "--". +# foo.arg+ +# +# Option that takes an optional list of arguments terminated by "--". +# foo.arg* +# +# Argument quantifiers work on all argument types, so, for +# example, the following is a valid option specification. +# foo.(bar|blat|blah)? +# +# Argument syntax miscellany: +# Options may be specified on the command line using a unique, +# shortened version of the option name. Given that program foo +# has an option list of {bar.alpha blah.arg blat.double}, +# "foo -b fob" returns an error, but "foo -ba fob" +# successfully returns {bar fob} +# +# Results: +# The typedGetopt function returns one of the following: +# 1 a valid option was found +# 0 no more options found to process +# -1 invalid option +# -2 missing argument to a valid option +# -3 argument to a valid option does not match type +# +# Known Bugs: +# When using options which include special glob characters, +# you must use the exact option. Abbreviating it can cause +# an error in the "cmdline::prefixSearch" procedure. + +proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { + variable charclasses + + upvar $argvVar argsList + + upvar $optVar retvar + upvar $argVar optarg + + # default settings for a normal return + set optarg "" + set retvar "" + set retval 0 + + # check if we're past the end of the args list + if {[llength $argsList] != 0} { + + # if we got -- or an option that doesn't begin with -, return (skipping + # the --). otherwise process the option arg. + switch -glob -- [set arg [lindex $argsList 0]] { + "--" { + set argsList [lrange $argsList 1 end] + } + + "-*" { + # Create list of options without their argument extensions + + set optstr "" + foreach str $optstring { + lappend optstr [file rootname $str] + } + + set _opt [string range $arg 1 end] + + set i [prefixSearch $optstr [file rootname $_opt]] + if {$i != -1} { + set opt [lindex $optstring $i] + + set quantifier "none" + if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { + set opt [string range $opt 0 end-1] + } + + if {[string first . $opt] == -1} { + set retval 1 + set retvar $opt + set argsList [lrange $argsList 1 end] + + } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] + || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { + if {[string equal arg $charclass]} { + set type arg + } elseif {[regexp -- "^($charclasses)\$" $charclass]} { + set type class + } else { + set type oneof + } + + set argsList [lrange $argsList 1 end] + set opt [file rootname $opt] + + while {1} { + if {[llength $argsList] == 0 + || [string equal "--" [lindex $argsList 0]]} { + if {[string equal "--" [lindex $argsList 0]]} { + set argsList [lrange $argsList 1 end] + } + + set oneof "" + if {$type == "arg"} { + set charclass an + } elseif {$type == "oneof"} { + set oneof ", one of $charclass" + set charclass an + } + + if {$quantifier == "?"} { + set retval 1 + set retvar $opt + set optarg "" + } elseif {$quantifier == "+"} { + set retvar $opt + if {[llength $optarg] < 1} { + set retval -2 + set optarg "Option requires at least one $charclass argument$oneof -- $opt" + } else { + set retval 1 + } + } elseif {$quantifier == "*"} { + set retval 1 + set retvar $opt + } else { + set optarg "Option requires $charclass argument$oneof -- $opt" + set retvar $opt + set retval -2 + } + set quantifier "" + } elseif {($type == "arg") + || (($type == "oneof") + && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) + || (($type == "class") + && [string is $charclass [lindex $argsList 0]])} { + set retval 1 + set retvar $opt + lappend optarg [lindex $argsList 0] + set argsList [lrange $argsList 1 end] + } else { + set oneof "" + if {$type == "arg"} { + set charclass an + } elseif {$type == "oneof"} { + set oneof ", one of $charclass" + set charclass an + } + set optarg "Option requires $charclass argument$oneof -- $opt" + set retvar $opt + set retval -3 + + if {$quantifier == "?"} { + set retval 1 + set optarg "" + } + set quantifier "" + } + if {![regexp -- {[+*]} $quantifier]} { + break; + } + } + } else { + Error \ + "Illegal option type specification: must be one of $charclasses" \ + BAD OPTION TYPE + } + } else { + set optarg "Illegal option -- $_opt" + set retvar $_opt + set retval -1 + } + } + default { + # Skip ahead + } + } + } + + return $retval +} + +# ::cmdline::typedGetoptions -- +# +# Process a set of command line options, filling in defaults +# for those not specified. This also generates an error message +# that lists the allowed options if an incorrect option is +# specified. +# +# Arguments: +# argvVar The name of the argument list, typically argv +# optlist A list-of-lists where each element specifies an option +# in the form: +# +# option default comment +# +# Options formatting is as described for the optstring +# argument of typedGetopt. Default is for optionally +# specifying a default value. Comment is for optionally +# specifying a comment for the usage display. The +# options "--", "-help", and "-?" are automatically included +# in optlist. +# +# Argument syntax miscellany: +# Options formatting and syntax is as described in typedGetopt. +# There are two additional suffixes that may be applied when +# passing options to typedGetoptions. +# +# You may add ".multi" as a suffix to any option. For options +# that take an argument, this means that the option may be used +# more than once on the command line and that each additional +# argument will be appended to a list, which is then returned +# to the application. +# foo.double.multi +# +# If a non-argument option is specified as ".multi", it is +# toggled on and off for each time it is used on the command +# line. +# foo.multi +# +# If an option specification does not contain the ".multi" +# suffix, it is not an error to use an option more than once. +# In this case, the behavior for options with arguments is that +# the last argument is the one that will be returned. For +# options that do not take arguments, using them more than once +# has no additional effect. +# +# Options may also be hidden from the usage display by +# appending the suffix ".secret" to any option specification. +# Please note that the ".secret" suffix must be the last suffix, +# after any argument type specification and ".multi" suffix. +# foo.xdigit.multi.secret +# +# Results +# Name value pairs suitable for using with array set. + +proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { + variable charclasses + + upvar 1 $argvVar argv + + set opts {? help} + foreach opt $optlist { + set name [lindex $opt 0] + if {[regsub -- {\.secret$} $name {} name] == 1} { + # Remove this extension before passing to typedGetopt. + } + if {[regsub -- {\.multi$} $name {} name] == 1} { + # Remove this extension before passing to typedGetopt. + + regsub -- {\..*$} $name {} temp + set multi($temp) 1 + } + lappend opts $name + if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { + # Set defaults for those that take values. + # Booleans are set just by being present, or not + + set dflt [lindex $opt 1] + if {$dflt != {}} { + set defaults($name) $dflt + } + } + } + set argc [llength $argv] + while {[set err [typedGetopt argv $opts opt arg]]} { + if {$err == 1} { + if {[info exists result($opt)] + && [info exists multi($opt)]} { + # Toggle boolean options or append new arguments + + if {$arg == ""} { + unset result($opt) + } else { + set result($opt) "$result($opt) $arg" + } + } else { + set result($opt) "$arg" + } + } elseif {($err == -1) || ($err == -3)} { + Error [typedUsage $optlist $usage] USAGE + } elseif {$err == -2 && ![info exists defaults($opt)]} { + Error [typedUsage $optlist $usage] USAGE + } + } + if {[info exists result(?)] || [info exists result(help)]} { + Error [typedUsage $optlist $usage] USAGE + } + foreach {opt dflt} [array get defaults] { + if {![info exists result($opt)]} { + set result($opt) $dflt + } + } + return [array get result] +} + +# ::cmdline::typedUsage -- +# +# Generate an error message that lists the allowed flags, +# type of argument taken (if any), default value (if any), +# and an optional description. +# +# Arguments: +# optlist As for cmdline::typedGetoptions +# +# Results +# A formatted usage message + +proc ::cmdline::typedUsage {optlist {usage {options:}}} { + variable charclasses + + set str "[getArgv0] $usage\n" + set longest 20 + set lines {} + foreach opt [concat $optlist \ + {{help "Print this message"} {? "Print this message"}}] { + set name "-[lindex $opt 0]" + if {[regsub -- {\.secret$} $name {} name] == 1} { + # Hidden option + continue + } + + if {[regsub -- {\.multi$} $name {} name] == 1} { + # Display something about multiple options + } + + if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || + [regexp -- {\.\(([^)]+)\)} $opt dummy charclass] + } { + regsub -- "\\..+\$" $name {} name + append name " $charclass" + set desc [lindex $opt 2] + set default [lindex $opt 1] + if {$default != ""} { + append desc " <$default>" + } + } else { + set desc [lindex $opt 1] + } + lappend accum $name $desc + set n [string length $name] + if {$n > $longest} { set longest $n } + # max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] + } + foreach {name desc} $accum { + append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" + } + return $str +} + +# ::cmdline::prefixSearch -- +# +# Search a Tcl list for a pattern; searches first for an exact match, +# and if that fails, for a unique prefix that matches the pattern +# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" +# +# Arguments: +# list list of words +# pattern word to search for +# +# Results: +# Index of found word is returned. If no exact match or +# unique short version is found then -1 is returned. + +proc ::cmdline::prefixSearch {list pattern} { + # Check for an exact match + + if {[set pos [::lsearch -exact $list $pattern]] > -1} { + return $pos + } + + # Check for a unique short version + + set slist [lsort $list] + if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { + # What if there is nothing for the check variable? + + set check [lindex $slist [expr {$pos + 1}]] + if {[string first $pattern $check] != 0} { + return [::lsearch -exact $list [lindex $slist $pos]] + } + } + return -1 +} +# ::cmdline::Error -- +# +# Internal helper to throw errors with a proper error-code attached. +# +# Arguments: +# message text of the error message to throw. +# args additional parts of the error code to use, +# with CMDLINE as basic prefix added by this command. +# +# Results: +# An error is thrown, always. + +proc ::cmdline::Error {message args} { + return -code error -errorcode [linsert $args 0 CMDLINE] $message +} diff --git a/src/vendormodules/csv-0.9.tm b/src/vendormodules/csv-0.9.tm new file mode 100644 index 00000000..60f8133a --- /dev/null +++ b/src/vendormodules/csv-0.9.tm @@ -0,0 +1,787 @@ +# csv.tcl -- +# +# Tcl implementations of CSV reader and writer +# +# Copyright (c) 2001 by Jeffrey Hobbs +# Copyright (c) 2001-2013,2022 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5 +package provide csv 0.9 + +namespace eval ::csv { + namespace export join joinlist read2matrix read2queue report + namespace export split split2matrix split2queue writematrix writequeue +} + +# ::csv::join -- +# +# Takes a list of values and generates a string in CSV format. +# +# Arguments: +# values A list of the values to join +# sepChar The separator character, defaults to comma +# delChar The delimiter character, defaults to quote +# delMode If set to 'always', values are always surrounded by delChar +# +# Results: +# A string containing the values in CSV format. + +proc ::csv::join {values {sepChar ,} {delChar \"} {delMode auto}} { + set out "" + set sep {} + foreach val $values { + if {($delMode eq "always") || [string match "*\[${delChar}$sepChar\r\n\]*" $val]} { + append out $sep${delChar}[string map [list $delChar ${delChar}${delChar}] $val]${delChar} + } else { + append out $sep${val} + } + set sep $sepChar + } + return $out +} + +# ::csv::joinlist -- +# +# Takes a list of lists of values and generates a string in CSV +# format. Each item in the list is made into a single CSV +# formatted record in the final string, the records being +# separated by newlines. +# +# Arguments: +# values A list of the lists of the values to join +# sepChar The separator character, defaults to comma +# delChar The delimiter character, defaults to quote +# delMode If set to 'always', values are always surrounded by delChar +# +# Results: +# A string containing the values in CSV format, the records +# separated by newlines. + +proc ::csv::joinlist {values {sepChar ,} {delChar \"} {delMode auto}} { + set out "" + foreach record $values { + # note that this is ::csv::join + append out "[join $record $sepChar $delChar $delMode]\n" + } + return $out +} + +# ::csv::joinmatrix -- +# +# Takes a matrix object following the API specified for the +# struct::matrix package. Each row of the matrix is converted +# into a single CSV formatted record in the final string, the +# records being separated by newlines. +# +# Arguments: +# matrix Matrix object command. +# sepChar The separator character, defaults to comma +# delChar The delimiter character, defaults to quote +# delMode If set to 'always', values are always surrounded by delChar +# +# Results: +# A string containing the values in CSV format, the records +# separated by newlines. + +proc ::csv::joinmatrix {matrix {sepChar ,} {delChar \"} {delMode auto}} { + return [joinlist [$matrix get rect 0 0 end end] $sepChar $delChar $delMode] +} + +# ::csv::iscomplete -- +# +# A predicate checking if the argument is a complete csv record. +# +# Arguments +# data The (partial) csv record to check. +# +# Results: +# A boolean flag indicating the completeness of the data. The +# result is true if the data is complete. + +proc ::csv::iscomplete {data} { + expr {1 - [regexp -all \" $data] % 2} +} + +# ::csv::read2matrix -- +# +# A wrapper around "Split2matrix" reading CSV formatted +# lines from the specified channel and adding it to the given +# matrix. +# +# Arguments: +# m The matrix to add the read data too. +# chan The channel to read from. +# sepChar The separator character, defaults to comma +# expand The expansion mode. The default is none +# +# Results: +# A list of the values in 'line'. + +proc ::csv::read2matrix {args} { + # FR #481023 + # See 'split2matrix' for the available expansion modes. + + # Argument syntax: + # + #2) chan m + #3) chan m sepChar + #3) -alternate chan m + #4) -alternate chan m sepChar + #4) chan m sepChar expand + #5) -alternate chan m sepChar expand + + set alternate 0 + set sepChar , + set expand none + + switch -exact -- [llength $args] { + 2 { + foreach {chan m} $args break + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set chan $b + set m $c + } else { + set chan $a + set m $b + set sepChar $c + } + } + 4 { + foreach {a b c d} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set chan $b + set m $c + set sepChar $d + } else { + set chan $a + set m $b + set sepChar $c + set expand $d + } + } + 5 { + foreach {a b c d e} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? chan m ?separator? ?expand?" + } + set alternate 1 + + set chan $b + set m $c + set sepChar $d + set expand $e + } + 0 - 1 - + default { + return -code error "wrong#args: Should be ?-alternate? chan m ?separator? ?expand?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character \"$sepChar\", is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character \"$sepChar\", is a string" + } + + set data "" + while {![eof $chan]} { + if {[gets $chan line] < 0} {continue} + + # Why skip empty lines? They may be in data. Except if the + # buffer is empty, i.e. we are between records. + if {$line == {} && $data == {}} {continue} + + append data $line + if {![iscomplete $data]} { + # Odd number of quotes - must have embedded newline + append data \n + continue + } + + Split2matrix $alternate $m $data $sepChar $expand + set data "" + } + return +} + +# ::csv::read2queue -- +# +# A wrapper around "::csv::split2queue" reading CSV formatted +# lines from the specified channel and adding it to the given +# queue. +# +# Arguments: +# q The queue to add the read data too. +# chan The channel to read from. +# sepChar The separator character, defaults to comma +# +# Results: +# A list of the values in 'line'. + +proc ::csv::read2queue {args} { + # Argument syntax: + # + #2) chan q + #3) chan q sepChar + #3) -alternate chan q + #4) -alternate chan q sepChar + + set alternate 0 + set sepChar , + + switch -exact -- [llength $args] { + 2 { + foreach {chan q} $args break + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set chan $b + set q $c + } else { + set chan $a + set q $b + set sepChar $c + } + } + 4 { + foreach {a b c d} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? chan q ?separator?" + } + set alternate 1 + set chan $b + set q $c + set sepChar $d + } + 0 - 1 - + default { + return -code error "wrong#args: Should be ?-alternate? chan q ?separator?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character \"$sepChar\", is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character \"$sepChar\", is a string" + } + + set data "" + while {![eof $chan]} { + if {[gets $chan line] < 0} {continue} + + # Why skip empty lines? They may be in data. Except if the + # buffer is empty, i.e. we are between records. + if {$line == {} && $data == {}} {continue} + + append data $line + if {![iscomplete $data]} { + # Odd number of quotes - must have embedded newline + append data \n + continue + } + + $q put [Split $alternate $data $sepChar] + set data "" + } + return +} + +# ::csv::report -- +# +# A report command which can be used by the matrix methods +# "format-via" and "format2chan-via". For the latter this +# command delegates the work to "::csv::writematrix". "cmd" is +# expected to be either "printmatrix" or +# "printmatrix2channel". The channel argument, "chan", has to +# be present for the latter and must not be present for the first. +# +# Arguments: +# cmd Either 'printmatrix' or 'printmatrix2channel' +# matrix The matrix to format. +# args 0 (chan): The channel to write to +# +# Results: +# None for 'printmatrix2channel', else the CSV formatted string. + +proc ::csv::report {cmd matrix args} { + switch -exact -- $cmd { + printmatrix { + if {[llength $args] > 0} { + return -code error "wrong # args:\ + ::csv::report printmatrix matrix" + } + return [joinlist [$matrix get rect 0 0 end end]] + } + printmatrix2channel { + if {[llength $args] != 1} { + return -code error "wrong # args:\ + ::csv::report printmatrix2channel matrix chan" + } + writematrix $matrix [lindex $args 0] + return "" + } + default { + return -code error "Unknown method $cmd" + } + } +} + +# ::csv::split -- +# +# Split a string according to the rules for CSV processing. +# This assumes that the string contains a single line of CSVs +# +# Arguments: +# line The string to split +# sepChar The separator character, defaults to comma +# +# Results: +# A list of the values in 'line'. + +proc ::csv::split {args} { + # Argument syntax: + # + # (1) line + # (2) line sepChar + # (2) -alternate line + # (3) -alternate line sepChar + + # (3) line sepChar delChar + # (4) -alternate line sepChar delChar + + set alternate 0 + set sepChar , + set delChar \" + + switch -exact -- [llength $args] { + 1 { + set line [lindex $args 0] + } + 2 { + foreach {a b} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set line $b + } else { + set line $a + set sepChar $b + } + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set line $b + set sepChar $c + } else { + set line $a + set sepChar $b + set delChar $c + } + } + 4 { + foreach {a b c d} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? line ?separator? ?delimiter?" + } + set alternate 1 + set line $b + set sepChar $c + set delChar $d + } + 0 - + default { + return -code error "wrong#args: Should be ?-alternate? line ?separator? ?delimiter?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character ${delChar}$sepChar${delChar}, is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character ${delChar}$sepChar${delChar}, is a string" + } + + if {[string length $delChar] < 1} { + return -code error "illegal separator character \"$delChar\", is empty" + } elseif {[string length $delChar] > 1} { + return -code error "illegal separator character \"$delChar\", is a string" + } + + return [Split $alternate $line $sepChar $delChar] +} + +proc ::csv::Split {alternate line sepChar {delChar \"}} { + # Protect the sepchar from special interpretation by + # the regex calls below. + + set sepRE \[\[.${sepChar}.]] + set delRE \[\[.${delChar}.]] + + if {$alternate} { + # The alternate syntax requires a different parser. + # A variation of the string map / regsub parser for the + # regular syntax was tried but does not handle embedded + # doubled " well (testcase csv-91.3 was 'knownBug', sole + # one, still a bug). Now we just tokenize the input into + # the primary parts (sep char, "'s and the rest) and then + # use an explicitly coded state machine (DFA) to parse + # and convert token sequences. + + ## puts 1->>$line<< + set line [string map [list \ + $sepChar \0$sepChar\0 \ + $delChar \0${delChar}\0 \ + ] $line] + + ## puts 2->>$line<< + set line [string map [list \0\0 \0] $line] + regsub "^\0" $line {} line + regsub "\0$" $line {} line + + ## puts 3->>$line<< + + set val "" + set res "" + set state base + + ## puts 4->>[::split $line \0] + foreach token [::split $line \0] { + + ## puts "\t*= $state\t>>$token<<" + switch -exact -- $state { + base { + if {[string equal $token "${delChar}"]} { + set state qvalue + continue + } + if {[string equal $token $sepChar]} { + lappend res $val + set val "" + continue + } + append val $token + } + qvalue { + if {[string equal $token "${delChar}"]} { + # May end value, may be a doubled " + set state endordouble + continue + } + append val $token + } + endordouble { + if {[string equal $token "${delChar}"]} { + # Doubled ", append to current value + append val ${delChar} + set state qvalue + continue + } + # Last " was end of quoted value. Close it. + # We expect current as $sepChar + + lappend res $val + set val "" + set state base + + if {[string equal $token $sepChar]} {continue} + + # Undoubled " in middle of text. Just assume that + # remainder is another qvalue. + set state qvalue + } + default { + return -code error "Internal error, illegal parsing state" + } + } + } + + ## puts "/= $state\t>>$val<<" + + lappend res $val + + ## puts 5->>$res<< + return $res + } else { + regsub -- "$sepRE${delRE}${delRE}$" $line $sepChar\0${delChar}${delChar}\0 line + regsub -- "^${delRE}${delRE}$sepRE" $line \0${delChar}${delChar}\0$sepChar line + regsub -all -- {(^${delChar}|${delChar}$)} $line \0 line + + set line [string map [list \ + $sepChar${delChar}${delChar}${delChar} $sepChar\0${delChar} \ + ${delChar}${delChar}${delChar}$sepChar ${delChar}\0$sepChar \ + ${delChar}${delChar} ${delChar} \ + ${delChar} \0 \ + ] $line] + + set end 0 + while {[regexp -indices -start $end -- {(\0)[^\0]*(\0)} $line \ + -> start end]} { + set start [lindex $start 0] + set end [lindex $end 0] + set range [string range $line $start $end] + if {[string first $sepChar $range] >= 0} { + set line [string replace $line $start $end \ + [string map [list $sepChar \1] $range]] + } + incr end + } + set line [string map [list $sepChar \0 \1 $sepChar \0 {} ] $line] + return [::split $line \0] + + } +} + +# ::csv::split2matrix -- +# +# Split a string according to the rules for CSV processing. +# This assumes that the string contains a single line of CSVs. +# The resulting list of values is appended to the specified +# matrix, as a new row. The code assumes that the matrix provides +# the same interface as the queue provided by the 'struct' +# module of tcllib, "add row" in particular. +# +# Arguments: +# m The matrix to write the resulting list to. +# line The string to split +# sepChar The separator character, defaults to comma +# expand The expansion mode. The default is none +# +# Results: +# A list of the values in 'line', written to 'q'. + +proc ::csv::split2matrix {args} { + # FR #481023 + + # Argument syntax: + # + #2) m line + #3) m line sepChar + #3) -alternate m line + #4) -alternate m line sepChar + #4) m line sepChar expand + #5) -alternate m line sepChar expand + + set alternate 0 + set sepChar , + set expand none + + switch -exact -- [llength $args] { + 2 { + foreach {m line} $args break + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set m $b + set line $c + } else { + set m $a + set line $b + set sepChar $c + } + } + 4 { + foreach {a b c d} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set m $b + set line $c + set sepChar $d + } else { + set m $a + set line $b + set sepChar $c + set expand $d + } + } + 4 { + foreach {a b c d e} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? m line ?separator? ?expand?" + } + set alternate 1 + + set m $b + set line $c + set sepChar $d + set expand $e + } + 0 - 1 - + default { + return -code error "wrong#args: Should be ?-alternate? m line ?separator? ?expand?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character \"$sepChar\", is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character \"$sepChar\", is a string" + } + + Split2matrix $alternate $m $line $sepChar $expand + return +} + +proc ::csv::Split2matrix {alternate m line sepChar expand} { + set csv [Split $alternate $line $sepChar] + + # Expansion modes + # - none : default, behaviour of original implementation. + # no expansion is done, lines are silently truncated + # to the number of columns in the matrix. + # + # - empty : A matrix without columns is expanded to the number + # of columns in the first line added to it. All + # following lines are handled as if "mode == none" + # was set. + # + # - auto : Full auto-mode. The matrix is expanded as needed to + # hold all columns of all lines. + + switch -exact -- $expand { + none {} + empty { + if {[$m columns] == 0} { + $m add columns [llength $csv] + } + } + auto { + if {[$m columns] < [llength $csv]} { + $m add columns [expr {[llength $csv] - [$m columns]}] + } + } + } + $m add row $csv + return +} + +# ::csv::split2queue -- +# +# Split a string according to the rules for CSV processing. +# This assumes that the string contains a single line of CSVs. +# The resulting list of values is appended to the specified +# queue, as a single item. IOW each item in the queue represents +# a single CSV record. The code assumes that the queue provides +# the same interface as the queue provided by the 'struct' +# module of tcllib, "put" in particular. +# +# Arguments: +# q The queue to write the resulting list to. +# line The string to split +# sepChar The separator character, defaults to comma +# +# Results: +# A list of the values in 'line', written to 'q'. + +proc ::csv::split2queue {args} { + # Argument syntax: + # + #2) q line + #3) q line sepChar + #3) -alternate q line + #4) -alternate q line sepChar + + set alternate 0 + set sepChar , + + switch -exact -- [llength $args] { + 2 { + foreach {q line} $args break + } + 3 { + foreach {a b c} $args break + if {[string equal $a "-alternate"]} { + set alternate 1 + set q $b + set line $c + } else { + set q $a + set line $b + set sepChar $c + } + } + 4 { + foreach {a b c d} $args break + if {![string equal $a "-alternate"]} { + return -code error "wrong#args: Should be ?-alternate? q line ?separator?" + } + set alternate 1 + + set q $b + set line $c + set sepChar $d + } + 0 - 1 - + default { + return -code error "wrong#args: Should be ?-alternate? q line ?separator?" + } + } + + if {[string length $sepChar] < 1} { + return -code error "illegal separator character \"$sepChar\", is empty" + } elseif {[string length $sepChar] > 1} { + return -code error "illegal separator character \"$sepChar\", is a string" + } + + $q put [Split $alternate $line $sepChar] + return +} + +# ::csv::writematrix -- +# +# A wrapper around "::csv::join" taking the rows in a matrix and +# writing them as CSV formatted lines into the channel. +# +# Arguments: +# m The matrix to take the data to write from. +# chan The channel to write into. +# sepChar The separator character, defaults to comma +# +# Results: +# None. + +proc ::csv::writematrix {m chan {sepChar ,} {delChar \"}} { + set n [$m rows] + for {set r 0} {$r < $n} {incr r} { + puts $chan [join [$m get row $r] $sepChar $delChar] + } + + # Memory intensive alternative: + # puts $chan [joinlist [m get rect 0 0 end end] $sepChar $delChar] + return +} + +# ::csv::writequeue -- +# +# A wrapper around "::csv::join" taking the rows in a queue and +# writing them as CSV formatted lines into the channel. +# +# Arguments: +# q The queue to take the data to write from. +# chan The channel to write into. +# sepChar The separator character, defaults to comma +# +# Results: +# None. + +proc ::csv::writequeue {q chan {sepChar ,} {delChar \"}} { + while {[$q size] > 0} { + puts $chan [join [$q get] $sepChar $delChar] + } + + # Memory intensive alternative: + # puts $chan [joinlist [$q get [$q size]] $sepChar $delChar] + return +} + diff --git a/src/vendormodules/dictutils-0.2.1.tm b/src/vendormodules/dictutils-0.2.1.tm new file mode 100644 index 00000000..cd6b4e58 --- /dev/null +++ b/src/vendormodules/dictutils-0.2.1.tm @@ -0,0 +1,145 @@ +# dictutils.tcl -- + # + # Various dictionary utilities. + # + # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). + # + # License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). + # + + #2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" + + package require Tcl 8.6- + package provide dictutils 0.2.1 + + namespace eval dictutils { + namespace export equal apply capture witharray nlappend + namespace ensemble create + + # dictutils witharray dictVar arrayVar script -- + # + # Unpacks the elements of the dictionary in dictVar into the array + # variable arrayVar and then evaluates the script. If the script + # completes with an ok, return or continue status, then the result is copied + # back into the dictionary variable, otherwise it is discarded. A + # [break] can be used to explicitly abort the transaction. + # + proc witharray {dictVar arrayVar script} { + upvar 1 $dictVar dict $arrayVar array + array set array $dict + try { uplevel 1 $script + } on break {} { # Discard the result + } on continue result - on ok result { + set dict [array get array] ;# commit changes + return $result + } on return {result opts} { + set dict [array get array] ;# commit changes + dict incr opts -level ;# remove this proc from level + return -options $opts $result + } + # All other cases will discard the changes and propagage + } + + # dictutils equal equalp d1 d2 -- + # + # Compare two dictionaries for equality. Two dictionaries are equal + # if they (a) have the same keys, (b) the corresponding values for + # each key in the two dictionaries are equal when compared using the + # equality predicate, equalp (passed as an argument). The equality + # predicate is invoked with the key and the two values from each + # dictionary as arguments. + # + proc equal {equalp d1 d2} { + if {[dict size $d1] != [dict size $d2]} { return 0 } + dict for {k v} $d1 { + if {![dict exists $d2 $k]} { return 0 } + if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } + } + return 1 + } + + # apply dictVar lambdaExpr ?arg1 arg2 ...? -- + # + # A combination of *dict with* and *apply*, this procedure creates a + # new procedure scope populated with the values in the dictionary + # variable. It then applies the lambdaTerm (anonymous procedure) in + # this new scope. If the procedure completes normally, then any + # changes made to variables in the dictionary are reflected back to + # the dictionary variable, otherwise they are ignored. This provides + # a transaction-style semantics whereby atomic updates to a + # dictionary can be performed. This procedure can also be useful for + # implementing a variety of control constructs, such as mutable + # closures. + # + proc apply {dictVar lambdaExpr args} { + upvar 1 $dictVar dict + set env $dict ;# copy + lassign $lambdaExpr params body ns + if {$ns eq ""} { set ns "::" } + set body [format { + upvar 1 env __env__ + dict with __env__ %s + } [list $body]] + set lambdaExpr [list $params $body $ns] + set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] + if {$rc == 0} { + # Copy back any updates + set dict $env + } + return -options $opts $ret + } + + # capture ?level? ?exclude? ?include? -- + # + # Captures a snapshot of the current (scalar) variable bindings at + # $level on the stack into a dictionary environment. This dictionary + # can later be used with *dictutils apply* to partially restore the + # scope, creating a first approximation of closures. The *level* + # argument should be of the forms accepted by *uplevel* and + # designates which level to capture. It defaults to 1 as in uplevel. + # The *exclude* argument specifies an optional list of literal + # variable names to avoid when performing the capture. No variables + # matching any item in this list will be captured. The *include* + # argument can be used to specify a list of glob patterns of + # variables to capture. Only variables matching one of these + # patterns are captured. The default is a single pattern "*", for + # capturing all visible variables (as determined by *info vars*). + # + proc capture {{level 1} {exclude {}} {include {*}}} { + if {[string is integer $level]} { incr level } + set env [dict create] + foreach pattern $include { + foreach name [uplevel $level [list info vars $pattern]] { + if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } + upvar $level $name value + catch { dict set env $name $value } ;# no arrays + } + } + return $env + } + + # nlappend dictVar keyList ?value ...? + # + # Append zero or more elements to the list value stored in the given + # dictionary at the path of keys specified in $keyList. If $keyList + # specifies a non-existent path of keys, nlappend will behave as if + # the path mapped to an empty list. + # + proc nlappend {dictvar keylist args} { + upvar 1 $dictvar dict + if {[info exists dict] && [dict exists $dict {*}$keylist]} { + set list [dict get $dict {*}$keylist] + } + lappend list {*}$args + dict set dict {*}$keylist $list + } + + # invoke cmd args... -- + # + # Helper procedure to invoke a callback command with arguments at + # the global scope. The helper ensures that proper quotation is + # used. The command is expected to be a list, e.g. {string equal}. + # + proc invoke {cmd args} { uplevel #0 $cmd $args } + + } diff --git a/src/vendormodules/fileutil-1.16.1.tm b/src/vendormodules/fileutil-1.16.1.tm new file mode 100644 index 00000000..6d5c737e --- /dev/null +++ b/src/vendormodules/fileutil-1.16.1.tm @@ -0,0 +1,2311 @@ +# fileutil.tcl -- +# +# Tcl implementations of standard UNIX utilities. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2002 by Phil Ehrens (fileType) +# Copyright (c) 2005-2013 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5- +package require cmdline +package provide fileutil 1.16.1 + +namespace eval ::fileutil { + namespace export \ + grep find findByPattern cat touch foreachLine \ + jail stripPwd stripN stripPath tempdir tempfile \ + install fileType writeFile appendToFile \ + insertIntoFile removeFromFile replaceInFile \ + updateInPlace test tempdirReset maketempdir +} + +# ::fileutil::grep -- +# +# Implementation of grep. Adapted from the Tcler's Wiki. +# +# Arguments: +# pattern pattern to search for. +# files list of files to search; if NULL, uses stdin. +# +# Results: +# results list of matches + +proc ::fileutil::grep {pattern {files {}}} { + set result [list] + if {[llength $files] == 0} { + # read from stdin + set lnum 0 + while {[gets stdin line] >= 0} { + incr lnum + if {[regexp -- $pattern $line]} { + lappend result "${lnum}:${line}" + } + } + } else { + foreach filename $files { + set file [open $filename r] + set lnum 0 + while {[gets $file line] >= 0} { + incr lnum + if {[regexp -- $pattern $line]} { + lappend result "${filename}:${lnum}:${line}" + } + } + close $file + } + } + return $result +} + +# ::fileutil::find == + +# Below is the core command, which is portable across Tcl versions and +# platforms. Functionality which is common or platform and/or Tcl +# version dependent, has been factored out/ encapsulated into separate +# (small) commands. Only these commands may have multiple variant +# implementations per the available features of the Tcl core / +# platform. +# +# These commands are +# +# FADD - Add path result, performs filtering. Portable! +# GLOBF - Return files in a directory. Tcl version/platform dependent. +# GLOBD - Return dirs in a directory. Tcl version/platform dependent. +# ACCESS - Check directory for accessibility. Tcl version/platform dependent. + +proc ::fileutil::find {{basedir .} {filtercmd {}}} { + set result {} + set filt [string length $filtercmd] + + if {[file isfile $basedir]} { + # The base is a file, and therefore only possible result, + # modulo filtering. + + FADD $basedir + + } elseif {[file isdirectory $basedir]} { + # For a directory as base we do an iterative recursion through + # the directory hierarchy starting at the base. We use a queue + # (Tcl list) of directories we have to check. We access it by + # index, and stop when we have reached beyond the end of the + # list. This is faster than removing elements from the be- + # ginning of the list, as that entails copying down a possibly + # large list of directories, making it O(n*n). The index is + # faster, O(n), at the expense of memory. Nothing is deleted + # from the list until we have processed all directories in the + # hierarchy. + # + # We scan each directory at least twice. First for files, then + # for directories. The scans may internally make several + # passes (normal vs hidden files). + # + # Looped directory structures due to symbolic links are + # handled by _fully_ normalizing directory paths and checking + # if we encountered the normalized form before. The array + # 'known' is our cache where we record the known normalized + # paths. + + set pending [list $basedir] + set at 0 + array set parent {} + array set norm {} + Enter {} $basedir + + while {$at < [llength $pending]} { + # Get next directory not yet processed. + set current [lindex $pending $at] + incr at + + # Is the directory accessible? Continue if not. + ACCESS $current + + # Files first, then the sub-directories ... + + foreach f [GLOBF $current] { FADD $f } + + foreach f [GLOBD $current] { + # Ignore current and parent directory, this needs + # explicit filtering outside of the filter command. + if { + [string equal [file tail $f] "."] || + [string equal [file tail $f] ".."] + } continue + + # Extend result, modulo filtering. + FADD $f + + # Detection of symlink loops via a portable path + # normalization computing a canonical form of the path + # followed by a check if that canonical form was + # encountered before. If ok, record directory for + # expansion in future iterations. + + Enter $current $f + if {[Cycle $f]} continue + + lappend pending $f + } + } + } else { + return -code error "$basedir does not exist" + } + + return $result +} + +proc ::fileutil::Enter {parent path} { + upvar 1 parent _parent norm _norm + set _parent($path) $parent + set _norm($path) [fullnormalize $path] + return +} + +proc ::fileutil::Cycle {path} { + upvar 1 parent _parent norm _norm + set nform $_norm($path) + set paren $_parent($path) + while {$paren ne {}} { + if {$_norm($paren) eq $nform} { return yes } + set paren $_parent($paren) + } + return no +} + +# Helper command for fileutil::find. Performs the filtering of the +# result per a filter command for the candidates found by the +# traversal core, see above. This is portable. + +proc ::fileutil::FADD {filename} { + upvar 1 result result filt filt filtercmd filtercmd + if {!$filt} { + lappend result $filename + return + } + + set here [pwd] + cd [file dirname $filename] + + if {[uplevel 2 [linsert $filtercmd end [file tail $filename]]]} { + lappend result $filename + } + + cd $here + return +} + +# The next three helper commands for fileutil::find depend strongly on +# the version of Tcl, and partially on the platform. + +# 1. The -directory and -types switches were added to glob in Tcl +# 8.3. This means that we have to emulate them for Tcl 8.2. +# +# 2. In Tcl 8.3 using -types f will return only true files, but not +# links to files. This changed in 8.4+ where links to files are +# returned as well. So for 8.3 we have to handle the links +# separately (-types l) and also filter on our own. +# Note that Windows file links are hard links which are reported by +# -types f, but not -types l, so we can optimize that for the two +# platforms. +# +# Note further that we have to handle broken links on our own. They +# are not returned by glob yet we want them in the output. +# +# 3. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on +# a known file") when trying to perform 'glob -types {hidden f}' on +# a directory without e'x'ecute permissions. We code around by +# testing if we can cd into the directory (stat might return enough +# information too (mode), but possibly also not portable). +# +# For Tcl 8.2 and 8.4+ glob simply delivers an empty result +# (-nocomplain), without crashing. For them this command is defined +# so that the bytecode compiler removes it from the bytecode. +# +# This bug made the ACCESS helper necessary. +# We code around the problem by testing if we can cd into the +# directory (stat might return enough information too (mode), but +# possibly also not portable). + +if {[package vsatisfies [package present Tcl] 8.5]} { + # Tcl 8.5+. + # We have to check readability of "current" on our own, glob + # changed to error out instead of returning nothing. + + proc ::fileutil::ACCESS {args} {} + + proc ::fileutil::GLOBF {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} + } + + set res [lsort -unique [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]]] + + # Look for broken links (They are reported as neither file nor directory). + foreach l [lsort -unique [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]]] { + if {[file isfile $l]} continue + if {[file isdirectory $l]} continue + lappend res $l + } + return [lsort -unique $res] + } + + proc ::fileutil::GLOBD {current} { + if {![file readable $current] || + [BadLink $current]} { + return {} + } + + lsort -unique [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] + } + + proc ::fileutil::BadLink {current} { + if {[file type $current] ne "link"} { return no } + + set dst [file join [file dirname $current] [file readlink $current]] + + if {![file exists $dst] || + ![file readable $dst]} { + return yes + } + + return no + } +} elseif {[package vsatisfies [package present Tcl] 8.4]} { + # Tcl 8.4+. + # (Ad 1) We have -directory, and -types, + # (Ad 2) Links are returned for -types f/d if they refer to files/dirs. + # (Ad 3) No bug to code around + + proc ::fileutil::ACCESS {args} {} + + proc ::fileutil::GLOBF {current} { + set res [lsort -unique [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]]] + + # Look for broken links (They are reported as neither file nor directory). + foreach l [lsort -unique [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]]] { + if {[file isfile $l]} continue + if {[file isdirectory $l]} continue + lappend res $l + } + return [lsort -unique $res] + } + + proc ::fileutil::GLOBD {current} { + lsort -unique [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] + } + +} elseif {[package vsatisfies [package present Tcl] 8.3]} { + # 8.3. + # (Ad 1) We have -directory, and -types, + # (Ad 2) Links are NOT returned for -types f/d, collect separately. + # No symbolic file links on Windows. + # (Ad 3) Bug to code around. + + proc ::fileutil::ACCESS {current} { + if {[catch { + set h [pwd] ; cd $current ; cd $h + }]} {return -code continue} + return + } + + if {[string equal $::tcl_platform(platform) windows]} { + proc ::fileutil::GLOBF {current} { + concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]] + } + } else { + proc ::fileutil::GLOBF {current} { + set l [concat \ + [glob -nocomplain -directory $current -types f -- *] \ + [glob -nocomplain -directory $current -types {hidden f} -- *]] + + foreach x [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]] { + if {[file isdirectory $x]} continue + # We have now accepted files, links to files, and broken links. + lappend l $x + } + + return $l + } + } + + proc ::fileutil::GLOBD {current} { + set l [concat \ + [glob -nocomplain -directory $current -types d -- *] \ + [glob -nocomplain -directory $current -types {hidden d} -- *]] + + foreach x [concat \ + [glob -nocomplain -directory $current -types l -- *] \ + [glob -nocomplain -directory $current -types {hidden l} -- *]] { + if {![file isdirectory $x]} continue + lappend l $x + } + + return $l + } +} else { + # 8.2. + # (Ad 1,2,3) We do not have -directory, nor -types. Full emulation required. + + proc ::fileutil::ACCESS {args} {} + + if {[string equal $::tcl_platform(platform) windows]} { + # Hidden files cannot be handled by Tcl 8.2 in glob. We have + # to punt. + + proc ::fileutil::GLOBF {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- [file join $current *]] { + if {[file isdirectory $x]} continue + if {[catch {file type $x}]} continue + # We have now accepted files, links to files, and + # broken links. We may also have accepted a directory + # as well, if the current path was inaccessible. This + # however will cause 'file type' to throw an error, + # hence the second check. + lappend res $x + } + return $res + } + + proc ::fileutil::GLOBD {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- [file join $current *]] { + if {![file isdirectory $x]} continue + lappend res $x + } + return $res + } + } else { + # Hidden files on Unix are dot-files. We emulate the switch + # '-types hidden' by using an explicit pattern. + + proc ::fileutil::GLOBF {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- [file join $current *] [file join $current .*]] { + if {[file isdirectory $x]} continue + if {[catch {file type $x}]} continue + # We have now accepted files, links to files, and + # broken links. We may also have accepted a directory + # as well, if the current path was inaccessible. This + # however will cause 'file type' to throw an error, + # hence the second check. + + lappend res $x + } + return $res + } + + proc ::fileutil::GLOBD {current} { + set current \\[join [split $current {}] \\] + set res {} + foreach x [glob -nocomplain -- $current/* [file join $current .*]] { + if {![file isdirectory $x]} continue + lappend res $x + } + return $res + } + } +} + +# ::fileutil::findByPattern -- +# +# Specialization of find. Finds files based on their names, +# which have to match the specified patterns. Options are used +# to specify which type of patterns (regexp-, glob-style) is +# used. +# +# Arguments: +# basedir Directory to start searching from. +# args Options (-glob, -regexp, --) followed by a +# list of patterns to search for. +# +# Results: +# files a list of interesting files. + +proc ::fileutil::findByPattern {basedir args} { + set pos 0 + set cmd ::fileutil::FindGlob + foreach a $args { + incr pos + switch -glob -- $a { + -- {break} + -regexp {set cmd ::fileutil::FindRegexp} + -glob {set cmd ::fileutil::FindGlob} + -* {return -code error "Unknown option $a"} + default {incr pos -1 ; break} + } + } + + set args [lrange $args $pos end] + + if {[llength $args] != 1} { + set pname [lindex [info level 0] 0] + return -code error \ + "wrong#args for \"$pname\", should be\ + \"$pname basedir ?-regexp|-glob? ?--? patterns\"" + } + + set patterns [lindex $args 0] + return [find $basedir [list $cmd $patterns]] +} + + +# ::fileutil::FindRegexp -- +# +# Internal helper. Filter command used by 'findByPattern' +# to match files based on regular expressions. +# +# Arguments: +# patterns List of regular expressions to match against. +# filename Name of the file to match against the patterns. +# Results: +# interesting A boolean flag. Set to true if the file +# matches at least one of the patterns. + +proc ::fileutil::FindRegexp {patterns filename} { + foreach p $patterns { + if {[regexp -- $p $filename]} { + return 1 + } + } + return 0 +} + +# ::fileutil::FindGlob -- +# +# Internal helper. Filter command used by 'findByPattern' +# to match files based on glob expressions. +# +# Arguments: +# patterns List of glob expressions to match against. +# filename Name of the file to match against the patterns. +# Results: +# interesting A boolean flag. Set to true if the file +# matches at least one of the patterns. + +proc ::fileutil::FindGlob {patterns filename} { + foreach p $patterns { + if {[string match $p $filename]} { + return 1 + } + } + return 0 +} + +# ::fileutil::stripPwd -- +# +# If the specified path references is a path in [pwd] (or [pwd] itself) it +# is made relative to [pwd]. Otherwise it is left unchanged. +# In the case of [pwd] itself the result is the string '.'. +# +# Arguments: +# path path to modify +# +# Results: +# path The (possibly) modified path. + +proc ::fileutil::stripPwd {path} { + + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set pwd [pwd] + if {[string equal $pwd $path]} { + return "." + } + + set pwd [file split $pwd] + set npath [file split $path] + + if {[string match ${pwd}* $npath]} { + set path [eval [linsert [lrange $npath [llength $pwd] end] 0 file join ]] + } + return $path +} + +# ::fileutil::stripN -- +# +# Removes N elements from the beginning of the path. +# +# Arguments: +# path path to modify +# n number of elements to strip +# +# Results: +# path The modified path + +proc ::fileutil::stripN {path n} { + set path [file split $path] + if {$n >= [llength $path]} { + return {} + } else { + return [eval [linsert [lrange $path $n end] 0 file join]] + } +} + +# ::fileutil::stripPath -- +# +# If the specified path references/is a path in prefix (or prefix itself) it +# is made relative to prefix. Otherwise it is left unchanged. +# In the case of it being prefix itself the result is the string '.'. +# +# Arguments: +# prefix prefix to strip from the path. +# path path to modify +# +# Results: +# path The (possibly) modified path. + +if {[string equal $tcl_platform(platform) windows]} { + + # Windows. While paths are stored with letter-case preserved al + # comparisons have to be done case-insensitive. For reference see + # SF Tcllib Bug 2499641. + + proc ::fileutil::stripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal -nocase $prefix $npath]} { + return "." + } + + if {[string match -nocase "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } +} else { + proc ::fileutil::stripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal $prefix $npath]} { + return "." + } + + if {[string match "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } +} + +# ::fileutil::jail -- +# +# Ensures that the input path 'filename' stays within the +# directory 'jail'. In this way it prevents user-supplied paths +# from escaping the jail. +# +# Arguments: +# jail The path to the directory the other must +# not escape from. +# filename The path to prevent from escaping. +# +# Results: +# path The (possibly) modified path surely within +# the confines of the jail. + +proc fileutil::jail {jail filename} { + if {![string equal [file pathtype $filename] "relative"]} { + # Although the path to check is absolute (or volumerelative on + # windows) we cannot perform a simple prefix check to see if + # the path is inside the jail or not. We have to normalize + # both path and jail and then we can check. If the path is + # outside we make the original path relative and prefix it + # with the original jail. We do make the jail pseudo-absolute + # by prefixing it with the current working directory for that. + + # Normalized jail. Fully resolved sym links, if any. Our main + # complication is that normalize does not resolve symlinks in the + # last component of the path given to it, so we add a bogus + # component, resolve, and then strip it off again. That is why the + # code is so large and long. + + set njail [eval [list file join] [lrange [file split \ + [Normalize [file join $jail __dummy__]]] 0 end-1]] + + # Normalize filename. Fully resolved sym links, if + # any. S.a. for an explanation of the complication. + + set nfile [eval [list file join] [lrange [file split \ + [Normalize [file join $filename __dummy__]]] 0 end-1]] + + if {[string match ${njail}* $nfile]} { + return $filename + } + + # Outside the jail, put it inside. ... We normalize the input + # path lexically for this, to prevent escapes still lurking in + # the original path. (We cannot use the normalized path, + # symlinks may have bent it out of shape in unrecognizable ways. + + return [eval [linsert [lrange [file split \ + [lexnormalize $filename]] 1 end] 0 file join [pwd] $jail]] + } else { + # The path is relative, consider it as outside + # implicitly. Normalize it lexically! to prevent escapes, then + # put the jail in front, use PWD to ensure absoluteness. + + return [eval [linsert [file split [lexnormalize $filename]] 0 \ + file join [pwd] $jail]] + } +} + + +# ::fileutil::test -- +# +# Simple API to testing various properties of +# a path (read, write, file/dir, existence) +# +# Arguments: +# path path to test +# codes names of the properties to test +# msgvar Name of variable to leave an error +# message in. Optional. +# label Label for error message, optional +# +# Results: +# ok boolean flag, set if the path passes +# all tests. + +namespace eval ::fileutil { + variable test + array set test { + read {readable {Read access is denied}} + write {writable {Write access is denied}} + exec {executable {Is not executable}} + exists {exists {Does not exist}} + file {isfile {Is not a file}} + dir {isdirectory {Is not a directory}} + } +} + +proc ::fileutil::test {path codes {msgvar {}} {label {}}} { + variable test + + if {[string equal $msgvar ""]} { + set msg "" + } else { + upvar 1 $msgvar msg + } + + if {![string equal $label ""]} {append label { }} + + if {![regexp {^(read|write|exec|exists|file|dir)} $codes]} { + # Translate single characters into proper codes + set codes [string map { + r read w write e exists x exec f file d dir + } [split $codes {}]] + } + + foreach c $codes { + foreach {cmd text} $test($c) break + if {![file $cmd $path]} { + set msg "$label\"$path\": $text" + return 0 + } + } + + return 1 +} + +# ::fileutil::cat -- +# +# Tcl implementation of the UNIX "cat" command. Returns the contents +# of the specified files. +# +# Arguments: +# args names of the files to read, interspersed with options +# to set encodings, translations, or eofchar. +# +# Results: +# data data read from the file. + +proc ::fileutil::cat {args} { + # Syntax: (?options? file)+ + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + if {![llength $args]} { + # Argument processing stopped with arguments missing. + return -code error \ + "wrong#args: should be\ + [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..." + } + + # We go through the arguments using foreach and keeping track of + # the index we are at. We do not shift the arguments out to the + # left. That is inherently quadratic, copying everything down. + + set opts {} + set mode maybeopt + set channels {} + + foreach a $args { + if {[string equal $mode optarg]} { + lappend opts $a + set mode maybeopt + continue + } elseif {[string equal $mode maybeopt]} { + if {[string match -* $a]} { + switch -exact -- $a { + -encoding - + -translation - + -eofchar { + lappend opts $a + set mode optarg + continue + } + -- { + set mode file + continue + } + default { + return -code error \ + "Bad option \"$a\",\ + expected one of\ + -encoding, -eofchar,\ + or -translation" + } + } + } + # Not an option, but a file. Change mode and fall through. + set mode file + } + # Process file arguments + + if {[string equal $a -]} { + # Stdin reference is special. + + # Test that the current options are all ok. + # For stdin we have to avoid closing it. + + set old [fconfigure stdin] + set fail [catch { + SetOptions stdin $opts + } msg] ; # {} + SetOptions stdin $old + + if {$fail} { + return -code error $msg + } + + lappend channels [list $a $opts 0] + } else { + if {![file exists $a]} { + return -code error "Cannot read file \"$a\", does not exist" + } elseif {![file isfile $a]} { + return -code error "Cannot read file \"$a\", is not a file" + } elseif {![file readable $a]} { + return -code error "Cannot read file \"$a\", read access is denied" + } + + # Test that the current options are all ok. + set c [open $a r] + set fail [catch { + SetOptions $c $opts + } msg] ; # {} + close $c + if {$fail} { + return -code error $msg + } + + lappend channels [list $a $opts [file size $a]] + } + + # We may have more options and files coming after. + set mode maybeopt + } + + if {![string equal $mode maybeopt]} { + # Argument processing stopped with arguments missing. + return -code error \ + "wrong#args: should be\ + [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..." + } + + set data "" + foreach c $channels { + foreach {fname opts size} $c break + + if {[string equal $fname -]} { + set old [fconfigure stdin] + SetOptions stdin $opts + append data [read stdin] + SetOptions stdin $old + continue + } + + set c [open $fname r] + SetOptions $c $opts + + if {$size > 0} { + # Used the [file size] command to get the size, which + # preallocates memory, rather than trying to grow it as + # the read progresses. + append data [read $c $size] + } else { + # if the file has zero bytes it is either empty, or + # something where [file size] reports 0 but the file + # actually has data (like the files in the /proc + # filesystem on Linux). + append data [read $c] + } + close $c + } + + return $data +} + +# ::fileutil::writeFile -- +# +# Write the specified data into the named file, +# creating it if necessary. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to write. +# data The data to write into the file +# +# Results: +# None. + +proc ::fileutil::writeFile {args} { + # Syntax: ?options? file data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec Writable $args opts fname data + + # Now perform the requested operation. + + file mkdir [file dirname $fname] + set c [open $fname w] + SetOptions $c $opts + puts -nonewline $c $data + close $c + return +} + +# ::fileutil::appendToFile -- +# +# Append the specified data at the end of the named file, +# creating it if necessary. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# data The data to extend the file with. +# +# Results: +# None. + +proc ::fileutil::appendToFile {args} { + # Syntax: ?options? file data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec Writable $args opts fname data + + # Now perform the requested operation. + + file mkdir [file dirname $fname] + set c [open $fname a] + SetOptions $c $opts + set at [tell $c] + puts -nonewline $c $data + close $c + return $at +} + +# ::fileutil::insertIntoFile -- +# +# Insert the specified data into the named file, +# creating it if necessary, at the given locaton. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# data The data to extend the file with. +# +# Results: +# None. + +proc ::fileutil::insertIntoFile {args} { + + # Syntax: ?options? file at data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname at data + + set max [file size $fname] + CheckLocation $at $max insertion + + if {[string length $data] == 0} { + # Another degenerate case, inserting nothing. + # Leave the file well enough alone. + return + } + + foreach {c o t} [Open2 $fname $opts] break + + # The degenerate cases of both appending and insertion at the + # beginning of the file allow more optimized implementations of + # the operation. + + if {$at == 0} { + puts -nonewline $o $data + fcopy $c $o + } elseif {$at == $max} { + fcopy $c $o + puts -nonewline $o $data + } else { + fcopy $c $o -size $at + puts -nonewline $o $data + fcopy $c $o + } + + Close2 $fname $t $c $o + return +} + +# ::fileutil::removeFromFile -- +# +# Remove n characters from the named file, +# starting at the given locaton. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# at Location to start the removal from. +# n Number of characters to remove. +# +# Results: +# None. + +proc ::fileutil::removeFromFile {args} { + + # Syntax: ?options? file at n + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname at n + + set max [file size $fname] + CheckLocation $at $max removal + CheckLength $n $at $max removal + + if {$n == 0} { + # Another degenerate case, removing nothing. + # Leave the file well enough alone. + return + } + + foreach {c o t} [Open2 $fname $opts] break + + # The degenerate cases of both removal from the beginning or end + # of the file allow more optimized implementations of the + # operation. + + if {$at == 0} { + seek $c $n current + fcopy $c $o + } elseif {($at + $n) == $max} { + fcopy $c $o -size $at + # Nothing further to copy. + } else { + fcopy $c $o -size $at + seek $c $n current + fcopy $c $o + } + + Close2 $fname $t $c $o + return +} + +# ::fileutil::replaceInFile -- +# +# Remove n characters from the named file, +# starting at the given locaton, and replace +# it with the given data. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# at Location to start the removal from. +# n Number of characters to remove. +# data The replacement data. +# +# Results: +# None. + +proc ::fileutil::replaceInFile {args} { + + # Syntax: ?options? file at n data + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname at n data + + set max [file size $fname] + CheckLocation $at $max replacement + CheckLength $n $at $max replacement + + if { + ($n == 0) && + ([string length $data] == 0) + } { + # Another degenerate case, replacing nothing with + # nothing. Leave the file well enough alone. + return + } + + foreach {c o t} [Open2 $fname $opts] break + + # Check for degenerate cases and handle them separately, + # i.e. strip the no-op parts out of the general implementation. + + if {$at == 0} { + if {$n == 0} { + # Insertion instead of replacement. + + puts -nonewline $o $data + fcopy $c $o + + } elseif {[string length $data] == 0} { + # Removal instead of replacement. + + seek $c $n current + fcopy $c $o + + } else { + # General replacement at front. + + seek $c $n current + puts -nonewline $o $data + fcopy $c $o + } + } elseif {($at + $n) == $max} { + if {$n == 0} { + # Appending instead of replacement + + fcopy $c $o + puts -nonewline $o $data + + } elseif {[string length $data] == 0} { + # Truncating instead of replacement + + fcopy $c $o -size $at + # Nothing further to copy. + + } else { + # General replacement at end + + fcopy $c $o -size $at + puts -nonewline $o $data + } + } else { + if {$n == 0} { + # General insertion. + + fcopy $c $o -size $at + puts -nonewline $o $data + fcopy $c $o + + } elseif {[string length $data] == 0} { + # General removal. + + fcopy $c $o -size $at + seek $c $n current + fcopy $c $o + + } else { + # General replacement. + + fcopy $c $o -size $at + seek $c $n current + puts -nonewline $o $data + fcopy $c $o + } + } + + Close2 $fname $t $c $o + return +} + +# ::fileutil::updateInPlace -- +# +# Run command prefix on the contents of the +# file and replace them with the result of +# the command. +# +# Arguments: +# options... Options and arguments. +# filename Path to the file to extend. +# cmd Command prefix to run. +# +# Results: +# None. + +proc ::fileutil::updateInPlace {args} { + # Syntax: ?options? file cmd + # options = -encoding ENC + # | -translation TRA + # | -eofchar ECH + # | -- + + Spec ReadWritable $args opts fname cmd + + # readFile/cat inlined ... + + set c [open $fname r] + SetOptions $c $opts + set data [read $c] + close $c + + # Transformation. Abort and do not modify the target file if an + # error was raised during this step. + + lappend cmd $data + set code [catch {uplevel 1 $cmd} res] + if {$code} { + return -code $code $res + } + + # writeFile inlined, with careful preservation of old contents + # until we are sure that the write was ok. + + if {[catch { + file rename -force $fname ${fname}.bak + + set o [open $fname w] + SetOptions $o $opts + puts -nonewline $o $res + close $o + + file delete -force ${fname}.bak + } msg]} { + if {[file exists ${fname}.bak]} { + catch { + file rename -force ${fname}.bak $fname + } + return -code error $msg + } + } + return +} + +proc ::fileutil::Writable {fname mv} { + upvar 1 $mv msg + if {[file exists $fname]} { + if {![file isfile $fname]} { + set msg "Cannot use file \"$fname\", is not a file" + return 0 + } elseif {![file writable $fname]} { + set msg "Cannot use file \"$fname\", write access is denied" + return 0 + } + } + return 1 +} + +proc ::fileutil::ReadWritable {fname mv} { + upvar 1 $mv msg + if {![file exists $fname]} { + set msg "Cannot use file \"$fname\", does not exist" + return 0 + } elseif {![file isfile $fname]} { + set msg "Cannot use file \"$fname\", is not a file" + return 0 + } elseif {![file writable $fname]} { + set msg "Cannot use file \"$fname\", write access is denied" + return 0 + } elseif {![file readable $fname]} { + set msg "Cannot use file \"$fname\", read access is denied" + return 0 + } + return 1 +} + +proc ::fileutil::Spec {check alist ov fv args} { + upvar 1 $ov opts $fv fname + + set n [llength $args] ; # Num more args + incr n ; # Count path as well + + set opts {} + set mode maybeopt + + set at 0 + foreach a $alist { + if {[string equal $mode optarg]} { + lappend opts $a + set mode maybeopt + incr at + continue + } elseif {[string equal $mode maybeopt]} { + if {[string match -* $a]} { + switch -exact -- $a { + -encoding - + -translation - + -eofchar { + lappend opts $a + set mode optarg + incr at + continue + } + -- { + # Stop processing. + incr at + break + } + default { + return -code error \ + "Bad option \"$a\",\ + expected one of\ + -encoding, -eofchar,\ + or -translation" + } + } + } + # Not an option, but a file. + # Stop processing. + break + } + } + + if {([llength $alist] - $at) != $n} { + # Argument processing stopped with arguments missing, or too + # many + return -code error \ + "wrong#args: should be\ + [lindex [info level 1] 0] ?-eofchar|-translation|-encoding arg? file $args" + } + + set fname [lindex $alist $at] + incr at + foreach \ + var $args \ + val [lrange $alist $at end] { + upvar 1 $var A + set A $val + } + + # Check given path ... + + if {![eval [linsert $check end $a msg]]} { + return -code error $msg + } + + return +} + +proc ::fileutil::Open2 {fname opts} { + set c [open $fname r] + set t [tempfile] + set o [open $t w] + + SetOptions $c $opts + SetOptions $o $opts + + return [list $c $o $t] +} + +proc ::fileutil::Close2 {f temp in out} { + close $in + close $out + + file copy -force $f ${f}.bak + file rename -force $temp $f + file delete -force ${f}.bak + return +} + +proc ::fileutil::SetOptions {c opts} { + if {![llength $opts]} return + eval [linsert $opts 0 fconfigure $c] + return +} + +proc ::fileutil::CheckLocation {at max label} { + if {![string is integer -strict $at]} { + return -code error \ + "Expected integer but got \"$at\"" + } elseif {$at < 0} { + return -code error \ + "Bad $label point $at, before start of data" + } elseif {$at > $max} { + return -code error \ + "Bad $label point $at, behind end of data" + } +} + +proc ::fileutil::CheckLength {n at max label} { + if {![string is integer -strict $n]} { + return -code error \ + "Expected integer but got \"$n\"" + } elseif {$n < 0} { + return -code error \ + "Bad $label size $n" + } elseif {($at + $n) > $max} { + return -code error \ + "Bad $label size $n, going behind end of data" + } +} + +# ::fileutil::foreachLine -- +# +# Executes a script for every line in a file. +# +# Arguments: +# var name of the variable to contain the lines +# filename name of the file to read. +# cmd The script to execute. +# +# Results: +# None. + +proc ::fileutil::foreachLine {var filename cmd} { + upvar 1 $var line + set fp [open $filename r] + + # -future- Use try/eval from tcllib/control + catch { + set code 0 + set result {} + set return 0 + while {[gets $fp line] >= 0} { + set code [catch {uplevel 1 $cmd} result options] + if {$code == 2} { + set return 1 + set code [dict get $options -code] + break + } elseif {$code != 0 && $code != 4} { + break + } + } + } + close $fp + + if {$return || $code == 1 || $code > 4} { + return -options $options $result + } + return $result +} + +# ::fileutil::touch -- +# +# Tcl implementation of the UNIX "touch" command. +# +# touch [-a] [-m] [-c] [-r ref_file] [-t time] filename ... +# +# Arguments: +# -a change the access time only, unless -m also specified +# -m change the modification time only, unless -a also specified +# -c silently prevent creating a file if it did not previously exist +# -r ref_file use the ref_file's time instead of the current time +# -t time use the specified time instead of the current time +# ("time" is an integer clock value, like [clock seconds]) +# filename ... the files to modify +# +# Results +# None. +# +# Errors: +# Both of "-r" and "-t" cannot be specified. + +if {[package vsatisfies [package provide Tcl] 8.3]} { + namespace eval ::fileutil { + namespace export touch + } + + proc ::fileutil::touch {args} { + # Don't bother catching errors, just let them propagate up + + set options { + {a "set the atime only"} + {m "set the mtime only"} + {c "do not create non-existant files"} + {r.arg "" "use time from ref_file"} + {t.arg -1 "use specified time"} + } + set usage ": [lindex [info level 0] 0]\ + \[options] filename ...\noptions:" + array set params [::cmdline::getoptions args $options $usage] + + # process -a and -m options + set set_atime [set set_mtime "true"] + if { $params(a) && ! $params(m)} {set set_mtime "false"} + if {! $params(a) && $params(m)} {set set_atime "false"} + + # process -r and -t + set has_t [expr {$params(t) != -1}] + set has_r [expr {[string length $params(r)] > 0}] + if {$has_t && $has_r} { + return -code error "Cannot specify both -r and -t" + } elseif {$has_t} { + set atime [set mtime $params(t)] + } elseif {$has_r} { + file stat $params(r) stat + set atime $stat(atime) + set mtime $stat(mtime) + } else { + set atime [set mtime [clock seconds]] + } + + # do it + foreach filename $args { + if {! [file exists $filename]} { + if {$params(c)} {continue} + close [open $filename w] + } + if {$set_atime} {file atime $filename $atime} + if {$set_mtime} {file mtime $filename $mtime} + } + return + } +} + +# ::fileutil::fileType -- +# +# Do some simple heuristics to determine file type. +# +# +# Arguments: +# filename Name of the file to test. +# +# Results +# type Type of the file. May be a list if multiple tests +# are positive (eg, a file could be both a directory +# and a link). In general, the list proceeds from most +# general (eg, binary) to most specific (eg, gif), so +# the full type for a GIF file would be +# "binary graphic gif" +# +# At present, the following types can be detected: +# +# directory +# empty +# binary +# text +# script +# executable [elf, dos, ne, pe] +# binary graphic [gif, jpeg, png, tiff, bitmap, icns] +# ps, eps, pdf +# html +# xml +# message pgp +# compressed [bzip, gzip, zip, tar] +# audio [mpeg, wave] +# gravity_wave_data_frame +# link +# doctools, doctoc, and docidx documentation files. +# + +proc ::fileutil::fileType {filename} { + ;## existence test + if { ! [ file exists $filename ] } { + set err "file not found: '$filename'" + return -code error $err + } + ;## directory test + if { [ file isdirectory $filename ] } { + set type directory + if { ! [ catch {file readlink $filename} ] } { + lappend type link + } + return $type + } + ;## empty file test + if { ! [ file size $filename ] } { + set type empty + if { ! [ catch {file readlink $filename} ] } { + lappend type link + } + return $type + } + set bin_rx {[\x00-\x08\x0b\x0e-\x1f]} + + if { [ catch { + set fid [ open $filename r ] + fconfigure $fid -translation binary + fconfigure $fid -buffersize 1024 + fconfigure $fid -buffering full + set test [ read $fid 1024 ] + ::close $fid + } err ] } { + catch { ::close $fid } + return -code error "::fileutil::fileType: $err" + } + + if { [ regexp $bin_rx $test ] } { + set type binary + set binary 1 + } else { + set type text + set binary 0 + } + + # SF Tcllib bug [795585]. Allowing whitespace between #! + # and path of script interpreter + + set metakit 0 + + if { [ regexp {^\#\!\s*(\S+)} $test -> terp ] } { + lappend type script $terp + } elseif {([regexp "\\\[manpage_begin " $test] && + !([regexp -- {--- !doctools ---} $test] || [regexp -- "!tcl\.tk//DSL doctools//EN//" $test])) || + ([regexp -- {--- doctools ---} $test] || [regexp -- "tcl\.tk//DSL doctools//EN//" $test])} { + lappend type doctools + } elseif {([regexp "\\\[toc_begin " $test] && + !([regexp -- {--- !doctoc ---} $test] || [regexp -- "!tcl\.tk//DSL doctoc//EN//" $test])) || + ([regexp -- {--- doctoc ---} $test] || [regexp -- "tcl\.tk//DSL doctoc//EN//" $test])} { + lappend type doctoc + } elseif {([regexp "\\\[index_begin " $test] && + !([regexp -- {--- !docidx ---} $test] || [regexp -- "!tcl\.tk//DSL docidx//EN//" $test])) || + ([regexp -- {--- docidx ---} $test] || [regexp -- "tcl\.tk//DSL docidx//EN//" $test])} { + lappend type docidx + } elseif {[regexp -- "tcl\\.tk//DSL diagram//EN//" $test]} { + lappend type tkdiagram + } elseif { $binary && [ regexp {^[\x7F]ELF} $test ] } { + lappend type executable elf + } elseif { $binary && [string match "MZ*" $test] } { + if { [scan [string index $test 24] %c] < 64 } { + lappend type executable dos + } else { + binary scan [string range $test 60 61] s next + set sig [string range $test $next [expr {$next + 1}]] + if { $sig == "NE" || $sig == "PE" } { + lappend type executable [string tolower $sig] + } else { + lappend type executable dos + } + } + } elseif { $binary && [string match "SQLite format 3\x00*" $test] } { + lappend type sqlite3 + + # Check for various sqlite-based application file formats. + set appid [string range $test 68 71] + if {$appid eq "\x0f\x05\x51\x12"} { + lappend type fossil-checkout + } elseif {$appid eq "\x0f\x05\x51\x13"} { + lappend type fossil-global-config + } elseif {$appid eq "\x0f\x05\x51\x11"} { + lappend type fossil-repository + } else { + # encode the appid as hex and append that. + binary scan $appid H8 aid + lappend type A$aid + } + + } elseif { $binary && [string match "BZh91AY\&SY*" $test] } { + lappend type compressed bzip + } elseif { $binary && [string match "\x1f\x8b*" $test] } { + lappend type compressed gzip + } elseif { $binary && [string range $test 257 262] == "ustar\x00" } { + lappend type compressed tar + } elseif { $binary && [string match "\x50\x4b\x03\x04*" $test] } { + lappend type compressed zip + } elseif { $binary && [string match "GIF*" $test] } { + lappend type graphic gif + } elseif { $binary && [string match "icns*" $test] } { + lappend type graphic icns bigendian + } elseif { $binary && [string match "snci*" $test] } { + lappend type graphic icns smallendian + } elseif { $binary && [string match "\x89PNG*" $test] } { + lappend type graphic png + } elseif { $binary && [string match "\xFF\xD8\xFF*" $test] } { + binary scan $test x3H2x2a5 marker txt + if { $marker == "e0" && $txt == "JFIF\x00" } { + lappend type graphic jpeg jfif + } elseif { $marker == "e1" && $txt == "Exif\x00" } { + lappend type graphic jpeg exif + } + } elseif { $binary && [string match "MM\x00\**" $test] } { + lappend type graphic tiff + } elseif { $binary && [string match "BM*" $test] && [string range $test 6 9] == "\x00\x00\x00\x00" } { + lappend type graphic bitmap + } elseif { ! $binary && [string match -nocase "*\*" $test] } { + lappend type html + } elseif {[string match "\%PDF\-*" $test] } { + lappend type pdf + } elseif { [string match "\%\!PS\-*" $test] } { + lappend type ps + if { [string match "* EPSF\-*" $test] } { + lappend type eps + } + } elseif { [string match -nocase "*\<\?xml*" $test] } { + lappend type xml + if { [ regexp -nocase {\<\!DOCTYPE\s+(\S+)} $test -> doctype ] } { + lappend type $doctype + } + } elseif { [string match {*BEGIN PGP MESSAGE*} $test] } { + lappend type message pgp + } elseif { $binary && [string match {IGWD*} $test] } { + lappend type gravity_wave_data_frame + } elseif {[string match "JL\x1a\x00*" $test] && ([file size $filename] >= 27)} { + lappend type metakit smallendian + set metakit 1 + } elseif {[string match "LJ\x1a\x00*" $test] && ([file size $filename] >= 27)} { + lappend type metakit bigendian + set metakit 1 + } elseif { $binary && [string match "RIFF*" $test] && [string range $test 8 11] == "WAVE" } { + lappend type audio wave + } elseif { $binary && [string match "ID3*" $test] } { + lappend type audio mpeg + } elseif { $binary && [binary scan $test S tmp] && [expr {$tmp & 0xFFE0}] == 65504 } { + lappend type audio mpeg + } + + # Additional checks of file contents at the end of the file, + # possibly pointing into the middle too (attached metakit, + # attached zip). + + ## Metakit File format: http://www.equi4.com/metakit/metakit-ff.html + ## Metakit database attached ? ## + + if {!$metakit && ([file size $filename] >= 27)} { + # The offsets in the footer are in always bigendian format + + if { [ catch { + set fid [ open $filename r ] + fconfigure $fid -translation binary + fconfigure $fid -buffersize 1024 + fconfigure $fid -buffering full + seek $fid -16 end + set test [ read $fid 16 ] + ::close $fid + } err ] } { + catch { ::close $fid } + return -code error "::fileutil::fileType: $err" + } + + binary scan $test IIII __ hdroffset __ __ + set hdroffset [expr {[file size $filename] - 16 - $hdroffset}] + + # Further checks iff the offset is actually inside the file. + + if {($hdroffset >= 0) && ($hdroffset < [file size $filename])} { + # Seek to the specified location and try to match a metakit header + # at this location. + + if { [ catch { + set fid [ open $filename r ] + fconfigure $fid -translation binary + fconfigure $fid -buffersize 1024 + fconfigure $fid -buffering full + seek $fid $hdroffset start + set test [ read $fid 16 ] + ::close $fid + } err ] } { + catch { ::close $fid } + return -code error "::fileutil::fileType: $err" + } + + if {[string match "JL\x1a\x00*" $test]} { + lappend type attached metakit smallendian + set metakit 1 + } elseif {[string match "LJ\x1a\x00*" $test]} { + lappend type attached metakit bigendian + set metakit 1 + } + } + } + + ## Zip File Format: http://zziplib.sourceforge.net/zzip-parse.html + ## http://www.pkware.com/products/enterprise/white_papers/appnote.html + + + ;## lastly, is it a link? + if { ! [ catch {file readlink $filename} ] } { + lappend type link + } + return $type +} + +# ::fileutil::tempdir -- +# +# Return the correct directory to use for temporary files. +# Python attempts this sequence, which seems logical: +# +# 1. The directory named by the `TMPDIR' environment variable. +# +# 2. The directory named by the `TEMP' environment variable. +# +# 3. The directory named by the `TMP' environment variable. +# +# 4. A platform-specific location: +# * On Macintosh, the `Temporary Items' folder. +# +# * On Windows, the directories `C:\\TEMP', `C:\\TMP', +# `\\TEMP', and `\\TMP', in that order. +# +# * On all other platforms, the directories `/tmp', +# `/var/tmp', and `/usr/tmp', in that order. +# +# 5. As a last resort, the current working directory. +# +# The code here also does +# +# 0. The directory set by invoking tempdir with an argument. +# If this is present it is used exclusively. +# +# Arguments: +# None. +# +# Side Effects: +# None. +# +# Results: +# The directory for temporary files. + +proc ::fileutil::tempdir {args} { + if {[llength $args] > 1} { + return -code error {wrong#args: should be "::fileutil::tempdir ?path?"} + } elseif {[llength $args] == 1} { + variable tempdir [lindex $args 0] + variable tempdirSet 1 + return + } + return [Normalize [TempDir]] +} + +proc ::fileutil::tempdirReset {} { + variable tempdir {} + variable tempdirSet 0 + return +} + +proc ::fileutil::TempDir {} { + global tcl_platform env + variable tempdir + variable tempdirSet + + set attempdirs [list] + set problems {} + + if {$tempdirSet} { + lappend attempdirs $tempdir + lappend problems {User/Application specified tempdir} + } else { + foreach tmp {TMPDIR TEMP TMP} { + if { [info exists env($tmp)] } { + lappend attempdirs $env($tmp) + } else { + lappend problems "No environment variable $tmp" + } + } + + switch $tcl_platform(platform) { + windows { + lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" + } + macintosh { + lappend attempdirs $env(TRASH_FOLDER) ;# a better place? + } + default { + lappend attempdirs \ + [file join / tmp] \ + [file join / var tmp] \ + [file join / usr tmp] + } + } + + lappend attempdirs [pwd] + } + + foreach tmp $attempdirs { + if { [file isdirectory $tmp] && [file writable $tmp] } { + return $tmp + } elseif { ![file isdirectory $tmp] } { + lappend problems "Not a directory: $tmp" + } else { + lappend problems "Not writable: $tmp" + } + } + + # Fail if nothing worked. + return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" +} + +namespace eval ::fileutil { + variable tempdir {} + variable tempdirSet 0 +} + +# ::fileutil::maketempdir -- + +proc ::fileutil::maketempdir {args} { + return [Normalize [MakeTempDir $args]] +} + +proc ::fileutil::MakeTempDir {config} { + # Setup of default configuration. + array set options {} + set options(-suffix) "" + set options(-prefix) "tmp" + set options(-dir) [tempdir] + + # TODO: Check for and reject options not in -suffix, -prefix, -dir + # Merge user configuration, overwrite defaults. + array set options $config + + # See also "tempfile" below. Could be shareable internal configuration. + set chars abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 + set nrand_chars 10 + set maxtries 10 + + for {set i 0} {$i < $maxtries} {incr i} { + # Build up the candidate name. See also "tempfile". + set directory_name $options(-prefix) + for {set j 0} {$j < $nrand_chars} {incr j} { + append directory_name \ + [string index $chars [expr {int(rand() * 62)}]] + } + append directory_name $options(-suffix) + set path [file join $options(-dir) $directory_name] + + # Try to create. Try again if already exists, or trouble + # with creation and setting of perms. + # + # Note: The last looks as if it is able to leave partial + # directories behind (created, trouble with perms). But + # deleting ... Might pull the rug out from somebody else. + + if {[file exists $path]} continue + if {[catch { + file mkdir $path + if {$::tcl_platform(platform) eq "unix"} { + file attributes $path -permissions 0700 + } + }]} continue + + return $path + } + return -code error "Failed to find an unused temporary directory name" +} + +# ::fileutil::tempfile -- +# +# generate a temporary file name suitable for writing to +# the file name will be unique, writable and will be in the +# appropriate system specific temp directory +# Code taken from http://mini.net/tcl/772 attributed to +# Igor Volobouev and anon. +# +# Arguments: +# prefix - a prefix for the filename, p +# Results: +# returns a file name +# + +proc ::fileutil::tempfile {{prefix {}}} { + return [Normalize [TempFile $prefix]] +} + +proc ::fileutil::TempFile {prefix} { + set tmpdir [tempdir] + + set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + set nrand_chars 10 + set maxtries 10 + set access [list RDWR CREAT EXCL] + set permission 0600 + set channel "" + set checked_dir_writable 0 + + for {set i 0} {$i < $maxtries} {incr i} { + set newname $prefix + for {set j 0} {$j < $nrand_chars} {incr j} { + append newname [string index $chars \ + [expr {int(rand()*62)}]] + } + set newname [file join $tmpdir $newname] + + if {[catch {open $newname $access $permission} channel]} { + if {!$checked_dir_writable} { + set dirname [file dirname $newname] + if {![file writable $dirname]} { + return -code error "Directory $dirname is not writable" + } + set checked_dir_writable 1 + } + } else { + # Success + close $channel + return $newname + } + + } + if {[string compare $channel ""]} { + return -code error "Failed to open a temporary file: $channel" + } else { + return -code error "Failed to find an unused temporary file name" + } +} + +# ::fileutil::install -- +# +# Tcl version of the 'install' command, which copies files from +# one places to another and also optionally sets some attributes +# such as group, owner, and permissions. +# +# Arguments: +# -m Change the file permissions to the specified +# value. Valid arguments are those accepted by +# file attributes -permissions +# +# Results: +# None. + +# TODO - add options for group/owner manipulation. + +proc ::fileutil::install {args} { + set options { + {m.arg "" "Set permission mode"} + } + set usage ": [lindex [info level 0] 0]\ +\[options] source destination \noptions:" + array set params [::cmdline::getoptions args $options $usage] + # Args should now just be the source and destination. + if { [llength $args] < 2 } { + return -code error $usage + } + set src [lindex $args 0] + set dst [lindex $args 1] + file copy -force $src $dst + if { $params(m) != "" } { + set targets [::fileutil::find $dst] + foreach fl $targets { + file attributes $fl -permissions $params(m) + } + } +} + +# ### ### ### ######### ######### ######### + +proc ::fileutil::lexnormalize {sp} { + set spx [file split $sp] + + # Resolution of embedded relative modifiers (., and ..). + + if { + ([lsearch -exact $spx . ] < 0) && + ([lsearch -exact $spx ..] < 0) + } { + # Quick path out if there are no relative modifiers + return $sp + } + + set absolute [expr {![string equal [file pathtype $sp] relative]}] + # A volumerelative path counts as absolute for our purposes. + + set sp $spx + set np {} + set noskip 1 + + while {[llength $sp]} { + set ele [lindex $sp 0] + set sp [lrange $sp 1 end] + set islast [expr {[llength $sp] == 0}] + + if {[string equal $ele ".."]} { + if { + ($absolute && ([llength $np] > 1)) || + (!$absolute && ([llength $np] >= 1)) + } { + # .. : Remove the previous element added to the + # new path, if there actually is enough to remove. + set np [lrange $np 0 end-1] + } + } elseif {[string equal $ele "."]} { + # Ignore .'s, they stay at the current location + continue + } else { + # A regular element. + lappend np $ele + } + } + if {[llength $np] > 0} { + return [eval [linsert $np 0 file join]] + # 8.5: return [file join {*}$np] + } + return {} +} + +# ### ### ### ######### ######### ######### +## Forward compatibility. Some routines require path normalization, +## something we have supported by the builtin 'file' only since Tcl +## 8.4. For versions of Tcl before that, to be supported by the +## module, we implement a normalizer in Tcl itself. Slow, but working. + +if {[package vcompare [package provide Tcl] 8.4] < 0} { + # Pre 8.4. We do not have 'file normalize'. We create an + # approximation for it based on earlier commands. + + # ... Hm. This is lexical normalization. It does not resolve + # symlinks in the path to their origin. + + proc ::fileutil::Normalize {sp} { + set sp [file split $sp] + + # Conversion of the incoming path to absolute. + if {[string equal [file pathtype [lindex $sp 0]] "relative"]} { + set sp [file split [eval [list file join [pwd]] $sp]] + } + + # Resolution of symlink components, and embedded relative + # modifiers (., and ..). + + set np {} + set noskip 1 + while {[llength $sp]} { + set ele [lindex $sp 0] + set sp [lrange $sp 1 end] + set islast [expr {[llength $sp] == 0}] + + if {[string equal $ele ".."]} { + if {[llength $np] > 1} { + # .. : Remove the previous element added to the + # new path, if there actually is enough to remove. + set np [lrange $np 0 end-1] + } + } elseif {[string equal $ele "."]} { + # Ignore .'s, they stay at the current location + continue + } else { + # A regular element. If it is not the last component + # then check if the combination is a symlink, and if + # yes, resolve it. + + lappend np $ele + + if {!$islast && $noskip} { + # The flag 'noskip' is technically not required, + # just 'file exists'. However if a path P does not + # exist, then all longer paths starting with P can + # not exist either, and using the flag to store + # this knowledge then saves us a number of + # unnecessary stat calls. IOW this a performance + # optimization. + + set p [eval file join $np] + set noskip [file exists $p] + if {$noskip} { + if {[string equal link [file type $p]]} { + set dst [file readlink $p] + + # We always push the destination in front of + # the source path (in expanded form). So that + # we handle .., .'s, and symlinks inside of + # this path as well. An absolute path clears + # the result, a relative one just removes the + # last, now resolved component. + + set sp [eval [linsert [file split $dst] 0 linsert $sp 0]] + + if {![string equal relative [file pathtype $dst]]} { + # Absolute|volrelative destination, clear + # result, we have to start over. + set np {} + } else { + # Relative link, just remove the resolved + # component again. + set np [lrange $np 0 end-1] + } + } + } + } + } + } + if {[llength $np] > 0} { + return [eval file join $np] + } + return {} + } +} else { + proc ::fileutil::Normalize {sp} { + file normalize $sp + } +} + +# ::fileutil::relative -- +# +# Taking two _directory_ paths, a base and a destination, computes the path +# of the destination relative to the base. +# +# Arguments: +# base The path to make the destination relative to. +# dst The destination path +# +# Results: +# The path of the destination, relative to the base. + +proc ::fileutil::relative {base dst} { + # Ensure that the link to directory 'dst' is properly done relative to + # the directory 'base'. + + if {![string equal [file pathtype $base] [file pathtype $dst]]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + set base [lexnormalize [file join [pwd] $base]] + set dst [lexnormalize [file join [pwd] $dst]] + + set save $dst + set base [file split $base] + set dst [file split $dst] + + while {[string equal [lindex $dst 0] [lindex $base 0]]} { + set dst [lrange $dst 1 end] + set base [lrange $base 1 end] + if {![llength $dst]} {break} + } + + set dstlen [llength $dst] + set baselen [llength $base] + + if {($dstlen == 0) && ($baselen == 0)} { + # Cases: + # (a) base == dst + + set dst . + } else { + # Cases: + # (b) base is: base/sub = sub + # dst is: base = {} + + # (c) base is: base = {} + # dst is: base/sub = sub + + while {$baselen > 0} { + set dst [linsert $dst 0 ..] + incr baselen -1 + } + # 8.5: set dst [file join {*}$dst] + set dst [eval [linsert $dst 0 file join]] + } + + return $dst +} + +# ::fileutil::relativeUrl -- +# +# Taking two _file_ paths, a base and a destination, computes the path +# of the destination relative to the base, from the inside of the base. +# +# This is how a browser resolves relative links in a file, hence the +# url in the command name. +# +# Arguments: +# base The file path to make the destination relative to. +# dst The destination file path +# +# Results: +# The path of the destination file, relative to the base file. + +proc ::fileutil::relativeUrl {base dst} { + # Like 'relative', but for links from _inside_ a file to a + # different file. + + if {![string equal [file pathtype $base] [file pathtype $dst]]} { + return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)" + } + + set base [lexnormalize [file join [pwd] $base]] + set dst [lexnormalize [file join [pwd] $dst]] + + set basedir [file dirname $base] + set dstdir [file dirname $dst] + + set dstdir [relative $basedir $dstdir] + + # dstdir == '.' on input => dstdir output has trailing './'. Strip + # this superfluous segment off. + + if {[string equal $dstdir "."]} { + return [file tail $dst] + } elseif {[string equal [file tail $dstdir] "."]} { + return [file join [file dirname $dstdir] [file tail $dst]] + } else { + return [file join $dstdir [file tail $dst]] + } +} + +# ::fileutil::fullnormalize -- +# +# Normalizes a path completely. I.e. a symlink in the last +# element is resolved as well, not only symlinks in the higher +# elements. +# +# Arguments: +# path The path to normalize +# +# Results: +# The input path with all symlinks resolved. + +proc ::fileutil::fullnormalize {path} { + # When encountering symlinks in a file copy operation Tcl copies + # the link, not the contents of the file it references. There are + # situations there this is not acceptable. For these this command + # resolves all symbolic links in the path, including in the last + # element of the path. A "file copy" using the return value of + # this command copies an actual file, it will not encounter + # symlinks. + + # BUG / WORKAROUND. Using the / instead of the join seems to work + # around a bug in the path handling on windows which can break the + # core 'file normalize' for symbolic links. This was exposed by + # the find testsuite which could not reproduced outside. I believe + # that there is some deep path bug in the core triggered under + # special circumstances. Use of / likely forces a refresh through + # the string rep and so avoids the problem with the path intrep. + + return [file dirname [Normalize $path/__dummy__]] + #return [file dirname [Normalize [file join $path __dummy__]]] +} diff --git a/src/vendormodules/overtype-1.5.6.tm b/src/vendormodules/overtype-1.5.6.tm new file mode 100644 index 00000000..5c56838b --- /dev/null +++ b/src/vendormodules/overtype-1.5.6.tm @@ -0,0 +1,928 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 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 - 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|]? ?-exposed1 ? ?-exposed2 ? ?-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 ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-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 ? ?-transparent [0|1|]? ?-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 ? ?-transparent [0|1|]? ?-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 ]] 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] diff --git a/src/vendormodules/overtype-1.5.7.tm b/src/vendormodules/overtype-1.5.7.tm new file mode 100644 index 00000000..c48990c6 --- /dev/null +++ b/src/vendormodules/overtype-1.5.7.tm @@ -0,0 +1,1034 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 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 - 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|]? ?-exposed1 ? ?-exposed2 ? ?-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 ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-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 ? ?-transparent [0|1|]? ?-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 ? ?-transparent [0|1|]? ?-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 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]; #SGR codestack (not other codes such as movement,insert key etc) + set pt_overchars "" + set i_o 0 + set grapheme_control_list [list] ;#tag each with g or c c are things like cursor-movement or insert-mode etc + 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 + lappend grapheme_control_list [list g $grapheme] + } + + 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 + } else { + lappend grapheme_control_list [list c $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 + #change to for loop? + 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 "D"} { + #left-arrow/move-back + if {$num eq ""} {set num 1} + set num [expr {$num -1}] ;#our index already moved forward 1 + incr idx -$num + if {$idx < $opt_colstart} { + set idx $opt_colstart + } + } elseif {$type eq "C"} { + #right-arrow/move forward + if {$num eq ""} {set num 1} + set num [expr {$num -1}] ;#our index already moved forward 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 ]] 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 + } + proc render_insertchar {i c stack} { + upvar outcols o + upvar understacks ustacks + set nxt [llength $o] + if {$i < $nxt} { + set o [linsert $o $i $i $c] + } else { + lappend o $c + } + #rewrite our whole understacks + #for inserts - the dict is less than ideal - but inserts are presumably the less common case + #dict set ustacks $i $stack + set new [dict create] + dict for {k v} $ustacks { + if {$k < $i} { + dict set new $k $v + } elseif {$k == $i} { + dict set new $k $stack + dict set new [expr {$k+1}] $v + } else { + dict set new [expr {$k+1}] $v + } + } + set ustacks $new + + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +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] diff --git a/src/vendormodules/overtype-1.5.8.tm b/src/vendormodules/overtype-1.5.8.tm new file mode 100644 index 00000000..86d61b69 --- /dev/null +++ b/src/vendormodules/overtype-1.5.8.tm @@ -0,0 +1,1547 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) Julian Noble 2003-2023 +# +# @@ Meta Begin +# Application overtype 1.5.8 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin overtype_module_overtype 0 1.5.8] +#[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 - 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 grapheme_widths [dict create] + + 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::ansifreestring_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] + if {[punk::ansi::ta::detect_sgr [lindex $underlines 0]]} { + set replay_codes "[a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set undertext_printlen [punk::ansi::printing_length $undertext] + if {$undertext_printlen < $colwidth} { + set udiff [expr {$colwidth - $undertext_printlen}] + append undertext [string repeat { } $udiff] + } + set overtext_printlen [punk::ansi::printing_length $overtext] + set overflowlength [expr {$overtext_printlen - $colwidth}] + + + set overtext [string cat $replay_codes_overlay $overtext] + set undertext [string cat $replay_codes_underlay $undertext] + if {$overflowlength > 0} { + #background line is narrower than data in line + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow [dict get $opts -overflow] $undertext $overtext] + set rendered [dict get $rinfo result] + + 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 + #review - ansi codes in overlay's overflow? + 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 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + lappend outputlines [dict get $rinfo result] + } + set replay_codes_underlay [dict get $rinfo replay_codes_underlay] + set replay_codes_overlay [dict get $rinfo replay_codes_overlay] + } + return [join $outputlines \n] + +} + +namespace eval overtype::piper { + proc overcentre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-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 ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-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] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + 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 undertext [string cat $replay_codes_underlay $undertext] + set overtext [string cat $replay_codes_overlay $overtext] + + 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 rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [dict get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rendered [dict get $rinfo result] + #todo - get replay_codes from overflow_right instead of wherever it was truncated? + + #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 -insert_mode 0 -transparent $opt_transparent $undertext $overtext] + } else { + #background block is wider than or equal to data for this line + #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + lappend outputlines [dict get $rinfo result] + } + set replay_codes_underlay [dict get $rinfo replay_codes_underlay] + set replay_codes_overlay [dict get $rinfo replay_codes_overlay] + } + 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]? ?-transparent 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\ + -align "left"\ + ] + 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 opt_align [dict get $opts -align] + # -- --- --- --- --- --- + + 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 {max(0,$colwidth - $overblock_width)}] + set left_exposed $under_exposed_max + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + 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 + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + if {$opt_align eq "left"} { + set startoffset 0 + } elseif {$opt_align eq "right"} { + set startoffset $odiff + } else { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } else { + set startoffset 0 ;#negative? + } + + set undertext [string cat $replay_codes_underlay $undertext] + set overtext [string cat $replay_codes_overlay $overtext] + + set overflowlength [expr {$overtext_datalen - $colwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] + set replay_codes [dict get $rinfo replay_codes] + set rendered [dict get $rinfo result] + 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 ellipsis [string cat $replay_codes $opt_ellipsistext] + #todo - overflow on left if allign = right?? + set rendered [overtype::right $rendered $ellipsis] + } + } + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + lappend outputlines [dict get $rinfo result] + } + set replay_codes [dict get $rinfo replay_codes] + set replay_codes_underlay [dict get $rinfo replay_codes_underlay] + set replay_codes_overlay [dict get $rinfo replay_codes_overlay] + } + + 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 ? ?-transparent [0|1|]? ?-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 + +#intended for single grapheme - but will work for multiple +#cannot contain ansi or newlines +#(a cache of ansifreestring_width calls - as these are quite regex heavy) +proc overtype::grapheme_width_cached {ch} { + variable grapheme_widths + if {[dict exists $grapheme_widths $ch]} { + return [dict get $grapheme_widths $ch] + } + set width [punk::char::ansifreestring_width $ch] + dict set grapheme_widths $ch $width + return $width +} +#-returnextra to enable returning of overflow and length +#review - use punk::ansi::ta::detect to short-circuit processing and do simpler 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 ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} + } + lassign [lrange $args end-1 end] under over + if {[string first \n $under] >= 0} { + error "overtype::renderline not allowed to contain newlines in undertext" + } + #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\ + -cursor_column 1\ + -cursor_row ""\ + -insert_mode 1\ + -info 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return + #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs + + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow + #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error + + 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] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay + set opt_colcursor [dict get $opts -cursor_column];#start cursor column relative to overlay + set opt_row_context [dict get $opts -cursor_row] + if {[string length $opt_row_context]} { + if {![string is integer -strict $opt_row_context] || $opt_row_context <1 } { + error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" + } + } + set opt_insert_mode [dict get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) + #default is for overtype + # -- --- --- --- --- --- --- --- --- --- --- --- + 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 {$opt_row_context eq ""} { + set cursor_row 0 ;#we aren't allowed to make assumptions about our context. zero represents cursor_row_change - not an absolute row (for which zero is invalid anyway) + } else { + set cursor_row "=$opt_row_context" ;#we are at this row number in the greater context - allow moves that explicitly refer to this row without returning prematurely + } + + + #----- + # + 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? + + #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, + #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. + + # -- --- --- --- --- --- --- --- + set undermap [punk::ansi::ta::split_codes_single $under] + set understacks [dict create] + + set i_u -1 ;#underlay may legitimately be empty + set undercols [list] + set u_codestack [list] + #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway + set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) + set understacks_gx [dict create] + 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 [grapheme_width_cached $grapheme] + incr i_u + dict set understacks $i_u $u_codestack + dict set understacks_gx $i_u $u_gx_stack + + lappend undercols $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 + dict set understacks_gx $i_u $u_gx_stack + lappend undercols "" + } + } + + #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 + } else { + #leave SGR stack as is + if {[punk::ansi::codetype::is_gx_open $code]} { + set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + set u_gx_stack [list] + } + + } + + #consider also if there are other codes that should be stacked..? + } + + #trailing codes in effect for underlay + #replay code for last overlay position in input line + # whether or not we get that far - we need to return it for possible replay on next line + if {[llength $undermap]} { + dict set understacks [expr {$i_u + 1}] $u_codestack ;#This is one column higher than our input + set replay_codes_underlay [join $u_codestack ""] + + # For gx we need the column after the data too ? + dict set understacks_gx [expr {$i_u +1}] $u_gx_stack + } else { + set replay_codes_underlay "" + #in case overlay onto emptystring as underlay + dict set understacks 0 [list] + dict set understacks_gx 0 [list] + } + #note - be careful.. understacks 1 bigger than input - for insertion at end (review) + + + # -- --- --- --- --- --- --- --- + #### + #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_overlay [string repeat " " [expr {$opt_colstart -1}]] + append startpad_overlay $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_overlay] + #### + + #??? + 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 overstacks_gx [dict create] + set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) + set o_gxstack [list] + set pt_overchars "" + set i_o 0 + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use + foreach {pt code} $overmap { + append pt_overchars $pt + #will get empty pt between adjacent codes + foreach grapheme [punk::char::grapheme_split $pt] { + dict set overstacks $i_o $o_codestack + dict set overstacks_gx $i_o $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + } + + #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 {$code ne ""} { + #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + lappend o_codestack $code + lappend overlay_grapheme_control_list [list sgr $code] + } else { + if {[punk::ansi::codetype::is_gx_open $code]} { + set o_gxstack [list "gx0_on"] + lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + set o_gxstack [list] + lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } else { + lappend overlay_grapheme_control_list [list other $code] + } + } + } + + } + #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme + set max_overlay_grapheme_index [expr {$i_o -1}] + dict set overstacks $i_o $o_codestack + dict set overstacks_gx $i_o $o_gxstack + set replay_codes_overlay [join $o_codestack ""] + + #if {[dict exists $overstacks $max_overlay_grapheme_index]} { + # set replay_codes_overlay [join [dict get $overstacks $max_overlay_grapheme_index] ""] + #} else { + # set replay_codes_overlay "" + #} + # -- --- --- --- --- --- --- --- + + + #potential problem - combinining diacritics directly following control chars like \r \b + + #we need to initialise overflow_idx before any potential row-movements - as they need to break and force in_overflow to 1 + if {$opt_overflow} { + set overflow_idx -1 + } else { + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. + + set unapplied "" ;#if we break for move row (but not for /v ?) + set insert_lines_above 0 ;#return key + set insert_lines_below 0 + + #set idx 0 ;# line index (cursor - 1) + #set idx [expr {$opt_colstart + $opt_colcursor} -1] + set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 + set idx_over -1 + + + #movements only occur within the overlay range. + #an underlay is however not necessary.. e.g + #renderline -overflow 1 "" data + #foreach {pt code} $overmap {} + set insert_mode $opt_insert_mode ;#default 1 + set in_overflow 0 + #puts "-->$overlay_grapheme_control_list<--" + #puts "-->overflow_idx: $overflow_idx" + for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { + set gc [lindex $overlay_grapheme_control_list $gci] + lassign $gc type item + + #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 {} + if {$type eq "g"} { + set ch $item + incr idx_over + if {$overflow_idx != -1 && $idx == $overflow_idx } { + #review 2w overflow? + set in_overflow 1 + #first overstack codeset only + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode + incr idx + continue + } + + set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our original data width + + if {$in_overflow} { + #render any char - even \b\v\r into outcols - will become part of overflow + #no stacks added from here on - raw codes go into overflow/remainder + priv::render_addchar $idx $ch [list] [list] $insert_mode + incr idx ;#width doesn't matter from here + } elseif {$ch eq "\n"} { + if {$cursor_row eq 0} { + incr cursor_row + } elseif {$cursor_row eq "=$opt_row_context"} { + set cursor_row "=[expr {$opt_row_context +1}]" ;#we can return an absolute next cursor row + } else { + #we should have already returned if cursor_row is not 1 or "=$opt_row_context" + error "overtype::renderline bad cursor_row $cursor_row encountered when \v encountered" + } + #override overflow_idx even if it was set to -1 due to opt_overflow = 1 + set overflow_idx $idx + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + append unapplied [join [dict get $overstacks $idx_over] ""] + if {[dict get $overstacks_gx $idx_over] eq "gx0_on"} { + append unapplied "\x1b(0" + } elseif {[dict get $overstacks_gx $idx_over] eq "gx0_off"} { + append unapplied "\x1b(B" + } + + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + append unapplied "\x1b(0" + } elseif {$item eq "gx0_off"} { + append unapplied "\x1b(B" + } + } else { + append unapplied $item + } + incr idx_over + } + if {$idx == 0} { + set insert_lines_above 1 + } else { + set insert_lines_below 1 + } + break + } elseif {$ch eq "\r"} { + set idx [expr {$opt_colstart -1}] + } elseif {$ch eq "\b"} { + #review - backspace effect on double-width chars + #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) + if {$idx > ($opt_colstart -1)} { + incr idx -1 + } + } elseif {$ch eq "\v"} { + #end processing this overline. rest of line is remainder. cursor for column as is. + if {$cursor_row eq 0} { + incr cursor_row + } elseif {$cursor_row eq "=$opt_row_context"} { + set cursor_row "=[expr {$opt_row_context +1}]" ;#we can return an absolute next cursor row + } else { + #we should have already returned if cursor_row is not 1 or "=$opt_row_context" + error "overtype::renderline bad cursor_row $cursor_row encountered when \v encountered" + } + #override overflow_idx even if it was set to -1 due to opt_overflow = 1 + set overflow_idx [expr $idx] + set in_overflow 1 + incr idx + #break + } 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 { + #todo - punk::char::char_width + set g [lindex $outcols $idx] + set uwidth [grapheme_width_cached $g] + 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 [grapheme_width_cached $ch] + incr idx + if {$owidth > 1} { + incr idx + } + } elseif {$uwidth > 1} { + if {[grapheme_width_cached $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] [dict get $overstacks_gx $idx_over] $insert_mode + incr idx + } + } + } else { + #2wide transparency over 2wide in underlay + incr idx + } + } + } + } else { + #non-transparent char in overlay + set uwidth [grapheme_width_cached [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] [dict get $overstacks_gx $idx_over] $insert_mode + #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}]] [dict get $understacks_gx [expr {$idx-1}]] $insert_mode + } + 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] [dict get $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode + incr idx + } else { + #overflow + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode + incr idx + } + } elseif {$uwidth == 1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode + incr idx + } else { + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx "" [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode + #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}]] [dict get $understacks_gx [expr {$idx+1}]] $insert_mode + } + incr idx + } + } elseif {$uwidth > 1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + priv::render_addchar $idx $ch [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx $opt_exposed2 [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode + #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] [dict get $overstacks_gx $idx_over] $insert_mode + incr idx 2 + } + } + } + } elseif {$type eq "other"} { + set code $item + if {$in_overflow} { + #render controls into overflow/remainder output + priv::render_addchar $idx $code [list] [list] $insert_mode + incr idx ;#take up a column for each control sequence too + continue + } + + #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)$} + set re_row_move {\x1b\[([0-9]*)(A|B)$} + set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} + set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} + if {[regexp $re_col_move $code _match num type]} { + if {$type eq "D"} { + #left-arrow/move-back + if {$num eq ""} {set num 1} + incr idx -$num + if {$idx < $opt_colstart-1} { + #wrap to previous line and position cursor at end of data + set idx [expr {$opt_colstart-1}] + } + } elseif {$type eq "C"} { + #right-arrow/move forward + if {$num eq ""} {set num 1} + + #todo - retrict to moving 1 position past datalen? restrict to column width? + #should ideally wrap to next line + if {!$opt_overflow || ($idx + $num) <= [llength $outcols]-1} { + incr idx $num + + if {$idx > [llength $outcols]-1} { + set idx [expr {[llength $outcols] -1}] + } + } else { + if {!$insert_mode} { + #block editing style with arrow keys + set idxstart $idx + set idxend [expr {[llength $outcols]}] + set moveend [expr {$idxend - $idxstart}] + if {$moveend < 0} {set moveend 0} ;#sanity? + #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" + incr idx $moveend + if {[dict exists $understacks $idx]} { + set stackinfo [dict get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + } else { + set stackinfo [list] + } + if {[dict exists $understacks_gx $idx]} { + set gxstackinfo [dict get $understacks_gx $idx] + } else { + set gxstackinfo [list] + } + #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 $gxstackinfo $insert_mode + } + } else { + #normal + incr idx $num + if {$idx > [llength $outcols]-1} { + set idx [expr {[llength $outcols] -1}] + } + } + } + } 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" + } + } elseif {[regexp $re_row_move $code _match num type]} { + if {$type eq "A"} { + #move up + if {$num eq ""} {set num 1} + if {$cursor_row eq 0} { + incr cursor_row -1 ;#relative change + } elseif {$cursor_row eq "=$opt_row_context"} { + set cursor_row "=[expr {$opt_row_context -1}]" ;#we can return an absolute next cursor row + } else { + #we should have already returned if cursor_row is not 1 or "=$opt_row_context" + error "overtype::renderline bad cursor_row $cursor_row encountered when \v encountered" + } + #ensure rest of *overlay* is emitted to remainder + incr idx + break + } elseif {$type eq "B"} { + #move down + if {$num eq ""} {set num 1} + if {$cursor_row eq 0} { + incr cursor_row 1 ;#relative change + } elseif {$cursor_row eq "=$opt_row_context"} { + set cursor_row "=[expr {$opt_row_context +1}]" ;#we can return an absolute next cursor row + } else { + #we should have already returned if cursor_row is not 1 or "=$opt_row_context" + error "overtype::renderline bad cursor_row $cursor_row encountered when \v encountered" + } + #set overflow_idx $idx ;#ensure rest of line is emitted to remainder + incr idx + break + } + } elseif {[regexp $re_vt_sequence $code _match key mod]} { + #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ + # + #e.g esc \[2~ insert esc \[2;2~ shift-insert + #mod - subtract 1, and then use bitmask + #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) + puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" + if {$key eq "1"} { + #home + } elseif {$key eq "2"} { + #Insert + if {$mod eq ""} { + #no modifier key + set insert_mode [expr {!$insert_mode}] + #rather than set the cursor - we return the insert mode state so the caller can decide + } + } elseif {$key eq "3"} { + #Delete + } elseif {$key eq "4"} { + #End + } elseif {$key eq "5"} { + #pgup + } elseif {$key eq "6"} { + #pgDn + } elseif {$key eq "7"} { + #Home + } elseif {$key eq "8"} { + #End + } elseif {$key eq "11"} { + #F1 - or ESCOP or e.g shift F1 ESC\[1;2P + } elseif {$key eq "12"} { + #F2 - or ESCOQ + } elseif {$key eq "13"} { + #F3 - or ESCOR + } elseif {$key eq "14"} { + #F4 - or ESCOS + } elseif {$key eq "15"} { + #F5 or shift F5 ESC\[15;2~ + } elseif {$key eq "17"} { + #F6 + } elseif {$key eq "18"} { + #F7 + } elseif {$key eq "19"} { + #F8 + } elseif {$key eq "20"} { + #F9 + } elseif {$key eq "21"} { + #F10 + } elseif {$key eq "23"} { + #F11 + } elseif {$key eq "24"} { + #F12 + } + } + } elseif {$type eq "sgr"} { + #prior to overflow - we have our sgr codes already in stacks + #post-overflow we need to keep them in order along with non sgr codes and graphemes + if {$in_overflow} { + set code $item + #render controls into output - will become overflow/remainder + priv::render_addchar $idx $code [list] [list] $insert_mode + incr idx ;#take up a column for each control sequence too + } + } elseif {$type eq "gx0"} { + if {$in_overflow} { + set code $item + if {$code eq "gx0_on"} { + set actual "\x1b(0" + } else { + set actual "\x1b(B" + } + priv::render_addchar $idx $actual [list] [list] $insert_mode + incr idx + } + + } + } + + #-------------- + if {$in_overflow} { + #set cursor_column [expr {$overflow_idx -1}] + set cursor_column [expr {$overflow_idx +1}] + } else { + set cursor_column [expr {$idx+1}] + } + + + 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 + } + if {$overflow_idx == -1} { + #overflow was initially unlimited and hasn't been overridden + } else { + + } + + + #coalesce and replay codestacks for outcols grapheme list + set outstring "" + set overflow_right "" ;#remainder after overflow point reached + set i 0 + set cstack [list] + set prevstack [list] + set prev_g0 [list] + set out_rawchars ""; #for overflow counting - review - not really 'raw' + set output_to "outstring" ;#var in effect depending on overflow + #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves + set in_overflow 0 ;#used to stop char-width scanning once in overflow + foreach ch $outcols { + #puts "---- [ansistring VIEW $ch]" + if {$overflow_idx != -1 && $i == $overflow_idx-1} { + if {[grapheme_width_cached $ch]> 1} { + #check if we overflowed with a double-width char + append out_rawchars $opt_exposed1 + set ch $opt_exposed1 + } else { + append out_rawchars $ch + } + } else { + append out_rawchars $ch + } + + if {$overflow_idx != -1 && $i == $overflow_idx} { + #only run when we exactly hit overflow_idx + + if {[dict exists $understacks_gx $i]} { + set g0 [dict get $understacks_gx $i] + if {[llength $g0]} { + append outstring "\x1b(B" + } + } + + set in_overflow 1 + if {[set visualwidth [punk::char::string_width $out_rawchars]] > [expr {$overflow_idx + 1}]} { + puts stderr "warning - overflow column exceeded" + } + #add first codestack only + if {[dict exists $understacks $i]} { + set cstack [dict get $understacks $i] + foreach code $cstack { + append overflow_right $code + } + } + } + if {$in_overflow} { + #ch could be a control-sequence or a grapheme once in overflow + set output_to "overflow_right" + } else { + if {[dict exists $understacks_gx $i]} { + set g0 [dict get $understacks_gx $i] + if {$g0 ne $prev_g0} { + if {$g0 eq [list "gx0_on"]} { + append $output_to "\x1b(0" + } else { + append $output_to "\x1b(B" + } + } + set prev_g0 $g0 + } else { + set prev_g0 [list] + } + #code replay when not in overflow + if {[dict exists $understacks $i]} { + 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 + } + } + set prevstack $cstack + } else { + set prevstack [list] + } + } + append $output_to $ch + incr i + } + + set replay_codes "" + if {[dict size $understacks] > 0} { + if {$overflow_idx == -1} { + set tail_idx [dict size $understacks] + } else { + set tail_idx [llength $undercols] + } + if {[dict exists $understacks [expr {$tail_idx-1}]]} { + set replay_codes [join [dict get $understacks [expr {$tail_idx-1}]] ""] ;#tail replay codes + } + if {[dict exists $understacks_gx [expr {$tail_idx-1}]]} { + set gx0 [dict get $understacks_gx [expr {$tail_idx-1}]] + if {$gx0 eq [list "gx0_on"]} { + #if it was on, turn gx0 off at the point we stop processing overlay + append outstring "\x1b(B" + } + } + } + if {[string length $overflow_right]} { + #puts stderr "remainder:$overflow_right" + } + #pdict $understacks + if {[punk::ansi::ta::detect_sgr $outstring]} { + append outstring [a] + } + if {$opt_returnextra} { + #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review + #replay_codes_underlay is the set of codes in effect at the very end of the original underlay + #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) + #todo - replay_codes for gx0 mode + return [list\ + result $outstring\ + visualwidth [punk::ansi::printing_length $outstring]\ + stringlen [string length $outstring]\ + overflow_idx $overflow_idx\ + overflow_right $overflow_right\ + unapplied $unapplied\ + insert_mode $insert_mode\ + insert_lines_above $insert_lines_above\ + insert_lines_below $insert_lines_below\ + cursor_column $cursor_column\ + cursor_row_change $cursor_row\ + replay_codes $replay_codes\ + replay_codes_underlay $replay_codes_underlay\ + replay_codes_overlay $replay_codes_overlay\ + ] + } 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::ansifreestring_width $v}]] + } else { + set width [punk::char::ansifreestring_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 ]] width height +} + +namespace eval overtype::priv { + variable cache_is_sgr [dict create] + + #we are likely to be asking the same question of the same ansi codes repeatedly + #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS + #todo - test if still worthwhile after a large cache is built up. (limit cache size?) + proc is_sgr {code} { + variable cache_is_sgr + if {[dict exists $cache_is_sgr $code]} { + return [dict get $cache_is_sgr $code] + } + set answer [punk::ansi::codetype::is_sgr $code] + dict set cache_is_sgr $code $answer + return $answer + } + #is actually addgrapheme? + proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + + set nxt [llength $o] + if {!$insert_mode} { + if {$i < $nxt} { + lset o $i $c + } else { + lappend o $c + } + dict set ustacks $i $sgrstack + dict set gxstacks $i $gx0stack + } else { + if {$i < $nxt} { + set o [linsert $o $i $c] + } else { + lappend o $c + } + #rewrite our whole understacks + #for inserts - the dict structure of the ansi stacks is less than ideal. + set new [dict create] + dict for {k v} $ustacks { + if {$k < $i} { + dict set new $k $v + } elseif {$k == $i} { + dict set new $k $sgrstack + dict set new [expr {$k+1}] $v + } else { + dict set new [expr {$k+1}] $v + } + } + set ustacks $new + + set new [dict create] + dict for {k v} $gxstacks { + if {$k < $i} { + dict set new $k $v + } elseif {$k == $i} { + dict set new $k $gx0stack + dict set new [expr {$k+1}] $v + } else { + dict set new [expr {$k+1}] $v + } + } + set gxstacks $new + } + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +namespace eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [namespace eval overtype { + variable version + set version 1.5.8 +}] +return + +#*** !doctools +#[manpage_end] diff --git a/src/vendormodules/struct/list-1.8.5.tm b/src/vendormodules/struct/list-1.8.5.tm new file mode 100644 index 00000000..e0f738db --- /dev/null +++ b/src/vendormodules/struct/list-1.8.5.tm @@ -0,0 +1,1834 @@ +#---------------------------------------------------------------------- +# +# list.tcl -- +# +# Definitions for extended processing of Tcl lists. +# +# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: list.tcl,v 1.27 2011/09/17 14:35:36 mic42 Exp $ +# +#---------------------------------------------------------------------- + +package require Tcl 8.4 +package require cmdline + +namespace eval ::struct { namespace eval list {} } + +namespace eval ::struct::list { + namespace export list + + if {0} { + # Possibly in the future. + namespace export Lassign + namespace export LdbJoin + namespace export LdbJoinOuter + namespace export Ldelete + namespace export Lequal + namespace export Lfilter + namespace export Lfilterfor + namespace export Lfirstperm + namespace export Lflatten + namespace export Lfold + namespace export Lforeachperm + namespace export Liota + namespace export LlcsInvert + namespace export LlcsInvert2 + namespace export LlcsInvertMerge + namespace export LlcsInvertMerge2 + namespace export LlongestCommonSubsequence + namespace export LlongestCommonSubsequence2 + namespace export Lmap + namespace export Lmapfor + namespace export Lnextperm + namespace export Lpermutations + namespace export Lrepeat + namespace export Lrepeatn + namespace export Lreverse + namespace export Lshift + namespace export Lswap + namespace export Lshuffle + } +} + +########################## +# Public functions + +# ::struct::list::list -- +# +# Command that access all list commands. +# +# Arguments: +# cmd Name of the subcommand to dispatch to. +# args Arguments for the subcommand. +# +# Results: +# Whatever the result of the subcommand is. + +proc ::struct::list::list {cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 1 } { + return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" + } + set sub L$cmd + if { [llength [info commands ::struct::list::$sub]] == 0 } { + set optlist [info commands ::struct::list::L*] + set xlist {} + foreach p $optlist { + lappend xlist [string range $p 1 end] + } + return -code error \ + "bad option \"$cmd\": must be [linsert [join $xlist ", "] "end-1" "or"]" + } + return [uplevel 1 [linsert $args 0 ::struct::list::$sub]] +} + +########################## +# Private functions follow + +proc ::struct::list::K { x y } { set x } + +########################## +# Implementations of the functionality. +# + +# ::struct::list::LlongestCommonSubsequence -- +# +# Computes the longest common subsequence of two lists. +# +# Parameters: +# sequence1, sequence2 -- Two lists to compare. +# maxOccurs -- If provided, causes the procedure to ignore +# lines that appear more than $maxOccurs times +# in the second sequence. See below for a discussion. +# Results: +# Returns a list of two lists of equal length. +# The first sublist is of indices into sequence1, and the +# second sublist is of indices into sequence2. Each corresponding +# pair of indices corresponds to equal elements in the sequences; +# the sequence returned is the longest possible. +# +# Side effects: +# None. +# +# Notes: +# +# While this procedure is quite rapid for many tasks of file +# comparison, its performance degrades severely if the second list +# contains many equal elements (as, for instance, when using this +# procedure to compare two files, a quarter of whose lines are blank. +# This drawback is intrinsic to the algorithm used (see the References +# for details). One approach to dealing with this problem that is +# sometimes effective in practice is arbitrarily to exclude elements +# that appear more than a certain number of times. This number is +# provided as the 'maxOccurs' parameter. If frequent lines are +# excluded in this manner, they will not appear in the common subsequence +# that is computed; the result will be the longest common subsequence +# of infrequent elements. +# +# The procedure struct::list::LongestCommonSubsequence2 +# functions as a wrapper around this procedure; it computes the longest +# common subsequence of infrequent elements, and then subdivides the +# subsequences that lie between the matches to approximate the true +# longest common subsequence. +# +# References: +# J. W. Hunt and M. D. McIlroy, "An algorithm for differential +# file comparison," Comp. Sci. Tech. Rep. #41, Bell Telephone +# Laboratories (1976). Available on the Web at the second +# author's personal site: http://www.cs.dartmouth.edu/~doug/ + +proc ::struct::list::LlongestCommonSubsequence { + sequence1 + sequence2 + {maxOccurs 0x7fffffff} +} { + # Construct a set of equivalence classes of lines in file 2 + + set index 0 + foreach string $sequence2 { + lappend eqv($string) $index + incr index + } + + # K holds descriptions of the common subsequences. + # Initially, there is one common subsequence of length 0, + # with a fence saying that it includes line -1 of both files. + # The maximum subsequence length is 0; position 0 of + # K holds a fence carrying the line following the end + # of both files. + + lappend K [::list -1 -1 {}] + lappend K [::list [llength $sequence1] [llength $sequence2] {}] + set k 0 + + # Walk through the first file, letting i be the index of the line and + # string be the line itself. + + set i 0 + foreach string $sequence1 { + # Consider each possible corresponding index j in the second file. + + if { [info exists eqv($string)] + && [llength $eqv($string)] <= $maxOccurs } { + + # c is the candidate match most recently found, and r is the + # length of the corresponding subsequence. + + set r 0 + set c [lindex $K 0] + + foreach j $eqv($string) { + # Perform a binary search to find a candidate common + # subsequence to which may be appended this match. + + set max $k + set min $r + set s [expr { $k + 1 }] + while { $max >= $min } { + set mid [expr { ( $max + $min ) / 2 }] + set bmid [lindex [lindex $K $mid] 1] + if { $j == $bmid } { + break + } elseif { $j < $bmid } { + set max [expr {$mid - 1}] + } else { + set s $mid + set min [expr { $mid + 1 }] + } + } + + # Go to the next match point if there is no suitable + # candidate. + + if { $j == [lindex [lindex $K $mid] 1] || $s > $k} { + continue + } + + # s is the sequence length of the longest sequence + # to which this match point may be appended. Make + # a new candidate match and store the old one in K + # Set r to the length of the new candidate match. + + set newc [::list $i $j [lindex $K $s]] + if { $r >= 0 } { + lset K $r $c + } + set c $newc + set r [expr { $s + 1 }] + + # If we've extended the length of the longest match, + # we're done; move the fence. + + if { $s >= $k } { + lappend K [lindex $K end] + incr k + break + } + } + + # Put the last candidate into the array + + lset K $r $c + } + + incr i + } + + # Package the common subsequence in a convenient form + + set seta {} + set setb {} + set q [lindex $K $k] + + for { set i 0 } { $i < $k } {incr i } { + lappend seta {} + lappend setb {} + } + while { [lindex $q 0] >= 0 } { + incr k -1 + lset seta $k [lindex $q 0] + lset setb $k [lindex $q 1] + set q [lindex $q 2] + } + + return [::list $seta $setb] +} + +# ::struct::list::LlongestCommonSubsequence2 -- +# +# Derives an approximation to the longest common subsequence +# of two lists. +# +# Parameters: +# sequence1, sequence2 - Lists to be compared +# maxOccurs - Parameter for imprecise matching - see below. +# +# Results: +# Returns a list of two lists of equal length. +# The first sublist is of indices into sequence1, and the +# second sublist is of indices into sequence2. Each corresponding +# pair of indices corresponds to equal elements in the sequences; +# the sequence returned is an approximation to the longest possible. +# +# Side effects: +# None. +# +# Notes: +# This procedure acts as a wrapper around the companion procedure +# struct::list::LongestCommonSubsequence and accepts the same +# parameters. It first computes the longest common subsequence of +# elements that occur no more than $maxOccurs times in the +# second list. Using that subsequence to align the two lists, +# it then tries to augment the subsequence by computing the true +# longest common subsequences of the sublists between matched pairs. + +proc ::struct::list::LlongestCommonSubsequence2 { + sequence1 + sequence2 + {maxOccurs 0x7fffffff} +} { + # Derive the longest common subsequence of elements that occur at + # most $maxOccurs times + + foreach { l1 l2 } \ + [LlongestCommonSubsequence $sequence1 $sequence2 $maxOccurs] { + break + } + + # Walk through the match points in the sequence just derived. + + set result1 {} + set result2 {} + set n1 0 + set n2 0 + foreach i1 $l1 i2 $l2 { + if { $i1 != $n1 && $i2 != $n2 } { + # The match points indicate that there are unmatched + # elements lying between them in both input sequences. + # Extract the unmatched elements and perform precise + # longest-common-subsequence analysis on them. + + set subl1 [lrange $sequence1 $n1 [expr { $i1 - 1 }]] + set subl2 [lrange $sequence2 $n2 [expr { $i2 - 1 }]] + foreach { m1 m2 } [LlongestCommonSubsequence $subl1 $subl2] break + foreach j1 $m1 j2 $m2 { + lappend result1 [expr { $j1 + $n1 }] + lappend result2 [expr { $j2 + $n2 }] + } + } + + # Add the current match point to the result + + lappend result1 $i1 + lappend result2 $i2 + set n1 [expr { $i1 + 1 }] + set n2 [expr { $i2 + 1 }] + } + + # If there are unmatched elements after the last match in both files, + # perform precise longest-common-subsequence matching on them and + # add the result to our return. + + if { $n1 < [llength $sequence1] && $n2 < [llength $sequence2] } { + set subl1 [lrange $sequence1 $n1 end] + set subl2 [lrange $sequence2 $n2 end] + foreach { m1 m2 } [LlongestCommonSubsequence $subl1 $subl2] break + foreach j1 $m1 j2 $m2 { + lappend result1 [expr { $j1 + $n1 }] + lappend result2 [expr { $j2 + $n2 }] + } + } + + return [::list $result1 $result2] +} + +# ::struct::list::LlcsInvert -- +# +# Takes the data describing a longest common subsequence of two +# lists and inverts the information in the sense that the result +# of this command will describe the differences between the two +# sequences instead of the identical parts. +# +# Parameters: +# lcsData longest common subsequence of two lists as +# returned by longestCommonSubsequence(2). +# Results: +# Returns a single list whose elements describe the differences +# between the original two sequences. Each element describes +# one difference through three pieces, the type of the change, +# a pair of indices in the first sequence and a pair of indices +# into the second sequence, in this order. +# +# Side effects: +# None. + +proc ::struct::list::LlcsInvert {lcsData len1 len2} { + return [LlcsInvert2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] +} + +proc ::struct::list::LlcsInvert2 {idx1 idx2 len1 len2} { + set result {} + set last1 -1 + set last2 -1 + + foreach a $idx1 b $idx2 { + # Four possible cases. + # a) last1 ... a and last2 ... b are not empty. + # This is a 'change'. + # b) last1 ... a is empty, last2 ... b is not. + # This is an 'addition'. + # c) last1 ... a is not empty, last2 ... b is empty. + # This is a deletion. + # d) If both ranges are empty we can ignore the + # two current indices. + + set empty1 [expr {($a - $last1) <= 1}] + set empty2 [expr {($b - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr b -1 + lappend result [::list added [::list $last1 $a] [::list $last2 $b]] + incr b + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr a -1 + lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] + incr a + } else { + # Case (q), 'change'. + incr last1 ; incr a -1 + incr last2 ; incr b -1 + lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] + incr a + incr b + } + + set last1 $a + set last2 $b + } + + # Handle the last chunk, using the information about the length of + # the original sequences. + + set empty1 [expr {($len1 - $last1) <= 1}] + set empty2 [expr {($len2 - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr len2 -1 + lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr len1 -1 + lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] + } else { + # Case (q), 'change'. + incr last1 ; incr len1 -1 + incr last2 ; incr len2 -1 + lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] + } + + return $result +} + +proc ::struct::list::LlcsInvertMerge {lcsData len1 len2} { + return [LlcsInvertMerge2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2] +} + +proc ::struct::list::LlcsInvertMerge2 {idx1 idx2 len1 len2} { + set result {} + set last1 -1 + set last2 -1 + + foreach a $idx1 b $idx2 { + # Four possible cases. + # a) last1 ... a and last2 ... b are not empty. + # This is a 'change'. + # b) last1 ... a is empty, last2 ... b is not. + # This is an 'addition'. + # c) last1 ... a is not empty, last2 ... b is empty. + # This is a deletion. + # d) If both ranges are empty we can ignore the + # two current indices. For merging we simply + # take the information from the input. + + set empty1 [expr {($a - $last1) <= 1}] + set empty2 [expr {($b - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), add 'unchanged' chunk. + set type -- + foreach {type left right} [lindex $result end] break + if {[string match unchanged $type]} { + # There is an existing result to extend + lset left end $a + lset right end $b + lset result end [::list unchanged $left $right] + } else { + # There is an unchanged result at the start of the list; + # it may be extended. + lappend result [::list unchanged [::list $a $a] [::list $b $b]] + } + } else { + if {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr b -1 + lappend result [::list added [::list $last1 $a] [::list $last2 $b]] + incr b + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr a -1 + lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]] + incr a + } else { + # Case (a), 'change'. + incr last1 ; incr a -1 + incr last2 ; incr b -1 + lappend result [::list changed [::list $last1 $a] [::list $last2 $b]] + incr a + incr b + } + # Finally, the two matching lines are a new unchanged region + lappend result [::list unchanged [::list $a $a] [::list $b $b]] + } + set last1 $a + set last2 $b + } + + # Handle the last chunk, using the information about the length of + # the original sequences. + + set empty1 [expr {($len1 - $last1) <= 1}] + set empty2 [expr {($len2 - $last2) <= 1}] + + if {$empty1 && $empty2} { + # Case (d), ignore the indices + } elseif {$empty1} { + # Case (b), 'addition'. + incr last2 ; incr len2 -1 + lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]] + } elseif {$empty2} { + # Case (c), 'deletion' + incr last1 ; incr len1 -1 + lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]] + } else { + # Case (q), 'change'. + incr last1 ; incr len1 -1 + incr last2 ; incr len2 -1 + lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]] + } + + return $result +} + +# ::struct::list::Lreverse -- +# +# Reverses the contents of the list and returns the reversed +# list as the result of the command. +# +# Parameters: +# sequence List to be reversed. +# +# Results: +# The sequence in reverse. +# +# Side effects: +# None. + +proc ::struct::list::Lreverse {sequence} { + set l [::llength $sequence] + + # Shortcut for lists where reversing yields the list itself + if {$l < 2} {return $sequence} + + # Perform true reversal + set res [::list] + while {$l} { + ::lappend res [::lindex $sequence [incr l -1]] + } + return $res +} + + +# ::struct::list::Lassign -- +# +# Assign list elements to variables. +# +# Parameters: +# sequence List to assign +# args Names of the variables to assign to. +# +# Results: +# The unassigned part of the sequence. Can be empty. +# +# Side effects: +# None. + +# Do a compatibility version of [assign] for pre-8.5 versions of Tcl. + +if { [package vcompare [package provide Tcl] 8.5] < 0 } { + # 8.4 + proc ::struct::list::Lassign {sequence v args} { + set args [linsert $args 0 $v] + set a [::llength $args] + + # Nothing to assign. + #if {$a == 0} {return $sequence} + + # Perform assignments + set i 0 + foreach v $args { + upvar 1 $v var + set var [::lindex $sequence $i] + incr i + } + + # Return remainder, if there is any. + return [::lrange $sequence $a end] +} + +} else { + # For 8.5+ simply redirect the method to the core command. + + interp alias {} ::struct::list::Lassign {} lassign +} + + +# ::struct::list::Lshift -- +# +# Shift a list in a variable one element down, and return first element +# +# Parameters: +# listvar Name of variable containing the list to shift. +# +# Results: +# The first element of the list. +# +# Side effects: +# After the call the list variable will contain +# the second to last elements of the list. + +proc ::struct::list::Lshift {listvar} { + upvar 1 $listvar list + set list [Lassign [K $list [set list {}]] v] + return $v +} + + +# ::struct::list::Lflatten -- +# +# Remove nesting from the input +# +# Parameters: +# sequence List to flatten +# +# Results: +# The input list with one or all levels of nesting removed. +# +# Side effects: +# None. + +proc ::struct::list::Lflatten {args} { + if {[::llength $args] < 1} { + return -code error \ + "wrong#args: should be \"::struct::list::Lflatten ?-full? ?--? sequence\"" + } + + set full 0 + while {[string match -* [set opt [::lindex $args 0]]]} { + switch -glob -- $opt { + -full {set full 1} + -- { + set args [::lrange $args 1 end] + break ; # fix ticket 6e778502b8 -- break exits while loop + } + default { + return -code error "Unknown option \"$opt\", should be either -full, or --" + } + } + set args [::lrange $args 1 end] + } + + if {[::llength $args] != 1} { + return -code error \ + "wrong#args: should be \"::struct::list::Lflatten ?-full? ?--? sequence\"" + } + + set sequence [::lindex $args 0] + set cont 1 + while {$cont} { + set cont 0 + set result [::list] + foreach item $sequence { + # catch/llength detects if the item is following the list + # syntax. + + if {[catch {llength $item} len]} { + # Element is not a list in itself, no flatten, add it + # as is. + lappend result $item + } else { + # Element is parseable as list, add all sub-elements + # to the result. + foreach e $item { + lappend result $e + } + } + } + if {$full && [string compare $sequence $result]} {set cont 1} + set sequence $result + } + return $result +} + + +# ::struct::list::Lmap -- +# +# Apply command to each element of a list and return concatenated results. +# +# Parameters: +# sequence List to operate on +# cmdprefix Operation to perform on the elements. +# +# Results: +# List containing the result of applying cmdprefix to the elements of the +# sequence. +# +# Side effects: +# None of its own, but the command prefix can perform arbitry actions. + +proc ::struct::list::Lmap {sequence cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + + set res [::list] + foreach item $sequence { + lappend res [uplevel 1 [linsert $cmdprefix end $item]] + } + return $res +} + +# ::struct::list::Lmapfor -- +# +# Apply a script to each element of a list and return concatenated results. +# +# Parameters: +# sequence List to operate on +# script The script to run on the elements. +# +# Results: +# List containing the result of running script on the elements of the +# sequence. +# +# Side effects: +# None of its own, but the script can perform arbitry actions. + +proc ::struct::list::Lmapfor {var sequence script} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + upvar 1 $var item + + set res [::list] + foreach item $sequence { + lappend res [uplevel 1 $script] + } + return $res +} + +# ::struct::list::Lfilter -- +# +# Apply command to each element of a list and return elements passing the test. +# +# Parameters: +# sequence List to operate on +# cmdprefix Test to perform on the elements. +# +# Results: +# List containing the elements of the input passing the test command. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lfilter {sequence cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + return [uplevel 1 [::list ::struct::list::Lfold $sequence {} [::list ::struct::list::FTest $cmdprefix]]] +} + +proc ::struct::list::FTest {cmdprefix result item} { + set pass [uplevel 1 [::linsert $cmdprefix end $item]] + if {$pass} {::lappend result $item} + return $result +} + +# ::struct::list::Lfilterfor -- +# +# Apply expr condition to each element of a list and return elements passing the test. +# +# Parameters: +# sequence List to operate on +# expr Test to perform on the elements. +# +# Results: +# List containing the elements of the input passing the test expression. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lfilterfor {var sequence expr} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $sequence} + + upvar 1 $var item + set result {} + foreach item $sequence { + if {[uplevel 1 [::list ::expr $expr]]} { + lappend result $item + } + } + return $result +} + +# ::struct::list::Lsplit -- +# +# Apply command to each element of a list and return elements passing +# and failing the test. Basic idea by Salvatore Sanfilippo +# (http://wiki.tcl.tk/lsplit). The implementation here is mine (AK), +# and the interface is slightly different (Command prefix with the +# list element given to it as argument vs. variable + script). +# +# Parameters: +# sequence List to operate on +# cmdprefix Test to perform on the elements. +# args = empty | (varPass varFail) +# +# Results: +# If the variables are specified then a list containing the +# numbers of passing and failing elements, in this +# order. Otherwise a list having two elements, the lists of +# passing and failing elements, in this order. +# +# Side effects: +# None of its own, but the command prefix can perform arbitrary actions. + +proc ::struct::list::Lsplit {sequence cmdprefix args} { + set largs [::llength $args] + if {$largs == 0} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return {{} {}}} + return [uplevel 1 [::list [namespace which Lfold] $sequence {} [ + ::list ::struct::list::PFTest $cmdprefix]]] + } elseif {$largs == 2} { + # Shortcut when nothing is to be done. + foreach {pv fv} $args break + upvar 1 $pv pass $fv fail + if {[::llength $sequence] == 0} { + set pass {} + set fail {} + return {0 0} + } + foreach {pass fail} [uplevel 1 [ + ::list ::struct::list::Lfold $sequence {} [ + ::list ::struct::list::PFTest $cmdprefix]]] break + return [::list [llength $pass] [llength $fail]] + } else { + return -code error \ + "wrong#args: should be \"::struct::list::Lsplit sequence cmdprefix ?passVar failVar?" + } +} + +proc ::struct::list::PFTest {cmdprefix result item} { + set passing [uplevel 1 [::linsert $cmdprefix end $item]] + set pass {} ; set fail {} + foreach {pass fail} $result break + if {$passing} { + ::lappend pass $item + } else { + ::lappend fail $item + } + return [::list $pass $fail] +} + +# ::struct::list::Lfold -- +# +# Fold list into one value. +# +# Parameters: +# sequence List to operate on +# cmdprefix Operation to perform on the elements. +# +# Results: +# Result of applying cmdprefix to the elements of the +# sequence. +# +# Side effects: +# None of its own, but the command prefix can perform arbitry actions. + +proc ::struct::list::Lfold {sequence initialvalue cmdprefix} { + # Shortcut when nothing is to be done. + if {[::llength $sequence] == 0} {return $initialvalue} + + set res $initialvalue + foreach item $sequence { + set res [uplevel 1 [linsert $cmdprefix end $res $item]] + } + return $res +} + +# ::struct::list::Liota -- +# +# Return a list containing the integer numbers 0 ... n-1 +# +# Parameters: +# n First number not in the generated list. +# +# Results: +# A list containing integer numbers. +# +# Side effects: +# None + +proc ::struct::list::Liota {n} { + set retval [::list] + for {set i 0} {$i < $n} {incr i} { + ::lappend retval $i + } + return $retval +} + +# ::struct::list::Ldelete -- +# +# Delete an element from a list by name. +# Similar to 'struct::set exclude', however +# this here preserves order and list intrep. +# +# Parameters: +# a First list to compare. +# b Second list to compare. +# +# Results: +# A boolean. True if the lists are delete. +# +# Side effects: +# None + +proc ::struct::list::Ldelete {var item} { + upvar 1 $var list + set pos [lsearch -exact $list $item] + if {$pos < 0} return + set list [lreplace [K $list [set list {}]] $pos $pos] + return +} + +# ::struct::list::Lequal -- +# +# Compares two lists for equality +# (Same length, Same elements in same order). +# +# Parameters: +# a First list to compare. +# b Second list to compare. +# +# Results: +# A boolean. True if the lists are equal. +# +# Side effects: +# None + +proc ::struct::list::Lequal {a b} { + # Author of this command is "Richard Suchenwirth" + + if {[::llength $a] != [::llength $b]} {return 0} + if {[::lindex $a 0] == $a && [::lindex $b 0] == $b} {return [string equal $a $b]} + foreach i $a j $b {if {![Lequal $i $j]} {return 0}} + return 1 +} + +# ::struct::list::Lrepeatn -- +# +# Create a list repeating the same value over again. +# +# Parameters: +# value value to use in the created list. +# args Dimension(s) of the (nested) list to create. +# +# Results: +# A list +# +# Side effects: +# None + +proc ::struct::list::Lrepeatn {value args} { + if {[::llength $args] == 1} {set args [::lindex $args 0]} + set buf {} + foreach number $args { + incr number 0 ;# force integer (1) + set buf {} + for {set i 0} {$i<$number} {incr i} { + ::lappend buf $value + } + set value $buf + } + return $buf + # (1): See 'Stress testing' (wiki) for why this makes the code safer. +} + +# ::struct::list::Lrepeat -- +# +# Create a list repeating the same value over again. +# [Identical to the Tcl 8.5 lrepeat command] +# +# Parameters: +# n Number of replications. +# args values to use in the created list. +# +# Results: +# A list +# +# Side effects: +# None + +# Do a compatibility version of [repeat] for pre-8.5 versions of Tcl. + +if { [package vcompare [package provide Tcl] 8.5] < 0 } { + + proc ::struct::list::Lrepeat {positiveCount value args} { + if {![string is integer -strict $positiveCount]} { + return -code error "expected integer but got \"$positiveCount\"" + } elseif {$positiveCount < 1} { + return -code error {must have a count of at least 1} + } + + set args [linsert $args 0 $value] + + if {$positiveCount == 1} { + # Tcl itself has already listified the incoming parameters + # via 'args'. + return $args + } + + set result [::list] + while {$positiveCount > 0} { + if {($positiveCount % 2) == 0} { + set args [concat $args $args] + set positiveCount [expr {$positiveCount/2}] + } else { + set result [concat $result $args] + incr positiveCount -1 + } + } + return $result + } + +} else { + # For 8.5 simply redirect the method to the core command. + + interp alias {} ::struct::list::Lrepeat {} lrepeat +} + +# ::struct::list::LdbJoin(Keyed) -- +# +# Relational table joins. +# +# Parameters: +# args key specs and tables to join +# +# Results: +# A table/matrix as nested list. See +# struct/matrix set/get rect for structure. +# +# Side effects: +# None + +proc ::struct::list::LdbJoin {args} { + # -------------------------------- + # Process options ... + + set mode inner + set keyvar {} + + while {[llength $args]} { + set err [::cmdline::getopt args {inner left right full keys.arg} opt arg] + if {$err == 1} { + if {[string equal $opt keys]} { + set keyvar $arg + } else { + set mode $opt + } + } elseif {$err < 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? ?-keys varname? \{key table\}..." + } else { + # Non-option argument found, stop processing. + break + } + } + + set inner [string equal $mode inner] + set innerorleft [expr {$inner || [string equal $mode left]}] + + # -------------------------------- + # Process tables ... + + if {([llength $args] % 2) != 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? \{key table\}..." + } + + # One table only, join is identity + if {[llength $args] == 2} {return [lindex $args 1]} + + # Use first table for setup. + + foreach {key table} $args break + + # Check for possible early abort + if {$innerorleft && ([llength $table] == 0)} {return {}} + + set width 0 + array set state {} + + set keylist [InitMap state width $key $table] + + # Extend state with the remaining tables. + + foreach {key table} [lrange $args 2 end] { + # Check for possible early abort + if {$inner && ([llength $table] == 0)} {return {}} + + switch -exact -- $mode { + inner {set keylist [MapExtendInner state $key $table]} + left {set keylist [MapExtendLeftOuter state width $key $table]} + right {set keylist [MapExtendRightOuter state width $key $table]} + full {set keylist [MapExtendFullOuter state width $key $table]} + } + + # Check for possible early abort + if {$inner && ([llength $keylist] == 0)} {return {}} + } + + if {[string length $keyvar]} { + upvar 1 $keyvar keys + set keys $keylist + } + + return [MapToTable state $keylist] +} + +proc ::struct::list::LdbJoinKeyed {args} { + # -------------------------------- + # Process options ... + + set mode inner + set keyvar {} + + while {[llength $args]} { + set err [::cmdline::getopt args {inner left right full keys.arg} opt arg] + if {$err == 1} { + if {[string equal $opt keys]} { + set keyvar $arg + } else { + set mode $opt + } + } elseif {$err < 0} { + return -code error "wrong#args: dbJoin ?-inner|-left|-right|-full? table..." + } else { + # Non-option argument found, stop processing. + break + } + } + + set inner [string equal $mode inner] + set innerorleft [expr {$inner || [string equal $mode left]}] + + # -------------------------------- + # Process tables ... + + # One table only, join is identity + if {[llength $args] == 1} { + return [Dekey [lindex $args 0]] + } + + # Use first table for setup. + + set table [lindex $args 0] + + # Check for possible early abort + if {$innerorleft && ([llength $table] == 0)} {return {}} + + set width 0 + array set state {} + + set keylist [InitKeyedMap state width $table] + + # Extend state with the remaining tables. + + foreach table [lrange $args 1 end] { + # Check for possible early abort + if {$inner && ([llength $table] == 0)} {return {}} + + switch -exact -- $mode { + inner {set keylist [MapKeyedExtendInner state $table]} + left {set keylist [MapKeyedExtendLeftOuter state width $table]} + right {set keylist [MapKeyedExtendRightOuter state width $table]} + full {set keylist [MapKeyedExtendFullOuter state width $table]} + } + + # Check for possible early abort + if {$inner && ([llength $keylist] == 0)} {return {}} + } + + if {[string length $keyvar]} { + upvar 1 $keyvar keys + set keys $keylist + } + + return [MapToTable state $keylist] +} + +## Helpers for the relational joins. +## Map is an array mapping from keys to a list +## of rows with that key + +proc ::struct::list::Cartesian {leftmap rightmap key} { + upvar $leftmap left $rightmap right + set joined [::list] + foreach lrow $left($key) { + foreach row $right($key) { + lappend joined [concat $lrow $row] + } + } + set left($key) $joined + return +} + +proc ::struct::list::SingleRightCartesian {mapvar key rightrow} { + upvar $mapvar map + set joined [::list] + foreach lrow $map($key) { + lappend joined [concat $lrow $rightrow] + } + set map($key) $joined + return +} + +proc ::struct::list::MapToTable {mapvar keys} { + # Note: keys must not appear multiple times in the list. + + upvar $mapvar map + set table [::list] + foreach k $keys { + foreach row $map($k) {lappend table $row} + } + return $table +} + +## More helpers, core join operations: Init, Extend. + +proc ::struct::list::InitMap {mapvar wvar key table} { + upvar $mapvar map $wvar width + set width [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + lappend map($keyval) $row + } else { + set map($keyval) [::list $row] + } + } + return [array names map] +} + +proc ::struct::list::MapExtendInner {mapvar key table} { + upvar $mapvar map + array set used {} + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + unset map($k) + } + } + return [array names map] +} + +proc ::struct::list::MapExtendRightOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. If there is nothing in the left table we + # create an appropriate empty row for the cartesian => definition + # of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + unset map($k) + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::MapExtendLeftOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + ## Keys: All in inner join + additional left keys + ## == All left keys = array names map after + ## all is said and done with it. + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + set used($keyval) [::list $row] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + incr width $w + return [array names map] +} + +proc ::struct::list::MapExtendFullOuter {mapvar wvar key table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + set keyval [lindex $row $key] + if {[info exists used($keyval)]} { + lappend used($keyval) $row + } else { + lappend keylist $keyval + set used($keyval) [::list $row] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + # If there is nothing in the left table we create an appropriate + # empty row for the cartesian => definition of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +## Keyed helpers + +proc ::struct::list::InitKeyedMap {mapvar wvar table} { + upvar $mapvar map $wvar width + set width [llength [lindex [lindex $table 0] 1]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + lappend map($keyval) $rowdata + } else { + set map($keyval) [::list $rowdata] + } + } + return [array names map] +} + +proc ::struct::list::MapKeyedExtendInner {mapvar table} { + upvar $mapvar map + array set used {} + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + unset map($k) + } + } + + return [array names map] +} + +proc ::struct::list::MapKeyedExtendRightOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map, and eliminate all entries which have no keys in + # the second table. If there is nothing in the left table we + # create an appropriate empty row for the cartesian => definition + # of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + unset map($k) + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::MapKeyedExtendLeftOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + ## Keys: All in inner join + additional left keys + ## == All left keys = array names map after + ## all is said and done with it. + + # Phase I - Find all keys in the second table matching keys in the + # first. Remember all their rows. + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists map($keyval)]} { + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + set used($keyval) [::list $rowdata] + } + } ; # else: Nothing to do for missing keys. + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + + foreach k [array names map] { + if {[info exists used($k)]} { + Cartesian map used $k + } else { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + incr width $w + return [array names map] +} + +proc ::struct::list::MapKeyedExtendFullOuter {mapvar wvar table} { + upvar $mapvar map $wvar width + array set used {} + + # Phase I - We keep all keys of the right table, even if they are + # missing in the left one <=> Definition of right outer join. + + set w [llength [lindex $table 0]] + foreach row $table { + foreach {keyval rowdata} $row break + if {[info exists used($keyval)]} { + lappend used($keyval) $rowdata + } else { + lappend keylist $keyval + set used($keyval) [::list $rowdata] + } + } + + # Phase II - Merge the collected rows of the second (right) table + # into the map. We keep entries which have no keys in the second + # table, we actually extend them <=> Left outer join. + # If there is nothing in the left table we create an appropriate + # empty row for the cartesian => definition of right outer join. + + # We go through used, because map can be empty for outer + + foreach k [array names map] { + if {![info exists used($k)]} { + SingleRightCartesian map $k [Lrepeatn {} $w] + } + } + foreach k [array names used] { + if {![info exists map($k)]} { + set map($k) [::list [Lrepeatn {} $width]] + } + Cartesian map used $k + } + + incr width $w + return [array names map] +} + +proc ::struct::list::Dekey {keyedtable} { + set table [::list] + foreach row $keyedtable {lappend table [lindex $row 1]} + return $table +} + +# ::struct::list::Lswap -- +# +# Exchange two elements of a list. +# +# Parameters: +# listvar Name of the variable containing the list to manipulate. +# i, j Indices of the list elements to exchange. +# +# Results: +# The modified list +# +# Side effects: +# None + +proc ::struct::list::Lswap {listvar i j} { + upvar $listvar list + + if {($i < 0) || ($j < 0)} { + return -code error {list index out of range} + } + set len [llength $list] + if {($i >= $len) || ($j >= $len)} { + return -code error {list index out of range} + } + + if {$i != $j} { + set tmp [lindex $list $i] + lset list $i [lindex $list $j] + lset list $j $tmp + } + return $list +} + +# ::struct::list::Lfirstperm -- +# +# Returns the lexicographically first permutation of the +# specified list. +# +# Parameters: +# list The list whose first permutation is sought. +# +# Results: +# A modified list containing the lexicographically first +# permutation of the input. +# +# Side effects: +# None + +proc ::struct::list::Lfirstperm {list} { + return [lsort $list] +} + +# ::struct::list::Lnextperm -- +# +# Accepts a permutation of a set of elements and returns the +# next permutatation in lexicographic sequence. +# +# Parameters: +# list The list containing the current permutation. +# +# Results: +# A modified list containing the lexicographically next +# permutation after the input permutation. +# +# Side effects: +# None + +proc ::struct::list::Lnextperm {perm} { + # Find the smallest subscript j such that we have already visited + # all permutations beginning with the first j elements. + + set len [expr {[llength $perm] - 1}] + + set j $len + set ajp1 [lindex $perm $j] + while { $j > 0 } { + incr j -1 + set aj [lindex $perm $j] + if { [string compare $ajp1 $aj] > 0 } { + set foundj {} + break + } + set ajp1 $aj + } + if { ![info exists foundj] } return + + # Find the smallest element greater than the j'th among the elements + # following aj. Let its index be l, and interchange aj and al. + + set l $len + while { [string compare $aj [set al [lindex $perm $l]]] >= 0 } { + incr l -1 + } + lset perm $j $al + lset perm $l $aj + + # Reverse a_j+1 ... an + + set k [expr {$j + 1}] + set l $len + while { $k < $l } { + set al [lindex $perm $l] + lset perm $l [lindex $perm $k] + lset perm $k $al + incr k + incr l -1 + } + + return $perm +} + +# ::struct::list::Lpermutations -- +# +# Returns a list containing all the permutations of the +# specified list, in lexicographic order. +# +# Parameters: +# list The list whose permutations are sought. +# +# Results: +# A list of lists, containing all permutations of the +# input. +# +# Side effects: +# None + +proc ::struct::list::Lpermutations {list} { + + if {[llength $list] < 2} { + return [::list $list] + } + + set res {} + set p [Lfirstperm $list] + while {[llength $p]} { + lappend res $p + set p [Lnextperm $p] + } + return $res +} + +# ::struct::list::Lforeachperm -- +# +# Executes a script for all the permutations of the +# specified list, in lexicographic order. +# +# Parameters: +# var Name of the loop variable. +# list The list whose permutations are sought. +# body The tcl script to run per permutation of +# the input. +# +# Results: +# The empty string. +# +# Side effects: +# None + +proc ::struct::list::Lforeachperm {var list body} { + upvar $var loopvar + + if {[llength $list] < 2} { + set loopvar $list + # TODO run body. + + # The first invocation of the body, also the last, as only one + # permutation is possible. That makes handling of the result + # codes easier. + + set code [catch {uplevel 1 $body} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel foreachperm] \ + -errorcode $::errorCode -code error $result + } + 3 {} + 4 {} + default { + # Includes code 2 + return -code $code $result + } + } + return + } + + set p [Lfirstperm $list] + while {[llength $p]} { + set loopvar $p + + set code [catch {uplevel 1 $body} result] + + # decide what to do upon the return code: + # + # 0 - the body executed successfully + # 1 - the body raised an error + # 2 - the body invoked [return] + # 3 - the body invoked [break] + # 4 - the body invoked [continue] + # everything else - return and pass on the results + # + switch -exact -- $code { + 0 {} + 1 { + return -errorinfo [ErrorInfoAsCaller uplevel foreachperm] \ + -errorcode $::errorCode -code error $result + } + 3 { + # FRINK: nocheck + return + } + 4 {} + default { + return -code $code $result + } + } + set p [Lnextperm $p] + } + return +} + +proc ::struct::list::Lshuffle {list} { + for {set i [llength $list]} {$i > 1} {lset list $j $t} { + set j [expr {int(rand() * $i)}] + set t [lindex $list [incr i -1]] + lset list $i [lindex $list $j] + } + return $list +} + +# ### ### ### ######### ######### ######### + +proc ::struct::list::ErrorInfoAsCaller {find replace} { + set info $::errorInfo + set i [string last "\n (\"$find" $info] + if {$i == -1} {return $info} + set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" + append result $replace ;# $find -> $replace + incr i [string length $find] + set j [string first ) $info [incr i]] ;# keep rest of parenthetical + append result [string range $info $i $j] + return $result +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'list::list' into the general structure namespace. + namespace import -force list::list + namespace export list +} +package provide struct::list 1.8.5 diff --git a/src/vendormodules/struct/matrix-2.1.tm b/src/vendormodules/struct/matrix-2.1.tm new file mode 100644 index 00000000..ee098eae --- /dev/null +++ b/src/vendormodules/struct/matrix-2.1.tm @@ -0,0 +1,2806 @@ +# matrix.tcl -- +# +# Implementation of a matrix data structure for Tcl. +# +# Copyright (c) 2001-2013,2019,2022 by Andreas Kupries +# +# Heapsort code Copyright (c) 2003 by Edwin A. Suominen , +# based on concepts in "Introduction to Algorithms" by Thomas H. Cormen et al. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require Tcl 8.5 +package require textutil::wcswidth ;# TermWidth, for _columnwidth and related places + +namespace eval ::struct {} + +namespace eval ::struct::matrix { + # Data storage in the matrix module + # ------------------------------- + # + # One namespace per object, containing + # + # - Two scalar variables containing the current number of rows and columns. + # - Four array variables containing the array data, the caches for + # row heights and column widths and the information about linked arrays. + # + # The variables are + # - columns #columns in data + # - rows #rows in data + # - data cell contents + # - colw cache of column widths + # - rowh cache of row heights + # - link information about linked arrays + # - lock boolean flag to disable MatTraceIn while in MatTraceOut [#532783] + # - unset string used to convey information about 'unset' traces from MatTraceIn to MatTraceOut. + + # counter is used to give a unique name for unnamed matrices + variable counter 0 + + # Only export one command, the one used to instantiate a new matrix + namespace export matrix +} + +# ::struct::matrix::matrix -- +# +# Create a new matrix with a given name; if no name is given, use +# matrixX, where X is a number. +# +# Arguments: +# name Optional name of the matrix; if null or not given, generate one. +# +# Results: +# name Name of the matrix created + +proc ::struct::matrix::matrix {args} { + variable counter + + set src {} + set srctype {} + + switch -exact -- [llength [info level 0]] { + 1 { + # Missing name, generate one. + incr counter + set name "matrix${counter}" + } + 2 { + # Standard call. New empty matrix. + set name [lindex $args 0] + } + 4 { + # Copy construction. + foreach {name as src} $args break + switch -exact -- $as { + = - := - as { + set srctype matrix + } + deserialize { + set srctype serial + } + default { + return -code error \ + "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\"" + } + } + } + default { + # Error. + return -code error \ + "wrong # args: should be \"matrix ?name ?=|:=|as|deserialize source??\"" + } + } + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 [list namespace current]] + if {"::" != $ns} { + append ns "::" + } + set name "$ns$name" + } + + if { [llength [info commands $name]] } { + return -code error "command \"$name\" already exists, unable to create matrix" + } + + # Set up the namespace + namespace eval $name { + variable columns 0 + variable rows 0 + + variable data + variable colw + variable rowh + variable link + variable lock + variable unset + + array set data {} + array set colw {} + array set rowh {} + array set link {} + set lock 0 + set unset {} + } + + # Create the command to manipulate the matrix + interp alias {} $name {} ::struct::matrix::MatrixProc $name + + # Automatic execution of assignment if a source + # is present. + if {$src != {}} { + switch -exact -- $srctype { + matrix {_= $name $src} + serial {_deserialize $name $src} + default { + return -code error \ + "Internal error, illegal srctype \"$srctype\"" + } + } + } + return $name +} + +########################## +# Private functions follow + +# ::struct::matrix::MatrixProc -- +# +# Command that processes all matrix object commands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand to invoke. +# args Arguments for subcommand. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::MatrixProc {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub _$cmd + if {[llength [info commands ::struct::matrix::$sub]] == 0} { + set optlist [lsort [info commands ::struct::matrix::_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + if {[string match __* $p]} {continue} + lappend xlist [string range $p 1 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_= -- +# +# Assignment operator. Copies the source matrix into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object we are copying into. +# source Name of the matrix object providing us with the +# data to copy. +# +# Results: +# Nothing. + +proc ::struct::matrix::_= {name source} { + _deserialize $name [$source serialize] + return +} + +# ::struct::matrix::_--> -- +# +# Reverse assignment operator. Copies this matrix into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object to copy +# dest Name of the matrix object we are copying to. +# +# Results: +# Nothing. + +proc ::struct::matrix::_--> {name dest} { + $dest deserialize [_serialize $name] + return +} + +# ::struct::matrix::_add -- +# +# Command that processes all 'add' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'add' to invoke. +# args Arguments for subcommand of 'add'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_add {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name add option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __add_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__add_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_delete -- +# +# Command that processes all 'delete' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'delete' to invoke. +# args Arguments for subcommand of 'delete'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_delete {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name delete option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __delete_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__delete_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_format -- +# +# Command that processes all 'format' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'format' to invoke. +# args Arguments for subcommand of 'format'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_format {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name format option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __format_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__format_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_get -- +# +# Command that processes all 'get' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'get' to invoke. +# args Arguments for subcommand of 'get'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_get {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name get option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __get_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__get_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_insert -- +# +# Command that processes all 'insert' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'insert' to invoke. +# args Arguments for subcommand of 'insert'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_insert {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name insert option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __insert_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__insert_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 9 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_search -- +# +# Command that processes all 'search' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# args Arguments for search. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_search {name args} { + set mode exact + set nocase 0 + + while {1} { + switch -glob -- [lindex $args 0] { + -exact - -glob - -regexp { + set mode [string range [lindex $args 0] 1 end] + set args [lrange $args 1 end] + } + -nocase { + set nocase 1 + set args [lrange $args 1 end] + } + -* { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -nocase, -exact, -glob, or -regexp" + } + default { + break + } + } + } + + # Possible argument signatures after option processing + # + # \ | args + # --+-------------------------------------------------------- + # 2 | all pattern + # 3 | row row pattern, column col pattern + # 6 | rect ctl rtl cbr rbr pattern + # + # All range specifications are internally converted into a + # rectangle. + + switch -exact -- [llength $args] { + 2 - 3 - 6 {} + default { + return -code error \ + "wrong # args: should be\ + \"$name search ?option...? (all|row row|column col|rect c r c r) pattern\"" + } + } + + set range [lindex $args 0] + set pattern [lindex $args end] + set args [lrange $args 1 end-1] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + switch -exact -- $range { + all { + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + column { + set ctl [ChkColumnIndex $name [lindex $args 0]] + set cbr $ctl + set rtl 0 ; set rbr $rows ; incr rbr -1 + } + row { + set rtl [ChkRowIndex $name [lindex $args 0]] + set ctl 0 ; set cbr $columns ; incr cbr -1 + set rbr $rtl + } + rect { + foreach {ctl rtl cbr rbr} $args break + set ctl [ChkColumnIndex $name $ctl] + set rtl [ChkRowIndex $name $rtl] + set cbr [ChkColumnIndex $name $cbr] + set rbr [ChkRowIndex $name $rbr] + if {($ctl > $cbr) || ($rtl > $rbr)} { + return -code error "Invalid cell indices, wrong ordering" + } + } + default { + return -code error "invalid range spec \"$range\": should be all, column, row, or rect" + } + } + + if {$nocase} { + set pattern [string tolower $pattern] + } + + set matches [list] + for {set r $rtl} {$r <= $rbr} {incr r} { + for {set c $ctl} {$c <= $cbr} {incr c} { + set v $data($c,$r) + if {$nocase} { + set v [string tolower $v] + } + switch -exact -- $mode { + exact {set matched [string equal $pattern $v]} + glob {set matched [string match $pattern $v]} + regexp {set matched [regexp -- $pattern $v]} + } + if {$matched} { + lappend matches [list $c $r] + } + } + } + return $matches +} + +# ::struct::matrix::_set -- +# +# Command that processes all 'set' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'set' to invoke. +# args Arguments for subcommand of 'set'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_set {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name set option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __set_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__set_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 6 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::_sort -- +# +# Command that processes all 'sort' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'sort' to invoke. +# args Arguments for subcommand of 'sort'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_sort {name cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + if {[string equal $cmd "rows"]} { + set code r + set byrows 1 + } elseif {[string equal $cmd "columns"]} { + set code c + set byrows 0 + } else { + return -code error \ + "bad option \"$cmd\": must be columns, or rows" + } + + set revers 0 ;# Default: -increasing + while {1} { + switch -glob -- [lindex $args 0] { + -increasing {set revers 0} + -decreasing {set revers 1} + default { + if {[llength $args] > 1} { + return -code error \ + "invalid option \"[lindex $args 0]\":\ + should be -increasing, or -decreasing" + } + break + } + } + set args [lrange $args 1 end] + } + # ASSERT: [llength $args] == 1 + + if {[llength $args] != 1} { + return -code error "wrong # args: should be \"$name sort option ?arg arg ...?\"" + } + + set key [lindex $args 0] + + if {$byrows} { + set key [ChkColumnIndex $name $key] + variable ${name}::rows + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $rows + } else { + set key [ChkRowIndex $name $key] + variable ${name}::columns + + # Adapted by EAS from BUILD-MAX-HEAP(A) of CRLS 6.3 + set heapSize $columns + } + + for {set i [expr {int($heapSize/2)-1}]} {$i>=0} {incr i -1} { + SortMaxHeapify $name $i $key $code $heapSize $revers + } + + # Adapted by EAS from remainder of HEAPSORT(A) of CRLS 6.4 + for {set i [expr {$heapSize-1}]} {$i>=1} {incr i -1} { + if {$byrows} { + SwapRows $name 0 $i + } else { + SwapColumns $name 0 $i + } + incr heapSize -1 + SortMaxHeapify $name 0 $key $code $heapSize $revers + } + return +} + +# ::struct::matrix::_swap -- +# +# Command that processes all 'swap' subcommands. +# +# Arguments: +# name Name of the matrix object to manipulate. +# cmd Subcommand of 'swap' to invoke. +# args Arguments for subcommand of 'swap'. +# +# Results: +# Varies based on command to perform + +proc ::struct::matrix::_swap {name {cmd ""} args} { + # Do minimal args checks here + if { [llength [info level 0]] == 2 } { + return -code error "wrong # args: should be \"$name swap option ?arg arg ...?\"" + } + + # Split the args into command and args components + set sub __swap_$cmd + if { [llength [info commands ::struct::matrix::$sub]] == 0 } { + set optlist [lsort [info commands ::struct::matrix::__swap_*]] + set xlist {} + foreach p $optlist { + set p [namespace tail $p] + lappend xlist [string range $p 7 end] + } + set optlist [linsert [join $xlist ", "] "end-1" "or"] + return -code error \ + "bad option \"$cmd\": must be $optlist" + } + uplevel 1 [linsert $args 0 ::struct::matrix::$sub $name] +} + +# ::struct::matrix::__add_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is appended immediately +# behind the last existing column. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_column {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new column is not added to the width cache, the other + # columns are not touched, the cache therefore unchanged. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($columns,$r) $v + incr r + } + incr columns + return +} + +# ::struct::matrix::__add_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is appended immediately behind the +# last existing row. +# +# Arguments: +# name Name of the matrix object. +# values Optional values to set into the new row. +# +# Results: +# None. + +proc ::struct::matrix::__add_row {name {values {}}} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - The new row is not added to the height cache, the other + # rows are not touched, the cache therefore unchanged. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$rows) $v + incr c + } + incr rows + return +} + +# ::struct::matrix::__add_columns -- +# +# Extends the matrix by "n" columns. The new cells will be set +# to the empty string. The new columns are appended immediately +# behind the last existing column. A value of "n" equal to or +# smaller than 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new columns to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_columns {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + AddColumns $name $n + return +} + +proc ::struct::matrix::AddColumns {name n} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set r 0} {$r < $rows} {incr r} { + set data($columns,$r) "" + } + incr columns + incr n -1 + } + + return +} + +# ::struct::matrix::__add_rows -- +# +# Extends the matrix by "n" rows. The new cells will be set to +# the empty string. The new rows are appended immediately behind +# the last existing row. A value of "n" equal to or smaller than +# 0 is not allowed. +# +# Arguments: +# name Name of the matrix object. +# n The number of new rows to create. +# +# Results: +# None. + +proc ::struct::matrix::__add_rows {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + AddRows $name $n + return +} + +proc ::struct::matrix::AddRows {name n} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + + # The new values set into the cell is always the empty + # string. These have a length and height of 0, i.e. the don't + # influence cached widths and heights as they are at least that + # big. IOW there is no need to touch and change the width and + # height caches. + + while {$n > 0} { + for {set c 0} {$c < $columns} {incr c} { + set data($c,$rows) "" + } + incr rows + incr n -1 + } + return +} + +# ::struct::matrix::_cells -- +# +# Returns the number of cells currently managed by the +# matrix. This is the product of "rows" and "columns". +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cells {name} { + variable ${name}::rows + variable ${name}::columns + return [expr {$rows * $columns}] +} + +# ::struct::matrix::_cellsize -- +# +# Returns the length of the string representation of the value +# currently contained in the addressed cell. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to query +# row Row index of the cell to query +# +# Results: +# The number of cells in the matrix. + +proc ::struct::matrix::_cellsize {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return [string length $data($column,$row)] +} + +# ::struct::matrix::_columns -- +# +# Returns the number of columns currently managed by the +# matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of columns in the matrix. + +proc ::struct::matrix::_columns {name} { + variable ${name}::columns + return $columns +} + +# ::struct::matrix::_columnwidth -- +# +# Returns the length of the longest string representation of all +# the values currently contained in the cells of the addressed +# column if these are all spanning only one line. For cell +# values spanning multiple lines the length of their longest +# line goes into the computation. +# +# Arguments: +# name Name of the matrix object. +# column The index of the column whose width is asked for. +# +# Results: +# See description. + +proc ::struct::matrix::_columnwidth {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::colw + + if {![info exists colw($column)]} { + variable ${name}::rows + variable ${name}::data + + set width 0 + for {set r 0} {$r < $rows} {incr r} { + foreach line [split $data($column,$r) \n] { + set len [TermWidth $line] + if {$len > $width} { + set width $len + } + } + } + + set colw($column) $width + } + + return $colw($column) +} + +# ::struct::matrix::__delete_column -- +# +# Deletes the specified column from the matrix and shifts all +# columns with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# column The index of the column to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_column {name column} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher columns down and then delete the + # superfluous data in the old last column. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set c $column; set cn [expr {$c + 1}]} {$cn < $columns} {incr c ; incr cn} { + set data($c,$r) $data($cn,$r) + if {[info exists colw($cn)]} { + set colw($c) $colw($cn) + unset colw($cn) + } + } + unset data($c,$r) + catch {unset rowh($r)} + } + incr columns -1 + return +} + +# ::struct::matrix::__delete_columns -- +# +# Shrink the matrix by "n" columns (from the right). +# A value of "n" equal to or smaller than 0 is not +# allowed, nor is "n" allowed to be greater than the +# number of columns in the matrix. +# +# Arguments: +# name Name of the matrix object. +# n The number of columns to remove. +# +# Results: +# None. + +proc ::struct::matrix::__delete_columns {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::columns + + if {$n > $columns} { + return -code error "A value of n > #columns is not allowed" + } + + DeleteColumns $name $n + return +} + +# ::struct::matrix::__delete_row -- +# +# Deletes the specified row from the matrix and shifts all +# row with higher indices one index down. +# +# Arguments: +# name Name of the matrix. +# row The index of the row to delete. +# +# Results: +# None. + +proc ::struct::matrix::__delete_row {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher rows down and then delete the + # superfluous data in the old last row. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set r $row; set rn [expr {$r + 1}]} {$rn < $rows} {incr r ; incr rn} { + set data($c,$r) $data($c,$rn) + if {[info exists rowh($rn)]} { + set rowh($r) $rowh($rn) + unset rowh($rn) + } + } + unset data($c,$r) + catch {unset colw($c)} + } + incr rows -1 + return +} + +# ::struct::matrix::__delete_rows -- +# +# Shrink the matrix by "n" rows (from the bottom). +# A value of "n" equal to or smaller than 0 is not +# allowed, nor is "n" allowed to be greater than the +# number of rows in the matrix. +# +# Arguments: +# name Name of the matrix object. +# n The number of rows to remove. +# +# Results: +# None. + +proc ::struct::matrix::__delete_rows {name n} { + if {$n <= 0} { + return -code error "A value of n <= 0 is not allowed" + } + + variable ${name}::rows + + if {$n > $rows} { + return -code error "A value of n > #rows is not allowed" + } + + DeleteRows $name $n + return +} + +# ::struct::matrix::_deserialize -- +# +# Assignment operator. Copies a serialization into the +# destination, destroying the original information. +# +# Arguments: +# name Name of the matrix object we are copying into. +# serial Serialized matrix to copy from. +# +# Results: +# Nothing. + +proc ::struct::matrix::_deserialize {name serial} { + # As we destroy the original matrix as part of + # the copying process we don't have to deal + # with issues like node names from the new matrix + # interfering with the old ... + + # I. Get the serialization of the source matrix + # and check it for validity. + + CheckSerialization $serial r c values + + # Get all the relevant data into the scope + + variable ${name}::rows + variable ${name}::columns + + # Resize the destination matrix for the new data + + if {$r > $rows} { + AddRows $name [expr {$r - $rows}] + } elseif {$r < $rows} { + DeleteRows $name [expr {$rows - $r}] + } + if {$c > $columns} { + AddColumns $name [expr {$c - $columns}] + } elseif {$c < $columns} { + DeleteColumns $name [expr {$columns - $c}] + } + + set rows $r + set columns $c + + # Copy the new data over the old information. + + set row 0 + foreach rv $values { + SetRow $name $row $rv + incr row + } + while {$row < $rows} { + # Fill with empty rows if there are not enough. + SetRow $name $row {} + incr row + } + return +} + +# ::struct::matrix::_destroy -- +# +# Destroy a matrix, including its associated command and data storage. +# +# Arguments: +# name Name of the matrix to destroy. +# +# Results: +# None. + +proc ::struct::matrix::_destroy {name} { + variable ${name}::link + + # Unlink all existing arrays before destroying the object so that + # we don't leave dangling references / traces. + + foreach avar [array names link] { + _unlink $name $avar + } + + namespace delete $name + interp alias {} $name {} +} + +# ::struct::matrix::__format_2string -- +# +# Formats the matrix using the specified report object and +# returns the string containing the result of this +# operation. The report has to support the "printmatrix" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# +# Results: +# A string containing the formatting result. + +proc ::struct::matrix::__format_2string {name {report {}}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # 1. Go through all columns and compute the column widths. + # 2. Then iterate through all rows and dump then into a + # string, formatted to the number of characters per columns + + array set cw {} + set cols [_columns $name] + for {set c 0} {$c < $cols} {incr c} { + set cw($c) [_columnwidth $name $c] + } + + set result [list] + set n [_rows $name] + for {set r 0} {$r < $n} {incr r} { + set rh [_rowheight $name $r] + if {$rh < 2} { + # Simple row. + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [__get_cell $name $c $r] + lappend line "$val[string repeat " " [expr {$cw($c)-[TermWidth $val]}]]" + } + lappend result [join $line " "] + } else { + # Complex row, multiple passes + for {set h 0} {$h < $rh} {incr h} { + set line [list] + for {set c 0} {$c < $cols} {incr c} { + set val [lindex [split [__get_cell $name $c $r] \n] $h] + lappend line "$val[string repeat " " [expr {$cw($c)-[TermWidth $val]}]]" + } + lappend result [join $line " "] + } + } + } + return [join $result \n] + } else { + return [$report printmatrix $name] + } +} + +# ::struct::matrix::__format_2chan -- +# +# Formats the matrix using the specified report object and +# writes the string containing the result of this operation into +# the channel. The report has to support the +# "printmatrix2channel" method. +# +# Arguments: +# name Name of the matrix. +# report Name of the report object specifying the formatting. +# chan Handle of the channel to write to. +# +# Results: +# None. + +proc ::struct::matrix::__format_2chan {name {report {}} {chan stdout}} { + if {$report == {}} { + # Use an internal hardwired simple report to format the matrix. + # We delegate this to the string formatter and print its result. + puts -nonewline $chan [__format_2string $name] + } else { + $report printmatrix2channel $name $chan + } + return +} + +# ::struct::matrix::__get_cell -- +# +# Returns the value currently contained in the cell identified +# by row and column index. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# row Row index of the addressed cell. +# +# Results: +# value Value currently stored in the addressed cell. + +proc ::struct::matrix::__get_cell {name column row} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + return $data($column,$row) +} + +# ::struct::matrix::__get_column -- +# +# Returns a list containing the values from all cells in the +# column identified by the index. The contents of the cell in +# row 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# column Column index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_column {name column} { + set column [ChkColumnIndex $name $column] + return [GetColumn $name $column] +} + +proc ::struct::matrix::GetColumn {name column} { + variable ${name}::data + variable ${name}::rows + + set result [list] + for {set r 0} {$r < $rows} {incr r} { + lappend result $data($column,$r) + } + return $result +} + +# ::struct::matrix::__get_rect -- +# +# Returns a list of lists of cell values. The values stored in +# the result come from the submatrix whose top-left and +# bottom-right cells are specified by "column_tl", "row_tl" and +# "column_br", "row_br" resp. Note that the following equations +# have to be true: column_tl <= column_br and row_tl <= row_br. +# The result is organized as follows: The outer list is the list +# of rows, its elements are lists representing a single row. The +# row with the smallest index is the first element of the outer +# list. The elements of the row lists represent the selected +# cell values. The cell with the smallest index is the first +# element in each row list. +# +# Arguments: +# name Name of the matrix. +# column_tl Column index of the top-left cell of the area. +# row_tl Row index of the top-left cell of the the area +# column_br Column index of the bottom-right cell of the area. +# row_br Row index of the bottom-right cell of the the area +# +# Results: +# List of a list of values stored in the addressed area. + +proc ::struct::matrix::__get_rect {name column_tl row_tl column_br row_br} { + set column_tl [ChkColumnIndex $name $column_tl] + set row_tl [ChkRowIndex $name $row_tl] + set column_br [ChkColumnIndex $name $column_br] + set row_br [ChkRowIndex $name $row_br] + + if { + ($column_tl > $column_br) || + ($row_tl > $row_br) + } { + return -code error "Invalid cell indices, wrong ordering" + } + return [GetRect $name $column_tl $row_tl $column_br $row_br] +} + +proc ::struct::matrix::GetRect {name column_tl row_tl column_br row_br} { + variable ${name}::data + set result [list] + + for {set r $row_tl} {$r <= $row_br} {incr r} { + set row [list] + for {set c $column_tl} {$c <= $column_br} {incr c} { + lappend row $data($c,$r) + } + lappend result $row + } + + return $result +} + +# ::struct::matrix::__get_row -- +# +# Returns a list containing the values from all cells in the +# row identified by the index. The contents of the cell in +# column 0 are stored as the first element of this list. +# +# Arguments: +# name Name of the matrix. +# row Row index of the addressed cell. +# +# Results: +# List of values stored in the addressed row. + +proc ::struct::matrix::__get_row {name row} { + set row [ChkRowIndex $name $row] + return [GetRow $name $row] +} + +proc ::struct::matrix::GetRow {name row} { + variable ${name}::data + variable ${name}::columns + + set result [list] + for {set c 0} {$c < $columns} {incr c} { + lappend result $data($c,$row) + } + return $result +} + +# ::struct::matrix::__insert_column -- +# +# Extends the matrix by one column and then acts like +# "setcolumn" (see below) on this new column if there were +# "values" supplied. Without "values" the new cells will be set +# to the empty string. The new column is inserted just before +# the column specified by the given index. This means, if +# "column" is less than or equal to zero, then the new column is +# inserted at the beginning of the matrix, before the first +# column. If "column" has the value "Bend", or if it is greater +# than or equal to the number of columns in the matrix, then the +# new column is appended to the matrix, behind the last +# column. The old column at the chosen index and all columns +# with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# column Index of the column where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_column {name column {values {}}} { + # Allow both negative and too big indices. + set column [ChkColumnIndexAll $name $column] + + variable ${name}::columns + + if {$column > $columns} { + # Same as 'addcolumn' + __add_column $name $values + return + } + + variable ${name}::data + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + set firstcol $column + if {$firstcol < 0} { + set firstcol 0 + } + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all rows, move all columns + + # Move all data from the higher columns one up and then insert the + # new data into the freed space. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + for {set r 0} {$r < $rows} {incr r} { + for {set cn $columns ; set c [expr {$cn - 1}]} {$c >= $firstcol} {incr c -1 ; incr cn -1} { + set data($cn,$r) $data($c,$r) + if {[info exists colw($c)]} { + set colw($cn) $colw($c) + unset colw($c) + } + } + set data($firstcol,$r) [lindex $values $r] + catch {unset rowh($r)} + } + incr columns + return +} + +# ::struct::matrix::__insert_row -- +# +# Extends the matrix by one row and then acts like "setrow" (see +# below) on this new row if there were "values" +# supplied. Without "values" the new cells will be set to the +# empty string. The new row is inserted just before the row +# specified by the given index. This means, if "row" is less +# than or equal to zero, then the new row is inserted at the +# beginning of the matrix, before the first row. If "row" has +# the value "end", or if it is greater than or equal to the +# number of rows in the matrix, then the new row is appended to +# the matrix, behind the last row. The old row at that index and +# all rows with higher indices are shifted one index upward. +# +# Arguments: +# name Name of the matrix. +# row Index of the row where to insert. +# values Optional values to set the cells to. +# +# Results: +# None. + +proc ::struct::matrix::__insert_row {name row {values {}}} { + # Allow both negative and too big indices. + set row [ChkRowIndexAll $name $row] + + variable ${name}::rows + + if {$row > $rows} { + # Same as 'addrow' + __add_row $name $values + return + } + + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + variable ${name}::colw + + set firstrow $row + if {$firstrow < 0} { + set firstrow 0 + } + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + # Invalidate all columns, move all rows + + # Move all data from the higher rows one up and then insert the + # new data into the freed space. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + for {set c 0} {$c < $columns} {incr c} { + for {set rn $rows ; set r [expr {$rn - 1}]} {$r >= $firstrow} {incr r -1 ; incr rn -1} { + set data($c,$rn) $data($c,$r) + if {[info exists rowh($r)]} { + set rowh($rn) $rowh($r) + unset rowh($r) + } + } + set data($c,$firstrow) [lindex $values $c] + catch {unset colw($c)} + } + incr rows + return +} + +# ::struct::matrix::_link -- +# +# Links the matrix to the specified array variable. This means +# that the contents of all cells in the matrix is stored in the +# array too, with all changes to the matrix propagated there +# too. The contents of the cell "(column,row)" is stored in the +# array using the key "column,row". If the option "-transpose" +# is specified the key "row,column" will be used instead. It is +# possible to link the matrix to more than one array. Note that +# the link is bidirectional, i.e. changes to the array are +# mirrored in the matrix too. +# +# Arguments: +# name Name of the matrix object. +# option Either empty of '-transpose'. +# avar Name of the variable to link to +# +# Results: +# None + +proc ::struct::matrix::_link {name args} { + switch -exact -- [llength $args] { + 0 { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + 1 { + set transpose 0 + set variable [lindex $args 0] + } + 2 { + foreach {t variable} $args break + if {[string compare $t -transpose]} { + return -code error "$name: illegal syntax: link ?-transpose? arrayvariable" + } + set transpose 1 + } + default { + return -code error "$name: wrong # args: link ?-transpose? arrayvariable" + } + } + + variable ${name}::link + + if {[info exists link($variable)]} { + return -code error "$name link: Variable \"$variable\" already linked to matrix" + } + + # Ok, a new variable we are linked to. Record this information, + # dump our current contents into the array, at last generate the + # traces actually performing the link. + + set link($variable) $transpose + + upvar #0 $variable array + variable ${name}::data + + foreach key [array names data] { + foreach {c r} [split $key ,] break + if {$transpose} { + set array($r,$c) $data($key) + } else { + set array($c,$r) $data($key) + } + } + + trace variable array wu [list ::struct::matrix::MatTraceIn $variable $name] + trace variable data w [list ::struct::matrix::MatTraceOut $variable $name] + return +} + +# ::struct::matrix::_links -- +# +# Retrieves the names of all array variable the matrix is +# officially linked to. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# List of variables the matrix is linked to. + +proc ::struct::matrix::_links {name} { + variable ${name}::link + return [array names link] +} + +# ::struct::matrix::_rowheight -- +# +# Returns the height of the specified row in lines. This is the +# highest number of lines spanned by a cell over all cells in +# the row. +# +# Arguments: +# name Name of the matrix +# row Index of the row queried for its height +# +# Results: +# The height of the specified row in lines. + +proc ::struct::matrix::_rowheight {name row} { + set row [ChkRowIndex $name $row] + + variable ${name}::rowh + + if {![info exists rowh($row)]} { + variable ${name}::columns + variable ${name}::data + + set height 1 + for {set c 0} {$c < $columns} {incr c} { + set cheight [llength [split $data($c,$row) \n]] + if {$cheight > $height} { + set height $cheight + } + } + + set rowh($row) $height + } + return $rowh($row) +} + +# ::struct::matrix::_rows -- +# +# Returns the number of rows currently managed by the matrix. +# +# Arguments: +# name Name of the matrix object. +# +# Results: +# The number of rows in the matrix. + +proc ::struct::matrix::_rows {name} { + variable ${name}::rows + return $rows +} + +# ::struct::matrix::_serialize -- +# +# Serialize a matrix object (partially) into a transportable value. +# If only a rectangle is serialized the result will be a sub- +# matrix in the mathematical sense of the word. +# +# Arguments: +# name Name of the matrix. +# args rectangle to place into the serialized matrix +# +# Results: +# A list structure describing the part of the matrix which was serialized. + +proc ::struct::matrix::_serialize {name args} { + + # all - boolean flag - set if and only if the all nodes of the + # matrix are chosen for serialization. Because if that is true we + # can skip the step finding the relevant arcs and simply take all + # arcs. + + set nargs [llength $args] + if {($nargs != 0) && ($nargs != 4)} { + return -code error "$name: wrong # args: serialize ?column_tl row_tl column_br row_br?" + } + + variable ${name}::rows + variable ${name}::columns + + if {$nargs == 4} { + foreach {column_tl row_tl column_br row_br} $args break + + set column_tl [ChkColumnIndex $name $column_tl] + set row_tl [ChkRowIndex $name $row_tl] + set column_br [ChkColumnIndex $name $column_br] + set row_br [ChkRowIndex $name $row_br] + + if { + ($column_tl > $column_br) || + ($row_tl > $row_br) + } { + return -code error "Invalid cell indices, wrong ordering" + } + set rn [expr {$row_br - $row_tl + 1}] + set cn [expr {$column_br - $column_tl + 1}] + } else { + set column_tl 0 + set row_tl 0 + set column_br [expr {$columns - 1}] + set row_br [expr {$rows - 1}] + set rn $rows + set cn $columns + } + + # We could optimize and remove empty cells to the right and rows + # to the bottom. For now we don't. + + return [list \ + $rn $cn \ + [GetRect $name $column_tl $row_tl $column_br $row_br]] +} + +# ::struct::matrix::__set_cell -- +# +# Sets the value in the cell identified by row and column index +# to the data in the third argument. +# +# Arguments: +# name Name of the matrix object. +# column Column index of the cell to set. +# row Row index of the cell to set. +# value The new value of the cell. +# +# Results: +# None. + +proc ::struct::matrix::__set_cell {name column row value} { + set column [ChkColumnIndex $name $column] + set row [ChkRowIndex $name $row] + + variable ${name}::data + + if {![string compare $value $data($column,$row)]} { + # No change, ignore call! + return + } + + set data($column,$row) $value + + if {$value != {}} { + variable ${name}::colw + variable ${name}::rowh + catch {unset colw($column)} + catch {unset rowh($row)} + } + return +} + +# ::struct::matrix::__set_column -- +# +# Sets the values in the cells identified by the column index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in row 0 and then upward. If there +# are less values in the list than there are rows the remaining +# rows are set to the empty string. If there are more values in +# the list than there are rows the superfluous elements are +# ignored. The matrix is not extended by this operation. +# +# Arguments: +# name Name of the matrix. +# column Index of the column to set. +# values Values to set into the column. +# +# Results: +# None. + +proc ::struct::matrix::__set_column {name column values} { + set column [ChkColumnIndex $name $column] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::rowh + variable ${name}::colw + + if {[set l [llength $values]] < $rows} { + # Missing values. Fill up with empty strings + + for {} {$l < $rows} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $rows} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$rows - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the column in the width cache. + # - The rows are either removed from the height cache or left + # unchanged, depending on the contents set into the cell. + + set r 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset rowh($r)} + } ; # {else leave the row unchanged} + set data($column,$r) $v + incr r + } + catch {unset colw($column)} + return +} + +# ::struct::matrix::__set_rect -- +# +# Takes a list of lists of cell values and writes them into the +# submatrix whose top-left cell is specified by the two +# indices. If the sublists of the outer list are not of equal +# length the shorter sublists will be filled with empty strings +# to the length of the longest sublist. If the submatrix +# specified by the top-left cell and the number of rows and +# columns in the "values" extends beyond the matrix we are +# modifying the over-extending parts of the values are ignored, +# i.e. essentially cut off. This subcommand expects its input in +# the format as returned by "getrect". +# +# Arguments: +# name Name of the matrix object. +# column Column index of the topleft cell to set. +# row Row index of the topleft cell to set. +# values Values to set. +# +# Results: +# None. + +proc ::struct::matrix::__set_rect {name column row values} { + # Allow negative indices! + set column [ChkColumnIndexNeg $name $column] + set row [ChkRowIndexNeg $name $row] + + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {$row < 0} { + # Remove rows from the head of values to restrict it to the + # overlapping area. + + set values [lrange $values [expr {0 - $row}] end] + set row 0 + } + + # Restrict it at the end too. + if {($row + [llength $values]) > $rows} { + set values [lrange $values 0 [expr {$rows - $row - 1}]] + } + + # Same for columns, but store it in some vars as this is required + # in a loop. + set firstcol 0 + if {$column < 0} { + set firstcol [expr {0 - $column}] + set column 0 + } + + # Now pan through values and area and copy the external data into + # the matrix. + + set r $row + foreach line $values { + set line [lrange $line $firstcol end] + + set l [expr {$column + [llength $line]}] + if {$l > $columns} { + set line [lrange $line 0 [expr {$columns - $column - 1}]] + } elseif {$l < [expr {$columns - $firstcol}]} { + # We have to take the offset into the line into account + # or we add fillers we don't need, overwriting part of the + # data array we shouldn't. + + for {} {$l < [expr {$columns - $firstcol}]} {incr l} { + lappend line {} + } + } + + set c $column + foreach cell $line { + if {$cell != {}} { + catch {unset rowh($r)} + catch {unset colw($c)} + } + set data($c,$r) $cell + incr c + } + incr r + } + return +} + +# ::struct::matrix::__set_row -- +# +# Sets the values in the cells identified by the row index to +# the elements of the list provided as the third argument. Each +# element of the list is assigned to one cell, with the first +# element going into the cell in column 0 and then upward. If +# there are less values in the list than there are columns the +# remaining columns are set to the empty string. If there are +# more values in the list than there are columns the superfluous +# elements are ignored. The matrix is not extended by this +# operation. +# +# Arguments: +# name Name of the matrix. +# row Index of the row to set. +# values Values to set into the row. +# +# Results: +# None. + +proc ::struct::matrix::__set_row {name row values} { + set row [ChkRowIndex $name $row] + SetRow $name $row $values +} + +proc ::struct::matrix::SetRow {name row values} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rows + variable ${name}::colw + variable ${name}::rowh + + if {[set l [llength $values]] < $columns} { + # Missing values. Fill up with empty strings + + for {} {$l < $columns} {incr l} { + lappend values {} + } + } elseif {[llength $values] > $columns} { + # To many values. Remove the superfluous items + set values [lrange $values 0 [expr {$columns - 1}]] + } + + # "values" now contains the information to set into the array. + # Regarding the width and height caches: + + # - Invalidate the row in the height cache. + # - The columns are either removed from the width cache or left + # unchanged, depending on the contents set into the cell. + + set c 0 + foreach v $values { + if {$v != {}} { + # Data changed unpredictably, invalidate cache + catch {unset colw($c)} + } ; # {else leave the row unchanged} + set data($c,$row) $v + incr c + } + catch {unset rowh($row)} + return +} + +# ::struct::matrix::__swap_columns -- +# +# Swaps the contents of the two specified columns. +# +# Arguments: +# name Name of the matrix. +# column_a Index of the first column to swap +# column_b Index of the second column to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_columns {name column_a column_b} { + set column_a [ChkColumnIndex $name $column_a] + set column_b [ChkColumnIndex $name $column_b] + return [SwapColumns $name $column_a $column_b] +} + +proc ::struct::matrix::SwapColumns {name column_a column_b} { + variable ${name}::data + variable ${name}::rows + variable ${name}::colw + + # Note: This operation does not influence the height cache for all + # rows and the width cache only insofar as its contents has to be + # swapped too for the two columns we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set r 0} {$r < $rows} {incr r} { + set tmp $data($column_a,$r) + set data($column_a,$r) $data($column_b,$r) + set data($column_b,$r) $tmp + } + + set cwa [info exists colw($column_a)] + set cwb [info exists colw($column_b)] + + if {$cwa && $cwb} { + set tmp $colw($column_a) + set colw($column_a) $colw($column_b) + set colw($column_b) $tmp + } elseif {$cwa} { + # Move contents, don't swap. + set colw($column_b) $colw($column_a) + unset colw($column_a) + } elseif {$cwb} { + # Move contents, don't swap. + set colw($column_a) $colw($column_b) + unset colw($column_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::__swap_rows -- +# +# Swaps the contents of the two specified rows. +# +# Arguments: +# name Name of the matrix. +# row_a Index of the first row to swap +# row_b Index of the second row to swap +# +# Results: +# None. + +proc ::struct::matrix::__swap_rows {name row_a row_b} { + set row_a [ChkRowIndex $name $row_a] + set row_b [ChkRowIndex $name $row_b] + return [SwapRows $name $row_a $row_b] +} + +proc ::struct::matrix::SwapRows {name row_a row_b} { + variable ${name}::data + variable ${name}::columns + variable ${name}::rowh + + # Note: This operation does not influence the width cache for all + # columns and the height cache only insofar as its contents has to be + # swapped too for the two rows we are touching. Note that the + # cache might be partially filled or not at all, so we don't have + # to "swap" in some situations. + + for {set c 0} {$c < $columns} {incr c} { + set tmp $data($c,$row_a) + set data($c,$row_a) $data($c,$row_b) + set data($c,$row_b) $tmp + } + + set rha [info exists rowh($row_a)] + set rhb [info exists rowh($row_b)] + + if {$rha && $rhb} { + set tmp $rowh($row_a) + set rowh($row_a) $rowh($row_b) + set rowh($row_b) $tmp + } elseif {$rha} { + # Move contents, don't swap. + set rowh($row_b) $rowh($row_a) + unset rowh($row_a) + } elseif {$rhb} { + # Move contents, don't swap. + set rowh($row_a) $rowh($row_b) + unset rowh($row_b) + } ; # else {nothing to do at all} + return +} + +# ::struct::matrix::_transpose -- +# +# Exchanges rows and columns of the matrix +# +# Arguments: +# name Name of the matrix. +# +# Results: +# None. + +proc ::struct::matrix::_transpose {name} { + variable ${name}::rows + variable ${name}::columns + + if {$rows == 0} { + # Change the dimensions. + # There is no data to shift. + # The row/col caches are empty too. + + set rows $columns + set columns 0 + return + + } elseif {$columns == 0} { + # Change the dimensions. + # There is no data to shift. + # The row/col caches are empty too. + + set columns $rows + set rows 0 + return + } + + variable ${name}::data + variable ${name}::rowh + variable ${name}::colw + + # Exchanging the row/col caches is easy, independent of the actual + # dimensions of the matrix. + + set rhc [array get rowh] + set cwc [array get colw] + + unset rowh ; array set rowh $cwc + unset colw ; array set colw $rhc + + if {$rows == $columns} { + # A square matrix. We have to swap data around, but there is + # need to resize any of the arrays. Only the core is present. + + set n $columns + + } elseif {$rows > $columns} { + # Rectangular matrix, we have to delete rows, and add columns. + + for {set r $columns} {$r < $rows} {incr r} { + for {set c 0} {$c < $columns} {incr c} { + set data($r,$c) $data($c,$r) + unset data($c,$r) + } + } + + set n $columns ; # Size of the core. + } else { + # rows < columns. Rectangular matrix, we have to delete + # columns, and add rows. + + for {set c $rows} {$c < $columns} {incr c} { + for {set r 0} {$r < $rows} {incr r} { + set data($r,$c) $data($c,$r) + unset data($c,$r) + } + } + + set n $rows ; # Size of the core. + } + + set tmp $rows + set rows $columns + set columns $tmp + + # Whatever the actual dimensions, a square core is always + # present. The data of this core is now shuffled + + for {set i 0} {$i < $n} {incr i} { + for {set j $i ; incr j} {$j < $n} {incr j} { + set tmp $data($i,$j) + set data($i,$j) $data($j,$i) + set data($j,$i) $tmp + } + } + return +} + +# ::struct::matrix::_unlink -- +# +# Removes the link between the matrix and the specified +# arrayvariable, if there is one. +# +# Arguments: +# name Name of the matrix. +# avar Name of the linked array. +# +# Results: +# None. + +proc ::struct::matrix::_unlink {name avar} { + + variable ${name}::link + + if {![info exists link($avar)]} { + # Ignore unlinking of unknown variables. + return + } + + # Delete the traces first, then remove the link management + # information from the object. + + upvar #0 $avar array + variable ${name}::data + + trace vdelete array wu [list ::struct::matrix::MatTraceIn $avar $name] + trace vdelete date w [list ::struct::matrix::MatTraceOut $avar $name] + + unset link($avar) + return +} + +# ::struct::matrix::ChkColumnIndex -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndex {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {($cc < 0) || ($cc >= $columns)} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + if {$columns <= 0} { + return -code error "bad column index $column, column does not exist" + } + return [expr {$columns - 1}] + } + {[0-9]+} { + if {($column < 0) || ($column >= $columns)} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndex -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndex {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {($rr < 0) || ($rr >= $rows)} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + if {$rows <= 0} { + return -code error "bad row index $row, row does not exist" + } + return [expr {$rows - 1}] + } + {[0-9]+} { + if {($row < 0) || ($row >= $rows)} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexNeg -- +# +# Helper to check and transform column indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of columns +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexNeg {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + if {$cc >= $columns} { + return -code error "bad column index end-$column, column does not exist" + } + return $cc + } + end { + return [expr {$columns - 1}] + } + {[0-9]+} { + if {$column >= $columns} { + return -code error "bad column index $column, column does not exist" + } + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexNeg -- +# +# Helper to check and transform row indices. Returns the +# absolute index number belonging to the specified +# index. Rejects indices out of the valid range of rows +# (Accepts negative indices). +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexNeg {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + if {$rr >= $rows} { + return -code error "bad row index end-$row, row does not exist" + } + return $rr + } + end { + return [expr {$rows - 1}] + } + {[0-9]+} { + if {$row >= $rows} { + return -code error "bad row index $row, row does not exist" + } + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkColumnIndexAll -- +# +# Helper to transform column indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# column The incoming index to check and transform +# +# Results: +# The absolute index to the column + +proc ::struct::matrix::ChkColumnIndexAll {name column} { + variable ${name}::columns + + switch -regexp -- $column { + {end-[0-9]+} { + set column [string map {end- ""} $column] + set cc [expr {$columns - 1 - $column}] + return $cc + } + end { + return $columns + } + {[0-9]+} { + return $column + } + default { + return -code error "bad column index \"$column\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::ChkRowIndexAll -- +# +# Helper to transform row indices. Returns the +# absolute index number belonging to the specified +# index. +# +# Arguments: +# matrix Matrix to look at +# row The incoming index to check and transform +# +# Results: +# The absolute index to the row + +proc ::struct::matrix::ChkRowIndexAll {name row} { + variable ${name}::rows + + switch -regexp -- $row { + {end-[0-9]+} { + set row [string map {end- ""} $row] + set rr [expr {$rows - 1 - $row}] + return $rr + } + end { + return $rows + } + {[0-9]+} { + return $row + } + default { + return -code error "bad row index \"$row\", syntax error" + } + } + # Will not come to this place +} + +# ::struct::matrix::MatTraceIn -- +# +# Helper propagating changes made to an array +# into the matrix the array is linked to. +# +# Arguments: +# avar Name of the array which was changed. +# name Matrix to write the changes to. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceIn {avar name var idx op} { + # Propagate changes in the linked array back into the matrix. + + variable ${name}::lock + if {$lock} {return} + + # We have to cover two possibilities when encountering an "unset" operation ... + # 1. The external array was destroyed: perform automatic unlink. + # 2. An individual element was unset: Set the corresponding cell to the empty string. + # See SF Tcllib Bug #532791. + + if {(![string compare $op u]) && ($idx == {})} { + # Possibility 1: Array was destroyed + $name unlink $avar + return + } + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + # Use standard method to propagate the change. + # => Get automatically index checks, cache updates, ... + + if {![string compare $op u]} { + # Unset possibility 2: Element was unset. + # Note: Setting the cell to the empty string will + # invoke MatTraceOut for this array and thus try + # to recreate the destroyed element of the array. + # We don't want this. But we do want to propagate + # the change to other arrays, as "unset". To do + # all of this we use another state variable to + # signal this situation. + + variable ${name}::unset + set unset $avar + + $name set cell $c $r "" + + set unset {} + return + } + + $name set cell $c $r $array($idx) + return +} + +# ::struct::matrix::MatTraceOut -- +# +# Helper propagating changes made to the matrix into the linked arrays. +# +# Arguments: +# avar Name of the array to write the changes to. +# name Matrix which was changed. +# var,idx,op Standard trace arguments +# +# Results: +# None. + +proc ::struct::matrix::MatTraceOut {avar name var idx op} { + # Propagate changes in the matrix data array into the linked array. + + variable ${name}::unset + + if {![string compare $avar $unset]} { + # Do not change the variable currently unsetting + # one of its elements. + return + } + + variable ${name}::lock + set lock 1 ; # Disable MatTraceIn [#532783] + + upvar #0 $avar array + variable ${name}::data + variable ${name}::link + + set transpose $link($avar) + + if {$transpose} { + foreach {r c} [split $idx ,] break + } else { + foreach {c r} [split $idx ,] break + } + + if {$unset != {}} { + # We are currently propagating the unset of an + # element in a different linked array to this + # array. We make sure that this is an unset too. + + unset array($c,$r) + } else { + set array($c,$r) $data($idx) + } + set lock 0 + return +} + +# ::struct::matrix::SortMaxHeapify -- +# +# Helper for the 'sort' method. Performs the central algorithm +# which converts the matrix into a heap, easily sortable. +# +# Arguments: +# name Matrix object which is sorted. +# i Index of the row/column currently being sorted. +# key Index of the column/row to sort the rows/columns by. +# rowCol Indicator if we are sorting rows ('r'), or columns ('c'). +# heapSize Number of rows/columns to sort. +# rev Boolean flag, set if sorting is done revers (-decreasing). +# +# Sideeffects: +# Transforms the matrix into a heap of rows/columns, +# swapping them around. +# +# Results: +# None. + +proc ::struct::matrix::SortMaxHeapify {name i key rowCol heapSize {rev 0}} { + # MAX-HEAPIFY, adapted by EAS from CLRS 6.2 + switch $rowCol { + r { set A [GetColumn $name $key] } + c { set A [GetRow $name $key] } + } + # Weird expressions below for clarity, as CLRS uses A[1...n] + # format and TCL uses A[0...n-1] + set left [expr {int(2*($i+1) -1)}] + set right [expr {int(2*($i+1)+1 -1)}] + + # left, right are tested as < rather than <= because they are + # in A[0...n-1] + if { + $left < $heapSize && + ( !$rev && [lindex $A $left] > [lindex $A $i] || + $rev && [lindex $A $left] < [lindex $A $i] ) + } { + set largest $left + } else { + set largest $i + } + + if { + $right < $heapSize && + ( !$rev && [lindex $A $right] > [lindex $A $largest] || + $rev && [lindex $A $right] < [lindex $A $largest] ) + } { + set largest $right + } + + if { $largest != $i } { + switch $rowCol { + r { SwapRows $name $i $largest } + c { SwapColumns $name $i $largest } + } + SortMaxHeapify $name $largest $key $rowCol $heapSize $rev + } + return +} + +# ::struct::matrix::CheckSerialization -- +# +# Validate the serialization of a matrix. +# +# Arguments: +# ser Serialization to validate. +# rvar Variable to store the number of rows into. +# cvar Variable to store the number of columns into. +# dvar Variable to store the matrix data into. +# +# Results: +# none + +proc ::struct::matrix::CheckSerialization {ser rvar cvar dvar} { + upvar 1 \ + $rvar rows \ + $cvar columns \ + $dvar data + + # Overall length ok ? + if {[llength $ser] != 3} { + return -code error \ + "error in serialization: list length not 3." + } + + foreach {r c d} $ser break + + # Check rows/columns information + + if {![string is integer -strict $r] || ($r < 0)} { + return -code error \ + "error in serialization: bad number of rows \"$r\"." + } + if {![string is integer -strict $c] || ($c < 0)} { + return -code error \ + "error in serialization: bad number of columns \"$c\"." + } + + # Validate data against rows/columns. We can have less data than + # rows or columns, the missing cells will be initialized to the + # empty string. But too many is considered as a signal of + # being something wrong. + + if {[llength $d] > $r} { + return -code error \ + "error in serialization: data for to many rows." + } + foreach rv $d { + if {[llength $rv] > $c} { + return -code error \ + "error in serialization: data for to many columns." + } + } + + # Ok. The data is now ready for the caller. + + set data $d + set rows $r + set columns $c + return +} + +# ::struct::matrix::DeleteRows -- +# +# Deletes n rows from the bottom of the matrix. +# +# Arguments: +# name Name of the matrix. +# n The number of rows to delete (no greater than the number of rows). +# +# Results: +# None. + +proc ::struct::matrix::DeleteRows {name n} { + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher rows down and then delete the + # superfluous data in the old last row. Move the data in the + # height cache too, take partial fill into account there too. + # Invalidate the width cache for all columns. + + set rowstart [expr {$rows - $n}] + + for {set c 0} {$c < $columns} {incr c} { + for {set r $rowstart} {$r < $rows} {incr r} { + unset data($c,$r) + catch {unset rowh($r)} + } + catch {unset colw($c)} + } + set rows $rowstart + return +} + +# ::struct::matrix::DeleteColumns -- +# +# Deletes n columns from the right of the matrix. +# +# Arguments: +# name Name of the matrix. +# n The number of columns to delete. +# +# Results: +# None. + +proc ::struct::matrix::DeleteColumns {name n} { + variable ${name}::data + variable ${name}::rows + variable ${name}::columns + variable ${name}::colw + variable ${name}::rowh + + # Move all data from the higher columns down and then delete the + # superfluous data in the old last column. Move the data in the + # width cache too, take partial fill into account there too. + # Invalidate the height cache for all rows. + + set colstart [expr {$columns - $n}] + + for {set r 0} {$r < $rows} {incr r} { + for {set c $colstart} {$c < $columns} {incr c} { + unset data($c,$r) + catch {unset colw($c)} + } + catch {unset rowh($r)} + } + set columns $colstart + return +} + +# ::struct::matrix::TermWidth -- +# +# Computes the number of terminal columns taken by the input string. +# This discounts ANSI color codes as zero-width, and asian characters +# as double-width. +# +# Arguments: +# str String to process +# +# Results: +# Number of terminal columns covered by string argument + +proc ::struct::matrix::TermWidth {str} { + # Look for ANSI color control sequences and remove them. Avoid counting their characters as such + # sequences as a whole represent a state change, and are logically of zero/no width. + # Further use wcswidth to account for double-wide Asian characters. + + regsub -all "\033\\\[\[0-9;\]*m" $str {} str + return [textutil::wcswidth $str] +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Get 'matrix::matrix' into the general structure namespace. + namespace import -force matrix::matrix + namespace export matrix +} +package provide struct::matrix 2.1 diff --git a/src/vendormodules/struct/set-2.2.3.tm b/src/vendormodules/struct/set-2.2.3.tm new file mode 100644 index 00000000..2ed2c260 --- /dev/null +++ b/src/vendormodules/struct/set-2.2.3.tm @@ -0,0 +1,189 @@ +#---------------------------------------------------------------------- +# +# sets.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +# @mdgen EXCLUDE: sets_c.tcl + +package require Tcl 8.5- + +namespace eval ::struct::set {} + +# ### ### ### ######### ######### ######### +## Management of set implementations. + +# ::struct::set::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::set::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of set requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::set_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir sets_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::set::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::set::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::set ::struct::set_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::set_$key ::struct::set + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +proc ::struct::set::Loaded {} { + variable loaded + return $loaded +} + +# ::struct::set::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::set::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::set::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::set::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::set::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::set { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::set { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export set +} + +package provide struct::set 2.2.3 diff --git a/src/vendormodules/struct/sets.tcl b/src/vendormodules/struct/sets.tcl new file mode 100644 index 00000000..2ed2c260 --- /dev/null +++ b/src/vendormodules/struct/sets.tcl @@ -0,0 +1,189 @@ +#---------------------------------------------------------------------- +# +# sets.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +# @mdgen EXCLUDE: sets_c.tcl + +package require Tcl 8.5- + +namespace eval ::struct::set {} + +# ### ### ### ######### ######### ######### +## Management of set implementations. + +# ::struct::set::LoadAccelerator -- +# +# Loads a named implementation, if possible. +# +# Arguments: +# key Name of the implementation to load. +# +# Results: +# A boolean flag. True if the implementation +# was successfully loaded; and False otherwise. + +proc ::struct::set::LoadAccelerator {key} { + variable accel + set r 0 + switch -exact -- $key { + critcl { + # Critcl implementation of set requires Tcl 8.4. + if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} + if {[catch {package require tcllibc}]} {return 0} + set r [llength [info commands ::struct::set_critcl]] + } + tcl { + variable selfdir + source [file join $selfdir sets_tcl.tcl] + set r 1 + } + default { + return -code error "invalid accelerator/impl. package $key:\ + must be one of [join [KnownImplementations] {, }]" + } + } + set accel($key) $r + return $r +} + +# ::struct::set::SwitchTo -- +# +# Activates a loaded named implementation. +# +# Arguments: +# key Name of the implementation to activate. +# +# Results: +# None. + +proc ::struct::set::SwitchTo {key} { + variable accel + variable loaded + + if {[string equal $key $loaded]} { + # No change, nothing to do. + return + } elseif {![string equal $key ""]} { + # Validate the target implementation of the switch. + + if {![info exists accel($key)]} { + return -code error "Unable to activate unknown implementation \"$key\"" + } elseif {![info exists accel($key)] || !$accel($key)} { + return -code error "Unable to activate missing implementation \"$key\"" + } + } + + # Deactivate the previous implementation, if there was any. + + if {![string equal $loaded ""]} { + rename ::struct::set ::struct::set_$loaded + } + + # Activate the new implementation, if there is any. + + if {![string equal $key ""]} { + rename ::struct::set_$key ::struct::set + } + + # Remember the active implementation, for deactivation by future + # switches. + + set loaded $key + return +} + +proc ::struct::set::Loaded {} { + variable loaded + return $loaded +} + +# ::struct::set::Implementations -- +# +# Determines which implementations are +# present, i.e. loaded. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. + +proc ::struct::set::Implementations {} { + variable accel + set res {} + foreach n [array names accel] { + if {!$accel($n)} continue + lappend res $n + } + return $res +} + +# ::struct::set::KnownImplementations -- +# +# Determines which implementations are known +# as possible implementations. +# +# Arguments: +# None. +# +# Results: +# A list of implementation keys. In the order +# of preference, most prefered first. + +proc ::struct::set::KnownImplementations {} { + return {critcl tcl} +} + +proc ::struct::set::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::struct::set { + variable selfdir [file dirname [info script]] + variable accel + array set accel {tcl 0 critcl 0} + variable loaded {} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::struct::set { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e +} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Export the constructor command. + namespace export set +} + +package provide struct::set 2.2.3 diff --git a/src/vendormodules/struct/sets_c.tcl b/src/vendormodules/struct/sets_c.tcl new file mode 100644 index 00000000..c9837e94 --- /dev/null +++ b/src/vendormodules/struct/sets_c.tcl @@ -0,0 +1,93 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. C implementation. +# +# Copyright (c) 2007 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +package require critcl +# @sak notprovided struct_setc +package provide struct_setc 2.1.1 +package require Tcl 8.5- + +namespace eval ::struct { + # Supporting code for the main command. + + catch { + #critcl::cheaders -g + #critcl::debug memory symbols + } + + critcl::cheaders sets/*.h + critcl::csources sets/*.c + + critcl::ccode { + /* -*- c -*- */ + + #include + } + + # Main command, set creation. + + critcl::ccommand set_critcl {dummy interp objc objv} { + /* Syntax - dispatcher to the sub commands. + */ + + static CONST char* methods [] = { + "add", "contains", "difference", "empty", + "equal","exclude", "include", "intersect", + "intersect3", "size", "subsetof", "subtract", + "symdiff", "union", + NULL + }; + enum methods { + S_add, S_contains, S_difference, S_empty, + S_equal,S_exclude, S_include, S_intersect, + S_intersect3, S_size, S_subsetof, S_subtract, + S_symdiff, S_union + }; + + int m; + + if (objc < 2) { + Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); + return TCL_ERROR; + } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", + 0, &m) != TCL_OK) { + return TCL_ERROR; + } + + /* Dispatch to methods. They check the #args in detail before performing + * the requested functionality + */ + + switch (m) { + case S_add: return sm_ADD (NULL, interp, objc, objv); + case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); + case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); + case S_empty: return sm_EMPTY (NULL, interp, objc, objv); + case S_equal: return sm_EQUAL (NULL, interp, objc, objv); + case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); + case S_include: return sm_INCLUDE (NULL, interp, objc, objv); + case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); + case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); + case S_size: return sm_SIZE (NULL, interp, objc, objv); + case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); + case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); + case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); + case S_union: return sm_UNION (NULL, interp, objc, objv); + } + /* Not coming to this place */ + } +} + +# ### ### ### ######### ######### ######### +## Ready diff --git a/src/vendormodules/struct/sets_tcl.tcl b/src/vendormodules/struct/sets_tcl.tcl new file mode 100644 index 00000000..ad76704f --- /dev/null +++ b/src/vendormodules/struct/sets_tcl.tcl @@ -0,0 +1,452 @@ +#---------------------------------------------------------------------- +# +# sets_tcl.tcl -- +# +# Definitions for the processing of sets. +# +# Copyright (c) 2004-2008 by Andreas Kupries. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ +# +#---------------------------------------------------------------------- + +package require Tcl 8.5- + +namespace eval ::struct::set { + # Only export one command, the one used to instantiate a new tree + namespace export set_tcl +} + +########################## +# Public functions + +# ::struct::set::set -- +# +# Command that access all set commands. +# +# Arguments: +# cmd Name of the subcommand to dispatch to. +# args Arguments for the subcommand. +# +# Results: +# Whatever the result of the subcommand is. + +proc ::struct::set::set_tcl {cmd args} { + # Do minimal args checks here + if { [llength [info level 0]] == 1 } { + return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" + } + ::set sub S_$cmd + if { [llength [info commands ::struct::set::$sub]] == 0 } { + ::set optlist [info commands ::struct::set::S_*] + ::set xlist {} + foreach p $optlist { + lappend xlist [string range $p 17 end] + } + return -code error \ + "bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" + } + return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] +} + +########################## +# Implementations of the functionality. +# + +# ::struct::set::S_empty -- +# +# Determines emptiness of the set +# +# Parameters: +# set -- The set to check for emptiness. +# +# Results: +# A boolean value. True indicates that the set is empty. +# +# Side effects: +# None. +# +# Notes: + +proc ::struct::set::S_empty {set} { + return [expr {[llength $set] == 0}] +} + +# ::struct::set::S_size -- +# +# Computes the cardinality of the set. +# +# Parameters: +# set -- The set to inspect. +# +# Results: +# An integer greater than or equal to zero. +# +# Side effects: +# None. + +proc ::struct::set::S_size {set} { + return [llength [Cleanup $set]] +} + +# ::struct::set::S_contains -- +# +# Determines if the item is in the set. +# +# Parameters: +# set -- The set to inspect. +# item -- The element to look for. +# +# Results: +# A boolean value. True indicates that the element is present. +# +# Side effects: +# None. + +proc ::struct::set::S_contains {set item} { + return [expr {[lsearch -exact $set $item] >= 0}] +} + +# ::struct::set::S_union -- +# +# Computes the union of the arguments. +# +# Parameters: +# args -- List of sets to unify. +# +# Results: +# The union of the arguments. +# +# Side effects: +# None. + +proc ::struct::set::S_union {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + foreach setX $args { + foreach x $setX {::set ($x) {}} + } + return [array names {}] +} + + +# ::struct::set::S_intersect -- +# +# Computes the intersection of the arguments. +# +# Parameters: +# args -- List of sets to intersect. +# +# Results: +# The intersection of the arguments +# +# Side effects: +# None. + +proc ::struct::set::S_intersect {args} { + switch -exact -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + } + ::set res [lindex $args 0] + foreach set [lrange $args 1 end] { + if {[llength $res] && [llength $set]} { + ::set res [Intersect $res $set] + } else { + # Squash 'res'. Otherwise we get the wrong result if res + # is not empty, but 'set' is. + ::set res {} + break + } + } + return $res +} + +proc ::struct::set::Intersect {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + + # This is slower than local vars, but more robust + if {[llength $B] > [llength $A]} { + ::set res $A + ::set A $B + ::set B $res + } + ::set res {} + foreach x $A {::set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res +} + +# ::struct::set::S_difference -- +# +# Compute difference of two sets. +# +# Parameters: +# A, B -- Sets to compute the difference for. +# +# Results: +# A - B +# +# Side effects: +# None. + +proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] +} + +if {0} { + # Tcllib SF Bug 1002143. We cannot use the implementation below. + # It will treat set elements containing '(' and ')' as array + # elements, and this screws up the storage of elements as the name + # of local vars something fierce. No way around this. Disabling + # this code and always using the other implementation (s.a.) is + # the only possible fix. + + if {[package vcompare [package provide Tcl] 8.4] < 0} { + # Tcl 8.[23]. Use explicit array to perform the operation. + } else { + # Tcl 8.4+, has 'unset -nocomplain' + + proc ::struct::set::S_difference {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return $A} + + # Get the variable B out of the way, avoid collisions + # prepare for "pure list optimization" + ::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] + unset B + + # unset A early: no local variables left + foreach [lindex [list $A [unset A]] 0] {.} {break} + + eval $::struct::set::tmp + return [info locals] + } + } +} + +# ::struct::set::S_symdiff -- +# +# Compute symmetric difference of two sets. +# +# Parameters: +# A, B -- The sets to compute the s.difference for. +# +# Results: +# The symmetric difference of the two input sets. +# +# Side effects: +# None. + +proc ::struct::set::S_symdiff {A B} { + # symdiff == (A-B) + (B-A) == (A+B)-(A*B) + if {[llength $A] == 0} {return $B} + if {[llength $B] == 0} {return $A} + return [S_union \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_intersect3 -- +# +# Return intersection and differences for two sets. +# +# Parameters: +# A, B -- The sets to inspect. +# +# Results: +# List containing A*B, A-B, and B-A +# +# Side effects: +# None. + +proc ::struct::set::S_intersect3 {A B} { + return [list \ + [S_intersect $A $B] \ + [S_difference $A $B] \ + [S_difference $B $A]] +} + +# ::struct::set::S_equal -- +# +# Compares two sets for equality. +# +# Parameters: +# a First set to compare. +# b Second set to compare. +# +# Results: +# A boolean. True if the lists are equal. +# +# Side effects: +# None. + +proc ::struct::set::S_equal {A B} { + ::set A [Cleanup $A] + ::set B [Cleanup $B] + + # Equal if of same cardinality and difference is empty. + + if {[::llength $A] != [::llength $B]} {return 0} + return [expr {[llength [S_difference $A $B]] == 0}] +} + + +proc ::struct::set::Cleanup {A} { + # unset A to avoid collisions + if {[llength $A] < 2} {return $A} + # We cannot use variables to avoid an explicit array. The set + # elements may look like namespace vars (i.e. contain ::), and + # such elements break that, cannot be proc-local variables. + array set S {} + foreach item $A {set S($item) .} + return [array names S] +} + +# ::struct::set::S_include -- +# +# Add an element to a set. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# element -- The item to add to the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by the element (if the element was not already present). + +proc ::struct::set::S_include {Avar element} { + # Avar = Avar + {element} + upvar 1 $Avar A + if {![info exists A] || ![S_contains $A $element]} { + lappend A $element + } + return +} + +# ::struct::set::S_exclude -- +# +# Remove an element from a set. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# element -- The item to remove from the set. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# the element remove (if the element was actually present). + +proc ::struct::set::S_exclude {Avar element} { + # Avar = Avar - {element} + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + while {[::set pos [lsearch -exact $A $element]] >= 0} { + ::set A [lreplace [K $A [::set A {}]] $pos $pos] + } + return +} + +# ::struct::set::S_add -- +# +# Add a set to a set. Similar to 'union', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to extend. +# B -- The set to add to the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is extended +# by all the elements in B. + +proc ::struct::set::S_add {Avar B} { + # Avar = Avar + B + upvar 1 $Avar A + if {![info exists A]} {set A {}} + ::set A [S_union [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subtract -- +# +# Remove a set from a set. Similar to 'difference', but the first argument +# is a variable. +# +# Parameters: +# Avar -- Reference to the set variable to shrink. +# B -- The set to remove from the set in Avar. +# +# Results: +# None. +# +# Side effects: +# The set in the variable referenced by Avar is shrunk, +# all elements of B are removed. + +proc ::struct::set::S_subtract {Avar B} { + # Avar = Avar - B + upvar 1 $Avar A + if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} + ::set A [S_difference [K $A [::set A {}]] $B] + return +} + +# ::struct::set::S_subsetof -- +# +# A predicate checking if the first set is a subset +# or equal to the second set. +# +# Parameters: +# A -- The possible subset. +# B -- The set to compare to. +# +# Results: +# A boolean value, true if A is subset of or equal to B +# +# Side effects: +# None. + +proc ::struct::set::S_subsetof {A B} { + # A subset|== B <=> (A == A*B) + return [S_equal $A [S_intersect $A $B]] +} + +# ::struct::set::K -- +# Performance helper command. + +proc ::struct::set::K {x y} {::set x} + +# ### ### ### ######### ######### ######### +## Ready + +namespace eval ::struct { + # Put 'set::set' into the general structure namespace + # for pickup by the main management. + + namespace import -force set::set_tcl +} diff --git a/src/vendormodules/textutil-0.9.tm b/src/vendormodules/textutil-0.9.tm new file mode 100644 index 00000000..59258514 --- /dev/null +++ b/src/vendormodules/textutil-0.9.tm @@ -0,0 +1,80 @@ +# textutil.tcl -- +# +# Utilities for manipulating strings, words, single lines, +# paragraphs, ... +# +# Copyright (c) 2000 by Ajuba Solutions. +# Copyright (c) 2000 by Eric Melski +# Copyright (c) 2002 by Joe English +# Copyright (c) 2001-2006 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: textutil.tcl,v 1.17 2006/09/21 06:46:24 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.2 + +namespace eval ::textutil {} + +# ### ### ### ######### ######### ######### +## API implementation +## All through sub-packages imported here. + +package require textutil::string +package require textutil::repeat +package require textutil::adjust +package require textutil::split +package require textutil::tabify +package require textutil::trim +package require textutil::wcswidth + +namespace eval ::textutil { + # Import the miscellaneous string command for public export + + namespace import -force string::chop string::tail + namespace import -force string::cap string::uncap string::capEachWord + namespace import -force string::longestCommonPrefix + namespace import -force string::longestCommonPrefixList + + # Import the repeat commands for public export + + namespace import -force repeat::strRepeat repeat::blank + + # Import the adjust commands for public export + + namespace import -force adjust::adjust adjust::indent adjust::undent + + # Import the split commands for public export + + namespace import -force split::splitx split::splitn + + # Import the trim commands for public export + + namespace import -force trim::trim trim::trimleft trim::trimright + namespace import -force trim::trimPrefix trim::trimEmptyHeading + + # Import the tabify commands for public export + + namespace import -force tabify::tabify tabify::untabify + namespace import -force tabify::tabify2 tabify::untabify2 + + # Re-export all the imported commands + + namespace export chop tail cap uncap capEachWord + namespace export longestCommonPrefix longestCommonPrefixList + namespace export strRepeat blank + namespace export adjust indent undent + namespace export splitx splitn + namespace export trim trimleft trimright trimPrefix trimEmptyHeading + namespace export tabify untabify tabify2 untabify2 +} + + +# ### ### ### ######### ######### ######### +## Ready + +package provide textutil 0.9 diff --git a/src/vendormodules/textutil/adjust-0.7.3.tm b/src/vendormodules/textutil/adjust-0.7.3.tm new file mode 100644 index 00000000..d47c82f8 --- /dev/null +++ b/src/vendormodules/textutil/adjust-0.7.3.tm @@ -0,0 +1,761 @@ +# trim.tcl -- +# +# Various ways of trimming a string. +# +# Copyright (c) 2000 by Ajuba Solutions. +# Copyright (c) 2000 by Eric Melski +# Copyright (c) 2002-2004 by Johannes-Heinrich Vogeler +# Copyright (c) 2001-2006 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: adjust.tcl,v 1.16 2011/12/13 18:12:56 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.2 +package require textutil::repeat +package require textutil::string + +namespace eval ::textutil::adjust {} + +# ### ### ### ######### ######### ######### +## API implementation + +namespace eval ::textutil::adjust { + namespace import -force ::textutil::repeat::strRepeat +} + +proc ::textutil::adjust::adjust {text args} { + if {[string length [string trim $text]] == 0} { + return "" + } + + Configure $args + Adjust text newtext + + return $newtext +} + +proc ::textutil::adjust::Configure {args} { + variable Justify left + variable Length 72 + variable FullLine 0 + variable StrictLength 0 + variable Hyphenate 0 + variable HyphPatterns ; # hyphenation patterns (TeX) + + set args [ lindex $args 0 ] + foreach { option value } $args { + switch -exact -- $option { + -full { + if { ![ string is boolean -strict $value ] } then { + error "expected boolean but got \"$value\"" + } + set FullLine [ string is true $value ] + } + -hyphenate { + # the word exceeding the length of line is tried to be + # hyphenated; if a word cannot be hyphenated to fit into + # the line processing stops! The length of the line should + # be set to a reasonable value! + + if { ![ string is boolean -strict $value ] } then { + error "expected boolean but got \"$value\"" + } + set Hyphenate [string is true $value] + if { $Hyphenate && ![info exists HyphPatterns(_LOADED_)]} { + error "hyphenation patterns not loaded!" + } + } + -justify { + set lovalue [ string tolower $value ] + switch -exact -- $lovalue { + left - + right - + center - + plain { + set Justify $lovalue + } + default { + error "bad value \"$value\": should be center, left, plain or right" + } + } + } + -length { + if { ![ string is integer $value ] } then { + error "expected positive integer but got \"$value\"" + } + if { $value < 1 } then { + error "expected positive integer but got \"$value\"" + } + set Length $value + } + -strictlength { + # the word exceeding the length of line is moved to the + # next line without hyphenation; words longer than given + # line length are cut into smaller pieces + + if { ![ string is boolean -strict $value ] } then { + error "expected boolean but got \"$value\"" + } + set StrictLength [ string is true $value ] + } + default { + error "bad option \"$option\": must be -full, -hyphenate, \ + -justify, -length, or -strictlength" + } + } + } + + return "" +} + +# ::textutil::adjust::Adjust +# +# History: +# rewritten on 2004-04-13 for bugfix tcllib-bugs-882402 (jhv) + +proc ::textutil::adjust::Adjust { varOrigName varNewName } { + variable Length + variable FullLine + variable StrictLength + variable Hyphenate + + upvar $varOrigName orig + upvar $varNewName text + + set pos 0; # Cursor after writing + set line "" + set text "" + + + if {!$FullLine} { + regsub -all -- "(\n)|(\t)" $orig " " orig + regsub -all -- " +" $orig " " orig + regsub -all -- "(^ *)|( *\$)" $orig "" orig + } + + set words [split $orig] + set numWords [llength $words] + set numline 0 + + for {set cnt 0} {$cnt < $numWords} {incr cnt} { + + set w [lindex $words $cnt] + set wLen [string length $w] + + # the word $w doesn't fit into the present line + # case #1: we try to hyphenate + + if {$Hyphenate && ($pos+$wLen >= $Length)} { + # Hyphenation instructions + set w2 [textutil::adjust::Hyphenation $w] + + set iMax [llength $w2] + if {$iMax == 1 && [string length $w] > $Length} { + # word cannot be hyphenated and exceeds linesize + + error "Word \"$w2\" can\'t be hyphenated\ + and exceeds linesize $Length!" + } else { + # hyphenating of $w was successfull, but we have to look + # that every sylable would fit into the line + + foreach x $w2 { + if {[string length $x] >= $Length} { + error "Word \"$w\" can\'t be hyphenated\ + to fit into linesize $Length!" + } + } + } + + for {set i 0; set w3 ""} {$i < $iMax} {incr i} { + set syl [lindex $w2 $i] + if {($pos+[string length " $w3$syl-"]) > $Length} {break} + append w3 $syl + } + for {set w4 ""} {$i < $iMax} {incr i} { + set syl [lindex $w2 $i] + append w4 $syl + } + + if {[string length $w3] && [string length $w4]} { + # hyphenation was successfull: redefine + # list of words w => {"$w3-" "$w4"} + + set x [lreplace $words $cnt $cnt "$w4"] + set words [linsert $x $cnt "$w3-"] + set w [lindex $words $cnt] + set wLen [string length $w] + incr numWords + } + } + + # the word $w doesn't fit into the present line + # case #2: we try to cut the word into pieces + + if {$StrictLength && ([string length $w] > $Length)} { + # cut word into two pieces + set w2 $w + + set over [expr {$pos+2+$wLen-$Length}] + + incr Length -1 + set w3 [string range $w2 0 $Length] + incr Length + set w4 [string range $w2 $Length end] + + set x [lreplace $words $cnt $cnt $w4] + set words [linsert $x $cnt $w3 ] + set w [lindex $words $cnt] + set wLen [string length $w] + incr numWords + } + + # continuing with the normal procedure + + if {($pos+$wLen < $Length)} { + # append word to current line + + if {$pos} {append line " "; incr pos} + append line $w + incr pos $wLen + } else { + # line full => write buffer and begin a new line + + if {[string length $text]} {append text "\n"} + append text [Justification $line [incr numline]] + set line $w + set pos $wLen + } + } + + # write buffer and return! + + if {[string length $text]} {append text "\n"} + append text [Justification $line end] + return $text +} + +# ::textutil::adjust::Justification +# +# justify a given line +# +# Parameters: +# line text for justification +# index index for line in text +# +# Returns: +# the justified line +# +# Remarks: +# Only lines with size not exceeding the max. linesize provided +# for text formatting are justified!!! + +proc ::textutil::adjust::Justification { line index } { + variable Justify + variable Length + variable FullLine + + set len [string length $line]; # length of current line + + if { $Length <= $len } then { + # the length of current line ($len) is equal as or greater than + # the value provided for text formatting ($Length) => to avoid + # inifinite loops we leave $line unchanged and return! + + return $line + } + + # Special case: + # for the last line, and if the justification is set to 'plain' + # the real justification is 'left' if the length of the line + # is less than 90% (rounded) of the max length allowed. This is + # to avoid expansion of this line when it is too small: without + # it, the added spaces will 'unbeautify' the result. + # + + set justify $Justify + if { ( "$index" == "end" ) && \ + ( "$Justify" == "plain" ) && \ + ( $len < round($Length * 0.90) ) } then { + set justify left + } + + # For a left justification, nothing to do, but to + # add some spaces at the end of the line if requested + + if { "$justify" == "left" } then { + set jus "" + if { $FullLine } then { + set jus [strRepeat " " [ expr { $Length - $len } ]] + } + return "${line}${jus}" + } + + # For a right justification, just add enough spaces + # at the beginning of the line + + if { "$justify" == "right" } then { + set jus [strRepeat " " [ expr { $Length - $len } ]] + return "${jus}${line}" + } + + # For a center justification, add half of the needed spaces + # at the beginning of the line, and the rest at the end + # only if needed. + + if { "$justify" == "center" } then { + set mr [ expr { ( $Length - $len ) / 2 } ] + set ml [ expr { $Length - $len - $mr } ] + set jusl [strRepeat " " $ml] + set jusr [strRepeat " " $mr] + if { $FullLine } then { + return "${jusl}${line}${jusr}" + } else { + return "${jusl}${line}" + } + } + + # For a plain justification, it's a little bit complex: + # + # if some spaces are missing, then + # + # 1) sort the list of words in the current line by decreasing size + # 2) foreach word, add one space before it, except if it's the + # first word, until enough spaces are added + # 3) rebuild the line + + if { "$justify" == "plain" } then { + set miss [ expr { $Length - [ string length $line ] } ] + + # Bugfix tcllib-bugs-860753 (jhv) + + set words [split $line] + set numWords [llength $words] + + if {$numWords < 2} { + # current line consists of less than two words - we can't + # insert blanks to achieve a plain justification => leave + # $line unchanged and return! + + return $line + } + + for {set i 0; set totalLen 0} {$i < $numWords} {incr i} { + set w($i) [lindex $words $i] + if {$i > 0} {set w($i) " $w($i)"} + set wLen($i) [string length $w($i)] + set totalLen [expr {$totalLen+$wLen($i)}] + } + + set miss [expr {$Length - $totalLen}] + + # len walks through all lengths of words of the line under + # consideration + + for {set len 1} {$miss > 0} {incr len} { + for {set i 1} {($i < $numWords) && ($miss > 0)} {incr i} { + if {$wLen($i) == $len} { + set w($i) " $w($i)" + incr wLen($i) + incr miss -1 + } + } + } + + set line "" + for {set i 0} {$i < $numWords} {incr i} { + set line "$line$w($i)" + } + + # End of bugfix + + return "${line}" + } + + error "Illegal justification key \"$justify\"" +} + +proc ::textutil::adjust::SortList { list dir index } { + + if { [ catch { lsort -integer -$dir -index $index $list } sl ] != 0 } then { + error "$sl" + } + + return $sl +} + +# Hyphenation utilities based on Knuth's algorithm +# +# Copyright (C) 2001-2003 by Dr.Johannes-Heinrich Vogeler (jhv) +# These procedures may be used as part of the tcllib + +# textutil::adjust::Hyphenation +# +# Hyphenate a string using Knuth's algorithm +# +# Parameters: +# str string to be hyphenated +# +# Returns: +# the hyphenated string + +proc ::textutil::adjust::Hyphenation { str } { + + # if there are manual set hyphenation marks e.g. "Recht\-schrei\-bung" + # use these for hyphenation and return + + if {[regexp {[^\\-]*[\\-][.]*} $str]} { + regsub -all {(\\)(-)} $str {-} tmp + return [split $tmp -] + } + + # Don't hyphenate very short words! Minimum length for hyphenation + # is set to 3 characters! + + if { [string length $str] < 4 } then { return $str } + + # otherwise follow Knuth's algorithm + + variable HyphPatterns; # hyphenation patterns (TeX) + + set w ".[string tolower $str]."; # transform to lower case + set wLen [string length $w]; # and add delimiters + + # Initialize hyphenation weights + + set s {} + for {set i 0} {$i < $wLen} {incr i} { + lappend s 0 + } + + for {set i 0} {$i < $wLen} {incr i} { + set kmax [expr {$wLen-$i}] + for {set k 1} {$k < $kmax} {incr k} { + set sw [string range $w $i [expr {$i+$k}]] + if {[info exists HyphPatterns($sw)]} { + set hw $HyphPatterns($sw) + set hwLen [string length $hw] + for {set l1 0; set l2 0} {$l1 < $hwLen} {incr l1} { + set c [string index $hw $l1] + if {[string is digit $c]} { + set sPos [expr {$i+$l2}] + if {$c > [lindex $s $sPos]} { + set s [lreplace $s $sPos $sPos $c] + } + } else { + incr l2 + } + } + } + } + } + + # Replace all even hyphenation weigths by zero + + for {set i 0} {$i < [llength $s]} {incr i} { + set c [lindex $s $i] + if {!($c%2)} { set s [lreplace $s $i $i 0] } + } + + # Don't start with a hyphen! Take also care of words enclosed in quotes + # or that someone has forgotten to put a blank between a punctuation + # character and the following word etc. + + for {set i 1} {$i < ($wLen-1)} {incr i} { + set c [string range $w $i end] + if {[regexp {^[:alpha:][.]*} $c]} { + for {set k 1} {$k < ($i+1)} {incr k} { + set s [lreplace $s $k $k 0] + } + break + } + } + + # Don't separate the last character of a word with a hyphen + + set max [expr {[llength $s]-2}] + if {$max} {set s [lreplace $s $max end 0]} + + # return the syllabels of the hyphenated word as a list! + + set ret "" + set w ".$str." + for {set i 1} {$i < ($wLen-1)} {incr i} { + if {[lindex $s $i]} { append ret - } + append ret [string index $w $i] + } + return [split $ret -] +} + +# textutil::adjust::listPredefined +# +# Return the names of the hyphenation files coming with the package. +# +# Parameters: +# None. +# +# Result: +# List of filenames (without directory) + +proc ::textutil::adjust::listPredefined {} { + variable here + return [glob -type f -directory $here -tails *.tex] +} + +# textutil::adjust::getPredefined +# +# Retrieve the full path for a predefined hyphenation file +# coming with the package. +# +# Parameters: +# name Name of the predefined file. +# +# Results: +# Full path to the file, or an error if it doesn't +# exist or is matching the pattern *.tex. + +proc ::textutil::adjust::getPredefined {name} { + variable here + + if {![string match *.tex $name]} { + return -code error \ + "Illegal hyphenation file \"$name\"" + } + set path [file join $here $name] + if {![file exists $path]} { + return -code error \ + "Unknown hyphenation file \"$path\"" + } + return $path +} + +# textutil::adjust::readPatterns +# +# Read hyphenation patterns from a file and store them in an array +# +# Parameters: +# filNam name of the file containing the patterns + +proc ::textutil::adjust::readPatterns { filNam } { + + variable HyphPatterns; # hyphenation patterns (TeX) + + # HyphPatterns(_LOADED_) is used as flag for having loaded + # hyphenation patterns from the respective file (TeX format) + + if {[info exists HyphPatterns(_LOADED_)]} { + unset HyphPatterns(_LOADED_) + } + + # the array xlat provides translation from TeX encoded characters + # to those of the ISO-8859-1 character set + + set xlat(\"s) \337; # 223 := sharp s " + set xlat(\`a) \340; # 224 := a, grave + set xlat(\'a) \341; # 225 := a, acute + set xlat(\^a) \342; # 226 := a, circumflex + set xlat(\"a) \344; # 228 := a, diaeresis " + set xlat(\`e) \350; # 232 := e, grave + set xlat(\'e) \351; # 233 := e, acute + set xlat(\^e) \352; # 234 := e, circumflex + set xlat(\`i) \354; # 236 := i, grave + set xlat(\'i) \355; # 237 := i, acute + set xlat(\^i) \356; # 238 := i, circumflex + set xlat(\~n) \361; # 241 := n, tilde + set xlat(\`o) \362; # 242 := o, grave + set xlat(\'o) \363; # 243 := o, acute + set xlat(\^o) \364; # 244 := o, circumflex + set xlat(\"o) \366; # 246 := o, diaeresis " + set xlat(\`u) \371; # 249 := u, grave + set xlat(\'u) \372; # 250 := u, acute + set xlat(\^u) \373; # 251 := u, circumflex + set xlat(\"u) \374; # 252 := u, diaeresis " + + set fd [open $filNam RDONLY] + set status 0 + + while {[gets $fd line] >= 0} { + + switch -exact $status { + PATTERNS { + if {[regexp {^\}[.]*} $line]} { + # End of patterns encountered: set status + # and ignore that line + set status 0 + continue + } else { + # This seems to be pattern definition line; to process it + # we have first to do some editing + # + # 1) eat comments in a pattern definition line + # 2) eat braces and coded linefeeds + + set z [string first "%" $line] + if {$z > 0} { set line [string range $line 0 [expr {$z-1}]] } + + regsub -all {(\\n|\{|\})} $line {} tmp + set line $tmp + + # Now $line should consist only of hyphenation patterns + # separated by white space + + # Translate TeX encoded characters to ISO-8859-1 characters + # using the array xlat defined above + + foreach x [array names xlat] { + regsub -all {$x} $line $xlat($x) tmp + set line $tmp + } + + # split the line and create a lookup array for + # the repective hyphenation patterns + + foreach item [split $line] { + if {[string length $item]} { + if {![string match {\\} $item]} { + # create index for hyphenation patterns + + set var $item + regsub -all {[0-9]} $var {} idx + # store hyphenation patterns as elements of an array + + set HyphPatterns($idx) $item + } + } + } + } + } + EXCEPTIONS { + if {[regexp {^\}[.]*} $line]} { + # End of patterns encountered: set status + # and ignore that line + set status 0 + continue + } else { + # to be done in the future + } + } + default { + if {[regexp {^\\endinput[.]*} $line]} { + # end of data encountered, stop processing and + # ignore all the following text .. + break + } elseif {[regexp {^\\patterns[.]*} $line]} { + # begin of patterns encountered: set status + # and ignore that line + set status PATTERNS + continue + } elseif {[regexp {^\\hyphenation[.]*} $line]} { + # some particular cases to be treated separately + set status EXCEPTIONS + continue + } else { + set status 0 + } + } + } + } + + close $fd + set HyphPatterns(_LOADED_) 1 + + return +} + +####################################################### + +# @c The specified block is indented +# @c by ing each line. The first +# @c lines ares skipped. +# +# @a text: The paragraph to indent. +# @a prefix: The string to use as prefix for each line +# @a prefix: of with. +# @a skip: The number of lines at the beginning to leave untouched. +# +# @r Basically , but indented a certain amount. +# +# @i indent +# @n This procedure is not checked by the testsuite. + +proc ::textutil::adjust::indent {text prefix {skip 0}} { + set text [string trimright $text] + + set res [list] + foreach line [split $text \n] { + if {[string compare "" [string trim $line]] == 0} { + lappend res {} + } else { + set line [string trimright $line] + if {$skip <= 0} { + lappend res $prefix$line + } else { + lappend res $line + } + } + if {$skip > 0} {incr skip -1} + } + return [join $res \n] +} + +# Undent the block of text: Compute LCP (restricted to whitespace!) +# and remove that from each line. Note that this preverses the +# shaping of the paragraph (i.e. hanging indent are _not_ flattened) +# We ignore empty lines !! + +proc ::textutil::adjust::undent {text} { + + if {$text == {}} {return {}} + + set lines [split $text \n] + set ne [list] + foreach l $lines { + if {[string length [string trim $l]] == 0} continue + lappend ne $l + } + set lcp [::textutil::string::longestCommonPrefixList $ne] + + if {[string length $lcp] == 0} {return $text} + + regexp "^(\[\t \]*)" $lcp -> lcp + + if {[string length $lcp] == 0} {return $text} + + set len [string length $lcp] + + set res [list] + foreach l $lines { + if {[string length [string trim $l]] == 0} { + lappend res {} + } else { + lappend res [string range $l $len end] + } + } + return [join $res \n] +} + +# ### ### ### ######### ######### ######### +## Data structures + +namespace eval ::textutil::adjust { + variable here [file dirname [info script]] + + variable Justify left + variable Length 72 + variable FullLine 0 + variable StrictLength 0 + variable Hyphenate 0 + variable HyphPatterns + + namespace export adjust indent undent +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide textutil::adjust 0.7.3 diff --git a/src/vendormodules/textutil/dehypht.tex b/src/vendormodules/textutil/dehypht.tex new file mode 100644 index 00000000..8f1dfb04 --- /dev/null +++ b/src/vendormodules/textutil/dehypht.tex @@ -0,0 +1,902 @@ +% This is `dehypht.tex' as of 03 March 1999. +% +% Copyright (C) 1988,1991 Rechenzentrum der Ruhr-Universitaet Bochum +% [german hyphen patterns] +% Copyright (C) 1993,1994,1999 Bernd Raichle/DANTE e.V. +% [macros, adaption for TeX 2] +% +% ----------------------------------------------------------------- +% IMPORTANT NOTICE: +% +% This program can be redistributed and/or modified under the terms +% of the LaTeX Project Public License Distributed from CTAN +% archives in directory macros/latex/base/lppl.txt; either +% version 1 of the License, or any later version. +% ----------------------------------------------------------------- +% +% +% This file contains german hyphen patterns following traditional +% hyphenation rules and includes umlauts and sharp s, but without +% `c-k' and triple consonants. It is based on hyphen patterns +% containing 5719 german hyphen patterns with umlauts in the +% recommended version of September 27, 1990. +% +% For use with TeX generated by +% +% Norbert Schwarz +% Rechenzentrum Ruhr-Universitaet Bochum +% Universitaetsstrasse 150 +% D-44721 Bochum, FRG +% +% +% Adaption of these patterns for TeX, Version 2.x and 3.x and +% all fonts in T1/`Cork'/EC/DC and/or OT1/CM encoding by +% +% Bernd Raichle +% Stettener Str. 73 +% D-73732 Esslingen, FRG +% Email: raichle@Informatik.Uni-Stuttgart.DE +% +% +% Error reports in case of UNCHANGED versions to +% +% DANTE e.V., Koordinator `german.sty' +% Postfach 10 18 40 +% D-69008 Heidelberg, FRG +% Email: german@Dante.DE +% +% or one of the addresses given above. +% +% +% Changes: +% 1990-09-27 First version of `ghyphen3.tex' (Norbert Schwarz) +% 1991-02-13 PC umlauts changed to ^^xx (Norbert Schwarz) +% 1993-08-27 Umlauts/\ss changed to "a/\3 macros, added macro +% definitions and additional logic to select correct +% patterns/encoding (Bernd Raichle) +% 1994-02-13 Release of `ghyph31.tex' V3.1a (Bernd Raichle) +% 1999-03-03 Renamed file to `dehypht.tex' according to the +% naming scheme using the ISO country code `de', the +% common part `hyph' for all hyphenation patterns files, +% and the additional postfix `t' for traditional, +% removed wrong catcode change of ^^e (the comment +% character %) and ^^f (the character &), +% do _not_ change \catcode, \lccode, \uccode to avoid +% problems with other hyphenation pattern files, +% changed code to distinguish TeX 2.x/3.x, +% changed license conditions to LPPL (Bernd Raichle) +% +% +% For more information see the additional documentation +% at the end of this file. +% +% ----------------------------------------------------------------- +% +\message{German Traditional Hyphenation Patterns % + `dehypht' Version 3.2a <1999/03/03>} +\message{(Formerly known under the name `ghyph31' and `ghyphen'.)} +% +% +% Next we define some commands which are used inside the patterns. +% To keep them local, we enclose the rest of the file in a group +% (The \patterns command globally changes the hyphenation trie!). +% +\begingroup +% +% +% Make sure that doublequote is not active: +\catcode`\"=12 +% +% +% Because ^^e4 is used in the following macros which is read by +% TeX 2.x as ^^e or %, the comment character of TeX, some trick +% has to be found to avoid this problem. The same is true for the +% character ^^f or & in the TeX 2.x code. +% Therefore in the code the exclamationmark ! is used instead of +% the circumflex ^ and its \catcode is set appropriately +% (normally \catcode`\!=12, in the code \catcode`\!=7). +% +% The following \catcode, \lccode assignments and macro definitions +% are defined in such a way that the following \pattern{...} list +% can be used for both, TeX 2.x and TeX 3.x. +% +% We first change the \lccode of ^^Y to make sure that we can +% include this character in the hyphenation patterns. +% +\catcode`\^^Y=11 \lccode`\^^Y=`\^^Y +% +% Then we have to define some macros depending on the TeX version. +% Therefore we have to distinguish TeX version 2.x and 3.x: +% +\ifnum`\@=`\^^40 % true => TeX 3.x + % + % For TeX 3: + % ---------- + % + % Assign appropriate \catcode and \lccode values for all + % accented characters used in the patterns (\uccode changes are + % not used within \patterns{...} and thus not necessary): + % + \catcode"E4=11 \catcode"C4=11 % \"a \"A + \catcode"F6=11 \catcode"D6=11 % \"o \"O + \catcode"FC=11 \catcode"DC=11 % \"u \"U + \catcode"FF=11 \catcode"DF=11 % \ss SS + % + \lccode"C4="E4 \uccode"C4="C4 \lccode"E4="E4 \uccode"E4="C4 + \lccode"D6="F6 \uccode"D6="D6 \lccode"F6="F6 \uccode"F6="D6 + \lccode"DC="FC \uccode"DC="DC \lccode"FC="FC \uccode"FC="DC + \lccode"DF="FF \uccode"DF="DF \lccode"FF="FF \uccode"FF="DF + % + % In the following definitions we use ??xy instead of ^^xy + % to avoid errors when reading the following macro definitions + % with TeX 2.x (remember ^^e(4) is the comment character): + % + \catcode`\?=7 + % + % Define the accent macro " in such a way that it + % expands to single letters in font encoding T1. + \catcode`\"=13 + \def"#1{\ifx#1a??e4\else \ifx#1o??f6\else \ifx#1u??fc\else + \errmessage{Hyphenation pattern file corrupted!}% + \fi\fi\fi} + % + % - patterns with umlauts are ok + \def\n#1{#1} + % + % For \ss which exists in T1 _and_ OT1 encoded fonts but with + % different glyph codes, duplicated patterns for both encodings + % are included. Thus you can use these hyphenation patterns for + % T1 and OT1 encoded fonts: + % - define \3 to be code `\^^ff (\ss in font encoding T1) + % - define \9 to be code `\^^Y (\ss in font encoding OT1) + \def\3{??ff} + \def\9{??Y} + % - duplicated patterns to support font encoding OT1 are ok + \def\c#1{#1} + % >>>>>> UNCOMMENT the next line, if you do not want + % >>>>>> to use fonts in font encoding OT1 + %\def\c#1{} + % + \catcode`\?=12 + % +\else + % + % For TeX 2: + % ---------- + % + % Define the accent macro " to throw an error message. + \catcode`\"=13 + \def"#1{\errmessage{Hyphenation pattern file corrupted!}} + % + % - ignore all patterns with umlauts + \def\n#1{} + % + % With TeX 2 fonts in encoding T1 can be used, but all glyphs + % in positions > 127 can not be used in hyphenation patterns. + % Thus only patterns with glyphs in OT1 positions are included: + % - define \3 to be code ^^Y (\ss in CM font encoding) + % - define \9 to throw an error message + \def\3{^^Y} + \def\9{\errmessage{Hyphenation pattern file corrupted!}} + % - ignore all duplicated patterns with \ss in T1 encoding + \def\c#1{} + % +\fi +% +% +\patterns{% +.aa6l .ab3a4s .ab3ei .abi2 .ab3it .ab1l .ab1r .ab3u .ad3o4r .alti6 +.ana3c .an5alg .an1e .ang8s .an1s .ap1p .ar6sc .ar6ta .ar6tei .as2z +.au2f1 .au2s3 .be5erb .be3na .ber6t5r .bie6r5 .bim6s5t .brot3 .bru6s +.ch6 .che6f5 .da8c .da2r .dar5in .dar5u .den6ka .de5r6en .des6pe +.de8spo .de3sz .dia3s4 .dien4 .dy2s1 .ehren5 .eine6 .ei6n5eh .ei8nen +.ein5sa .en6der .en6d5r .en3k4 .en8ta8 .en8tei .en4t3r .epo1 .er6ban +.er6b5ei .er6bla .er6d5um .er3ei .er5er .er3in .er3o4b .erwi5s .es1p +.es8t .ex1a2 .ex3em .fal6sc .fe6st5a .flu4g3 .furch8 .ga6ner .ge3n4a +\n{.ge5r"o} .ges6 .halb5 .halbe6 .hal6br .haup4 .hau4t .heima6 .he4r3e +.her6za .he5x .hin3 .hir8sc .ho4c .hu3sa .hy5o .ibe5 .ima6ge .in1 +.ini6 .is5chi .jagd5 .kal6k5o .ka6ph .ki4e .kop6f3 .kraf6 \n{.k"u5ra} +.lab6br .liie6 .lo6s5k \n{.l"o4s3t} .ma5d .mi2t1 .no6th .no6top +.obe8ri .ob1l .obs2 .ob6st5e .or3c .ort6s5e .ost3a .oste8r .pe4re +.pe3ts .ph6 .po8str .rau4m3 .re5an .ro8q .ru5the \n{.r"u5be} +\n{.r"u8stet} .sch8 .se6e .se5n6h .se5ra .si2e .spi6ke .st4 .sy2n +.tages5 .tan6kl .ta8th .te6e .te8str .to6der .to8nin .to6we .um1 +.umpf4 .un1 .une6 .unge5n .ur1c .ur5en .ve6rin .vora8 .wah6l5 .we8ges +.wo6r .wor3a .wun4s .zi4e .zuch8 \n{."ande8re} \n{."och8} aa1c aa2gr +aal5e aa6r5a a5arti aa2s1t aat2s 6aba ab3art 1abdr 6abel aben6dr +ab5erk ab5err ab5esse 1abf 1abg \n{1abh"a} ab1ir 1abko a1bl ab1la +5ablag a6bla\3 \c{a6bla\9} ab4ler ab1lu \n{a8bl"a} \n{5a6bl"o} abma5c +1abn ab1ra ab1re 5a6brec ab1ro ab1s ab8sk abs2z 3abtei ab1ur 1abw +5abze 5abzu \n{ab1"an} \n{ab"au8} a4ce. a5chal ach5art ach5au a1che +a8chent ach6er. a6ch5erf a1chi ach1l ach3m ach5n a1cho ach3re a1chu +ach1w a1chy \n{ach5"af} ack1o acks6t ack5sta a1d 8ad. a6d5ac ad3ant +ad8ar 5addi a8dein ade5o8 adi5en 1adj 1adle ad1op a2dre 3adres adt1 +1adv \n{a6d"a} a1e2d ae1r a1er. 1aero 8afa a3fal af1an a5far a5fat +af1au a6fentl a2f1ex af1fr af5rau af1re 1afri af6tent af6tra aft5re +a6f5um \n{8af"a} ag5abe 5a4gent ag8er ages5e 1aggr ag5las ag1lo a1gn +ag2ne 1agog a6g5und a1ha a1he ah5ein a4h3erh a1hi ahl1a ah1le ah4m3ar +ahn1a a5ho ahra6 ahr5ab ah1re ah8rei ahren8s ahre4s3 ahr8ti ah1ru a1hu +\n{ah8"o} ai3d2s ai1e aif6 a3inse ai4re. a5isch. ais8e a3ismu ais6n +aiso6 a1j 1akad a4kade a1ke a1ki 1akko 5akro1 a5lal al5ans 3al8arm +al8beb al8berw alb5la 3album al1c a1le a6l5e6be a4l3ein a8lel a8lerb +a8lerh a6lert 5a6l5eth 1algi al4gli al3int al4lab al8lan al4l3ar +alle3g a1lo a4l5ob al6schm al4the altist5 al4t3re 8a1lu alu5i a6lur +alu3ta \n{a1l"a} a6mate 8ame. 5a6meise am6m5ei am6mum am2n ampf3a +am6schw am2ta a1mu \n{a1m"a} a3nac a1nad anadi5e an3ako an3alp 3analy +an3ame an3ara a1nas an5asti a1nat anat5s an8dent ande4s3 an1ec an5eis +an1e2k 4aner. a6n5erd a8nerf a6n5erke 1anfa 5anfert \n{1anf"a} 3angab +5angebo an3gli ang6lis an2gn 3angri ang5t6 \n{5anh"a} ani5g ani4ka +an5i8on an1kl an6kno an4kro 1anl anma5c anmar4 3annah anne4s3 a1no +5a6n1o2d 5a6n3oma 5a6nord 1anr an1sa 5anschl an4soz an1st 5anstal +an1s2z 5antenn an1th \n{5anw"a} a5ny an4z3ed 5anzeig 5anzieh 3anzug +\n{an1"a} \n{5an"as} \n{a1n"o} \n{an"o8d} a1os a1pa 3apfel a2ph1t +\n{aph5"a6} a1pi 8apl apo1c apo1s a6poste a6poth 1appa ap1pr a1pr +\n{a5p"a} \n{a3p"u} a1ra a4r3af ar3all 3arbei 2arbt ar1c 2a1re ar3ein +ar2gl 2a1ri ari5es ar8kers ar6les ar4nan ar5o6ch ar1o2d a1rol ar3ony +a8ror a3ros ar5ox ar6schl 8artei ar6t5ri a1ru a1ry 1arzt arz1w +\n{ar8z"a} \n{ar"a8m} \n{ar"o6} \n{ar5"om} \n{ar1"u2} a1sa a6schec +asch5l asch3m a6schn a3s4hi as1pa asp5l a8steb as5tev 1asth a6stoc +a1str ast3re 8a1ta ata5c ata3la a6tapf ata5pl a1te a6teli aten5a +ate5ran 6atf 6atg a1th at3hal 1athl 2a1ti 5atlant 3atlas 8atmus 6atn +a1to a6t5ops ato6ra a6t5ort. 4a1tr a6t5ru at2t1h \n{at5t6h"a} 6a1tu +atz1w \n{a1t"a} \n{a1t"u} au1a au6bre auch3a au1e aue4l 5aufent +\n{3auff"u} 3aufga 1aufn auf1t 3auftr 1aufw 3auge. au4kle aule8s 6aum +au8mar aum5p 1ausb 3ausd 1ausf 1ausg au8sin 3auss au4sta 1ausw 1ausz +aut5eng au1th 1auto au\3e8 \c{au\9e8} a1v ave5r6a aver6i a1w a6wes a1x +a2xia a6xio a1ya a1z azi5er. 8a\3 \c{8a\9} 1ba 8ba8del ba1la ba1na +ban6k5r ba5ot bardi6n ba1ro basten6 bau3sp 2b1b bb6le b2bli 2b1c 2b1d +1be be1a be8at. be1ch 8becht 8becke. be5el be1en bee8rei be5eta bef2 +8beff be1g2 \n{beh"o8} bei1s 6b5eisen bei3tr b8el bel8o belu3t be3nac +bend6o be6ners be6nerw be4nor ben4se6 bens5el \n{be1n"a} \n{be1n"u} +be1o2 b8er. be1ra be8rac ber8gab. ber1r \n{be1r"u} bes8c bes5erh +bes2p be5tha bet5sc be1un be1ur 8bex be6zwec 2b1f8 bfe6st5e 2b1g2 +bga2s5 bge1 2b1h bhole6 1bi bi1bl b6ie bi1el bi1la \n{bil"a5} bi1na +bi4nok bi5str bi6stu bi5tr bit4t5r b1j 2b1k2 \n{bk"u6} bl8 b6la. +6b1lad 6blag 8blam 1blat b8latt 3blau. b6lav 3ble. b1leb b1led +8b1leg 8b1leh 8bleid 8bleih 6b3lein blei3s ble4m3o 4blich b4lind +8bling b2lio 5blit b4litz b1loh 8b1los 1blu 5blum 2blun blut3a blut5sc +\n{3bl"a} \n{bl"as5c} \n{5bl"o} \n{3bl"u} \n{bl"u8sc} 2b1m 2b1n 1bo +bo1ch bo5d6s boe5 8boff 8bonk bo1ra b1ort 2b1p2 b1q 1br brail6 brast8 +bre4a b5red 8bref 8b5riem b6riga bro1s b1rup b2ruz \n{8br"oh} +\n{br"os5c} 8bs b1sa b8sang b2s1ar b1sc bs3erl bs3erz b8sof b1s2p +bst1h b3stru \n{b5st"a} b6sun 2b1t b2t1h 1bu bu1ie bul6k b8ure bu6sin +6b1v 2b1w 1by1 by6te. 8b1z bzi1s \n{1b"a} \n{b5"a6s5} \n{1b"u} +\n{b6"u5bere} \n{b"uge6} \n{b"ugel5e} \n{b"ur6sc} 1ca cag6 ca5la ca6re +ca5y c1c 1ce celi4c celich5 ce1ro c8h 2ch. 1chae ch1ah ch3akt cha6mer +8chanz 5chara 3chari 5chato 6chb 1chef 6chei ch3eil ch3eis 6cherkl +6chf 4chh 5chiad 5chias 6chins 8chj chl6 5chlor 6ch2m 2chn6 ch8nie +5cho. 8chob choi8d 6chp ch3ren ch6res \n{ch3r"u} 2chs 2cht cht5ha +cht3hi 5chthon ch6tin 6chuh chu4la 6ch3unt chut6t 8chw 1ci ci5tr c2k +2ck. ck1ei 4ckh ck3l ck3n ck5o8f ck1r 2cks ck5stra ck6s5u c2l 1c8o +con6ne 8corb cos6t c3q 1c6r 8c1t 1cu 1cy \n{5c"a1} \n{c"o5} 1da. +8daas 2dabg 8dabr 6dabt 6dabw 1dac da2gr 6d5alk 8d5amt dan6ce. +dani5er dan8ker 2danl danla6 6dans 8danzi 6danzu d1ap da2r1a8 2d1arb +d3arc dar6men 4d3art 8darz 1dat 8datm 2d1auf 2d1aus 2d1b 2d1c 2d1d +d5de d3d2h \n{dd"amme8} 1de 2deal de5an de3cha de1e defe6 6deff 2d1ehr +5d4eic de5isc de8lar del6s5e del6spr de4mag de8mun de8nep dene6r +8denge. 8dengen de5o6d 2deol de5ram 8derdb der5ein de1ro der1r d8ers +der5um de4s3am de4s3an de4sau de6sil de4sin de8sor de4spr de2su 8deul +de5us. 2d1f df2l 2d1g 2d1h 1di dia5c di5ara dice5 di3chr di5ena di1gn +di1la dil8s di1na 8dind 6dinf 4d3inh 2d1ins di5o6d di3p4t di8sen dis1p +di5s8per di6s5to dis5tra di8tan di8tin d1j 6dje 2dju 2d1k 2d1l 2d1m +2d1n6 dni6 dnje6 1do 6d5obe do6berf 6d5ony do3ran 6dord 2d1org dor4t3h +do6ste 6doth dott8e 2d1p d5q dr4 1drah 8drak d5rand 6dre. 4drech +d6reck 4d3reg 8d3reic d5reife 8drem 8d1ren 2drer 8dres. 6d5rh 1dria +d1ric 8drind droi6 dro5x 1dru 8drut \n{dr"os5c} \n{1dr"u} \n{dr"u5b} +\n{dr"u8sc} 2ds d1sa d6san dsat6 d1sc 5d6scha. 5dschik dse8e d8serg +8dsl d1sp d4spak ds2po \n{d8sp"a} d1st \n{d1s"u} 2dt d1ta d1te d1ti +d1to dt1s6 d1tu \n{d5t"a} 1du du5als du1b6 du1e duf4t3r 4d3uh du5ie +8duml 8dumw 2d1und du8ni 6d5unt dur2c durch3 6durl 6dursa 8durt du1s +du8schr 2d1v 2d1w dwa8l 2d1z \n{1d"a} \n{6d"ah} \n{8d"and} \n{d"a6r} +\n{d"o8bl} \n{d5"ol} \n{d"or6fl} \n{d"o8sc} \n{d5"o4st} \n{d"os3te} +\n{1d"u} ea4ben e1ac e1ah e1akt e1al. e5alf e1alg e5a8lin e1alk e1all +e5alp e1alt e5alw e1am e1and ea6nim e1ar. e5arf e1ark e5arm e3art +e5at. e6ate e6a5t6l e8ats e5att e6au. e1aus e1b e6b5am ebens5e +eb4lie eb4ser eb4s3in e1che e8cherz e1chi ech3m 8ech3n ech1r ech8send +ech4su e1chu eck5an e5cl e1d ee5a ee3e ee5g e1ei ee5isc eei4s3t +ee6lend e1ell \n{ee5l"o} e1erd ee3r4e ee8reng eere6s5 \n{ee5r"a} +ee6tat e1ex e1f e6fau e8fe8b 3effek ef3rom ege6ra eglo6si 1egy e1ha +e6h5ach eh5ans e6hap eh5auf e1he e1hi ehl3a eh1le ehl5ein eh1mu ehn5ec +e1ho ehr1a eh1re ehre6n eh1ri eh1ru ehr5um e1hu eh1w e1hy \n{e1h"a} +\n{e1h"o} \n{e3h"ut} ei1a eia6s ei6bar eich3a eich5r ei4dar ei6d5ei +ei8derf ei3d4sc ei1e 8eifen 3eifri 1eign eil1d ei6mab ei8mag ein1a4 +ei8nat ei8nerh ei8ness ei6nete ein1g e8ini ein1k ei6n5od ei8nok ei4nor +\n{e3ins"a} ei1o e1irr ei5ru ei8sab ei5schn ei6s5ent ei8sol ei4t3al +eit3ar eit1h ei6thi ei8tho eit8samt ei6t5um e1j 1ekd e1ke e1ki e1k2l +e1kn ekni4 e1la e2l1al 6elan e6lanf e8lanl e6l5ans el3arb el3arm +e6l3art 5e6lasti e6lauge elbst5a e1le 6elef ele6h e6l5ehe e8leif +e6l5einh 1elek e8lel 3eleme e6lemen e6lente el5epi e4l3err e6l5ersc +elf2l elg2 e6l5ins ell8er 4e1lo e4l3ofe el8soh el8tent 5eltern e1lu +elut2 \n{e1l"a} \n{e1l"u} em8dei em8meis 4emo emo5s 1emp1f 1empt 1emto +e1mu emurk4 emurks5 \n{e1m"a} en5a6ben en5achs en5ack e1nad en5af +en5all en3alt en1am en3an. en3ant en3anz en1a6p en1ar en1a6s 6e1nat +en3auf en3aus en2ce enda6l end5erf end5erg en8dess 4ene. en5eck +e8neff e6n5ehr e6n5eim en3eis 6enem. 6enen e4nent 4ener. e8nerd +e6n3erf e4nerg 5energi e6n5erla en5ers e6nerst en5erw 6enes e6n5ess +e2nex en3glo 2eni enni6s5 ennos4 enns8 e1no e6nober eno8f en5opf +e4n3ord en8sers ens8kl en1sp ens6por en5t6ag enta5go en8terbu en6tid +3entla ent5ric 5entwic 5entwu 1entz enu5i e3ny en8zan \n{en1"of} +\n{e1n"os} \n{e1n"ug} eo1c e5o6fe e5okk e1on. e3onf e5onk e5onl e5onr +e5opf e5ops e5or. e1ord e1org eo5r6h eo1t e1pa e8pee e6p5e6g ep5ent +e1p2f e1pi 5epid e6pidem e1pl 5epos e6pos. ep4p3a e1pr \n{e1p"a} e1q +e1ra. er5aal 8eraba e5rabel er5a6ben e5rabi er3abs er3ach era5e +era5k6l er3all er3amt e3rand e3rane er3ans e5ranz. e1rap er3arc +e3rari er3a6si e1rat erat3s er3auf e3raum 3erbse er1c e1re 4e5re. +er3eck er5egg er5e2h 2erei e3rei. e8reine er5einr 6eren. e4r3enm +4erer. e6r5erm er5ero er5erst e4r3erz er3ess \n{5erf"ul} er8gan. +5ergebn er2g5h \n{5erg"anz} \n{5erh"ohu} 2e1ri eri5ak e6r5iat e4r3ind +e6r5i6n5i6 er5ins e6r5int er5itio er1kl \n{3erkl"a} \n{5erl"os.} +ermen6s er6nab 3ernst 6e1ro. e1rod er1o2f e1rog 6e3roi ero8ide e3rol +e1rom e1ron e3rop8 e2r1or e1ros e1rot er5ox ersch4 5erstat er6t5ein +er2t1h er5t6her 2e1ru eruf4s3 e4r3uhr er3ums e5rus 5erwerb e1ry er5zwa +er3zwu \n{er"a8m} \n{er5"as} \n{er"o8} \n{e3r"os.} \n{e6r1"u2b} e1sa +esa8b e8sap e6s5a6v e1sc esch4l ese1a es5ebe eserve5 e8sh es5ill +es3int es4kop e2sl eso8b e1sp espei6s5 es2po es2pu 5essenz e6stabs +e6staf e6st5ak est3ar e8stob e1str est5res es3ur e2sz \n{e1s"u} e1ta +et8ag etari5e eta8ta e1te eten6te et5hal e5thel e1ti 1etn e1to e1tr +et3rec e8tscha et8se et6tei et2th et2t1r e1tu etu1s et8zent et8zw +\n{e1t"a} \n{e1t"o} \n{e1t"u} eu1a2 eu1e eue8rei eu5fe euin5 euk2 +e1um. eu6nio e5unter eu1o6 eu5p 3europ eu1sp eu5str eu8zo e1v eval6s +eve5r6en ever4i e1w e2wig ex1or 1exp 1extr ey3er. e1z \n{e1"a2} +\n{e5"o8} \n{e1"u} e8\3es \c{e8\9es} fa6ch5i fade8 fa6del fa5el. +fal6lo falt8e fa1na fan4gr 6fanl 6fap far6ba far4bl far6r5a 2f1art +fa1sc fau8str fa3y 2f1b2 6f1c 2f1d 1fe 2f1eck fe6dr feh6lei f6eim +8feins f5eis fel5en 8feltern 8femp fe5rant 4ferd. ferri8 fe8stof +fe6str fe6stum fe8tag fet6ta fex1 2ff f1fa f6f5arm f5fe ffe5in ffe6la +ffe8ler ff1f f1fla ff3lei ff4lie ff8sa ff6s5ta 2f1g2 fgewen6 4f1h 1fi +fid4 fi3ds fieb4 fi1la fi8lei fil4m5a f8in. fi1na 8finf fi8scho fi6u +6f1j 2f1k2 f8lanz fl8e 4f3lein 8flib 4fling f2lix 6f3lon 5flop 1flor +\n{5f8l"ac} \n{3fl"ot} 2f1m 2f1n 1fo foh1 f2on fo6na 2f1op fo5ra +for8mei for8str for8th for6t5r fo5ru 6f5otte 2f1p8 f1q fr6 f5ram +1f8ran f8ra\3 \c{f8ra\9} f8re. frei1 5frei. f3reic f3rest f1rib +8f1ric 6frig 1fris fro8na \n{fr"as5t} 2fs f1sc f2s1er f5str +\n{fs3t"at} 2ft f1tak f1te ft5e6h ftere6 ft1h f1ti f5to f1tr ft5rad +ft1sc ft2so f1tu ftwi3d4 ft1z 1fu 6f5ums 6funf fun4ka fu8\3end +\c{fu8\9end} 6f1v 2f1w 2f1z \n{1f"a} \n{f"a1c} \n{8f"arm} \n{6f"aug} +\n{f"a8\3} \n{\c{f"a8\9}} \n{f"ode3} \n{8f"of} \n{3f"or} \n{1f"u} +\n{f"un4f3u} 1ga ga6bl 6gabw 8gabz g3a4der ga8ho ga5isc 4gak ga1la +6g5amt ga1na gan5erb gan6g5a ga5nj 6ganl 8gansc 6garb 2g1arc 2g1arm +ga5ro 6g3arti ga8sa ga8sc ga6stre 2g1atm 6g5auf gau5fr g5aus 2g1b g5c +6gd g1da 1ge ge1a2 ge6an ge8at. ge1e2 ge6es gef2 8geff ge1g2l ge1im +4g3eise geist5r gel8bra gelt8s \n{ge5l"o} ge8nin gen3k 6g5entf +\n{ge3n"a} ge1or ge1ra ge6rab ger8au \n{8gerh"o} ger8ins ge1ro 6g5erz. +\n{ge1r"a} \n{ge1r"u} ge1s ges2p ge5unt 4g3ex3 2g1f8 2g1g g1ha 6g1hei +5ghel. g5henn 6g1hi g1ho 1ghr \n{g1h"o} 1gi gi5la gi8me. gi1na +4g3ins gi3str g1j 2g1k 8gl. 1glad g5lag glan4z3 1glas 6glass 5glaub +g3lauf 1gle. g5leb 3gleic g3lein 5gleis 1glem 2gler 8g3leu gli8a +g2lie 3glied 1g2lik 1g2lim g6lio 1gloa 5glom 1glon 1glop g1los g4loss +g5luf 1g2ly \n{1gl"u} 2g1m gn8 6gn. 1gna 8gnach 2gnah g1nas g8neu +g2nie g3nis 1gno 8gnot 1go goe1 8gof 2gog 5gogr 6g5oh goni5e 6gonist +go1ra 8gord 2g1p2 g1q 1gr4 g5rahm gra8m gra4s3t 6g1rec gre6ge 4g3reic +g5reit 8grenn gri4e g5riem 5grif 2grig g5ring 6groh 2grot gro6\3 +\c{gro6\9} 4grut 2gs gs1ab g5sah gs1ak gs1an gs8and gs1ar gs1au g1sc +gs1ef g5seil gs5ein g2s1er gs1in g2s1o gso2r gs1pr g2s1u 2g1t g3te +g2t1h 1gu gu5as gu2e 2gue. 6gued 4g3uh 8gums 6g5unt gu1s gut3h gu2tu +4g1v 2g1w gy1n g1z \n{1g"a} \n{8g"a8m} \n{6g"arm} \n{1g"o} \n{1g"u} +\n{6g"ub} 1haa hab8r ha8del hade4n 8hae ha5el. haf6tr 2hal. ha1la +hal4b5a 6hale 8han. ha1na han6dr han6ge. 2hani h5anth 6hanz 6harb +h3arbe h3arme ha5ro ha2t1h h1atm hau6san ha8\3 \c{ha8\9} h1b2 h1c h1d +he2bl he3cho h3echt he5d6s 5heft h5e6he. hei8ds h1eif 2hein he3ism +he5ist. heit8s3 hek6ta hel8lau 8helt he6mer 1hemm 6h1emp hen5end +hen5klo hen6tri he2nu 8heo he8q her3ab he5rak her3an 4herap her3au +h3erbi he1ro he8ro8b he4r3um her6z5er he4spe he1st heta6 het5am he5th +heu3sc he1xa hey5e h1f2 h1g hgol8 h1h h1iat hie6r5i hi5kt hil1a2 +hil4fr hi5nak hin4ta hi2nu hi5ob hirn5e hir6ner hi1sp hi1th hi5tr +5hitz h1j h6jo h1k2 hlabb4 hla4ga hla6gr h5lai hl8am h1las h1la\3 +\c{h1la\9} hl1c h1led h3lein h5ler. h2lif h2lim h8linf hl5int h2lip +h2lit h4lor h3lose \n{h1l"as} hme5e h2nee h2nei hn3eig h2nel hne8n +hne4p3f hn8erz h6netz h2nip h2nit h1nol hn5sp h2nuc h2nud h2nul hoch1 +1hoh hoh8lei 2hoi ho4l3ar 1holz h2on ho1ra 6horg 5horn. ho3sl hos1p +ho4spi h1p hpi6 h1q 6hr h1rai h8rank h5raum hr1c hrcre8 h1red h3reg +h8rei. h4r3erb h8rert hrg2 h1ric hr5ins h2rom hr6t5erl hr2t1h hr6t5ra +hr8tri h6rum hr1z hs3ach h6s5amt h1sc h6s5ec h6s5erl hs8erle h4sob +h1sp h8spa\3 \c{h8spa\9} h8spel hs6po h4spun h1str h4s3tum hs3und +\n{h1s"u} h5ta. h5tab ht3ac ht1ak ht3ang h5tanz ht1ar ht1at h5taub +h1te h2t1ec ht3eff ht3ehe h4t3eif h8teim h4t3ein ht3eis h6temp h8tentf +hte8ren \n{h6terf"u} h8tergr h4t3erh h6t5ersc h8terst h8tese h8tess +h2t1eu h4t3ex ht1he ht5hu h1ti ht5rak hts3ah ht1sc ht6sex ht8sk ht8so +h1tu htz8 \n{h5t"um} hub5l hu6b5r huh1l h5uhr. huld5a6 hu8lent +\n{hu8l"a} h5up. h1v h5weib h3weis h1z \n{h"a8kl} \n{h"al8s} +\n{h"ama8tu8} \n{h"a8sche.} \n{h"at1s} \n{h"au4s3c} \n{2h"o.} +\n{2h"oe} \n{8h"oi} \n{h"o6s} \n{h"os5c} \n{h"uhne6} \n{h"ul4s3t} +\n{h"utte8re} i5adn i1af i5ak. i1al. i1al1a i1alb i1ald i5alei i1alf +i1alg i3alh i1alk i1all i1alp i1alr i1als i1alt i1alv i5alw i3alz +i1an. ia5na i3and ian8e ia8ne8b i1ang i3ank i5ann i1ant i1anz i6apo +i1ar. ia6rab i5arr i1as. i1asm i1ass i5ast. i1at. i5ats i1au i5azz +i6b5eig i6b5eis ib2le i4blis i6brig i6b5unt \n{i6b"ub} i1che ich5ei +i6cherb i1chi ich5ins ich1l ich3m ich1n i1cho icht5an icht3r i1chu +ich1w ick6s5te ic5l i1d id3arm 3ideal ide8na 3ideol \n{ide5r"o} i6diot +id5rec id1t ie1a ie6b5ar iebe4s3 ie2bl ieb1r ie8bra ie4bre \n{ie8b"a} +ie2dr ie1e8 ie6f5ad ief5f ie2f1l ie4fro ief1t i1ei ie4l3ec ie8lei +ie4lek i3ell i1en. i1end ien6e i3enf i5enn ien6ne. i1enp i1enr +i5ensa ien8stal i5env i1enz ie5o ier3a4b ie4rap i2ere ie4rec ie6r5ein +ie6r5eis ier8er i3ern. ie8rum ie8rund ie6s5che ie6tau ie8tert ie5the +ie6t5ri i1ett ie5un iex5 2if i1fa if5ang i6fau if1fr if5lac i5f6lie +i1fre ift5a if6t5r ig3art 2ige i8gess ig5he i5gla ig2ni i5go ig3rot +ig3s2p i1ha i8ham i8hans i1he i1hi ih1n ih1r i1hu i8hum ih1w 8i1i ii2s +ii2t i1j i1k i6kak i8kerz i6kes ik4ler i6k5unt 2il i5lac i1lag il3ans +i5las i1lau il6auf i1le ile8h i8lel il2fl il3ipp il6l5enn i1lo ilt8e +i1lu \n{i1l"a} i8mart imb2 i8mele i8mid imme6l5a i1mu \n{i1m"a} +\n{i5m"o} ina5he i1nat in1au inau8s 8ind. in4d3an 5index ind2r 3indus +i5nec i2n1ei i8nerw 3infek 1info 5ingeni ing5s6o 5inhab ini5er. 5inj +\n{in8k"at} in8nan i1no inoi8d in3o4ku in5sau in1sp 5inspe 5instit +5instru ins4ze 5intere 5interv in3the in5t2r i5ny \n{in"a2} \n{i1n"ar} +\n{in1"as} \n{in"o8} \n{in5"od} \n{i1n"os} 2io io1a8 io1c iode4 io2di +ioi8 i1ol. i1om. i1on. i5onb ion2s1 i1ont i5ops i5o8pt i1or. +i3oral io3rat i5orc i1os. i1ot. i1o8x 2ip i1pa i1pi i1p2l i1pr i1q +i1ra ir6bl i1re i1ri ir8me8d ir2m1o2 ir8nak i1ro ir5rho ir6schl +ir6sch5r i5rus i5ry \n{i5r"a} i1sa i8samt i6sar i2s1au i8scheh i8schei +isch5m isch3r \n{isch"a8} is8ele ise3ra i4s3erh is3err isi6de i8sind +is4kop ison5e is6por i8s5tum i5sty \n{i5s"o} i1ta it5ab. i2t1a2m +i8tax i1te i8tersc i1thi i1tho i5thr \n{it8h"a} i1ti i8ti8d iti6kl +itmen4 i1to i8tof it3ran it3rau i1tri itri5o it1sc it2se it5spa it8tru +i1tu it6z5erg it6z1w \n{i1t"a} \n{it"a6r5e} \n{it"at2} \n{it"ats5} +\n{i1t"u} i1u iu6r 2i1v i6vad iva8tin i8vei i6v5ene i8verh i2vob i8vur +i1w iwi2 i5xa i1xe i1z ize8n i8zir i6z5w \n{i"a8m} \n{i1"a6r} +\n{i5"at.} \n{i5"av} \n{i1"o8} \n{i"u8} i6\35ers \c{i6\95ers} ja5la +je2t3r 6jm 5jo jo5as jo1ra jou6l ju5cha jugen4 jugend5 jung5s6 ju1s +\n{3j"a} 1ka 8kachs 8kakz ka1la kal5d kam5t ka1na 2kanl 8kapf ka6pl +ka5r6a 6k3arbe ka1ro kar6p5f 4k3arti 8karz \n{ka1r"a} kasi5e ka6teb +kat8ta kauf6s kau3t2 2k1b 2k1c 4k1d kehr6s kehrs5a 8keic 2k1eig 6k5ein +6k5eis ke6lar ke8leis ke8lo 8kemp k5ente. k3entf 8k5ents 6kentz ke1ra +k5erlau 2k1f8 2k1g 2k1h ki5fl 8kik king6s5 6kinh ki5os ki5sp ki5th +\n{8ki8"o} 2k1k2 kl8 1kla 8klac k5lager kle4br k3leib 3kleid kle5isc +4k3leit k3lek 6k5ler. 5klet 2klic 8klig k2lim k2lin 5klip 5klop k3lor +\n{1kl"a} 2k1m kmani5e kn8 6kner k2ni \n{kn"a8} 1k2o ko1a2 ko6de. +ko1i koi8t ko6min ko1op ko1or ko6pht ko3ra kor6d5er ko5ru ko5t6sc k3ou +3kow 6k5ox 2k1p2 k1q 1kr8 4k3rad 2k1rec 4k3reic kre5ie 2krib 6krig +2krip 6kroba 2ks k1sa k6sab ksal8s k8samt k6san k1sc k2s1ex k5spat +k5spe k8spil ks6por k1spr kst8 k2s1uf 2k1t kta8l kt5a6re k8tein kte8re +k2t1h k8tinf kt3rec kt1s 1ku ku1ch kuck8 k3uhr ku5ie kum2s1 kunfts5 +kun2s kunst3 ku8rau ku4ro kurz1 ku1st 4kusti ku1ta ku8\3 \c{ku8\9} +6k1v 2k1w ky5n 2k1z \n{1k"a} \n{k"a4m} \n{4k3"ami} \n{k"ase5} \n{1k"o} +\n{k"o1c} \n{k"o1s} \n{1k"u} \n{k"u1c} \n{k"ur6sc} \n{k"u1s} 1la. +8labf 8labh lab2r 2l1abs lach3r la8dr 5ladu 8ladv 6laff laf5t la2gn +5laken 8lamb la6mer 5lampe. 2l1amt la1na 1land lan4d3a lan4d3r lan4gr +8lanme 6lann 8lanw \n{6lan"a} 8lappa lap8pl lap6pr l8ar. la5ra lar4af +la8rag la8ran la6r5a6s l3arbe la8rei 6larm. la8sa la1sc la8sta lat8i +6l5atm 4lauss 4lauto 1law 2lb l8bab l8bauf l8bede l4b3ins l5blo +lbst5an lbst3e 8lc l1che l8chert l1chi lch3m l5cho lch5w 6ld l4d3ei +ld1re \n{l6d"ub} le2bl le8bre lecht6s5 led2r 6leff le4gas 1lehr lei6br +le8inf 8leinn 5leistu 4lektr le6l5ers lemo2 8lemp l8en. 8lends +6lendun le8nend len8erw 6l5ents 4l3entw 4lentz 8lenzy 8leoz 6lepi +le6pip 8lepo 1ler l6er. 8lerbs 6l5erde le8reis le8rend le4r3er 4l3erg +l8ergr 6lerkl 6l5erzie \n{8ler"o} 8lesel lesi5e le3sko le3tha let1s +5leuc 4leuro leu4s3t le5xe 6lexp l1f 2l1g lgend8 l8gh lglie3 lglied6 +6l1h 1li li1ar li1as 2lick li8dr li1en lien6n li8ers li8ert 2lie\3 +\c{2lie\9} 3lig li8ga8b li1g6n li1l8a 8limb li1na 4l3indu lings5 +4l3inh 6linj link4s3 4linkt 2lint 8linv lion5s6t 4lipp 5lipt 4lisam +livi5e 6l1j 6l1k l8keim l8kj lk2l lko8f lkor8 lk2sa lk2se 6ll l1la +ll3a4be l8labt ll8anl ll1b ll1c ll1d6 l1le l4l3eim l6l5eise ller3a +l4leti l5lip l1lo ll3ort ll5ov ll6spr llte8 l1lu ll3urg \n{l1l"a} +\n{l5l"u} \n{l6l"ub} 2l1m l6m5o6d 6ln l1na l1no 8lobl lo6br 3loch. +l5o4fen 5loge. 5lohn 4l3ohr 1lok l2on 4l3o4per lo1ra 2l1ord 6lorg +4lort lo1ru 1los. lo8sei 3losig lo6ve lowi5 6l1p lp2f l8pho l8pn +lp4s3te l2pt l1q 8l1r 2ls l1sa l6sarm l1sc l8sec l6s5erg l4s3ers l8sh +l5s6la l1sp ls4por ls2pu l1str l8suni \n{l1s"u} 2l1t lt5amp l4t3ein +l5ten l6t5eng l6t5erp l4t3hei lt3her l2t1ho l6t5i6b lti1l \n{l8tr"o} +lt1sc lt6ser lt4s3o lt5ums lu8br lu2dr lu1en8 8lu8fe luft3a luf8tr +lu6g5r 2luh l1uhr lu5it 5luk 2l1umf 2l1umw 1lun 6l5u6nio 4l3unte lu5ol +4lurg 6lurs l3urt lu4sto lu3str lu6st5re lu8su lu6tal lu6t5e6g lu8terg +lu3the lu6t5or lu2t1r lu6\35 \c{lu6\95} l1v lve5r6u 2l1w 1ly lya6 +6lymp ly1no l8zess l8zo8f l3zwei lz5wu \n{3l"and} \n{l"a5on} +\n{l"a6sc} \n{l"at1s} \n{5l"auf} \n{2l"aug} \n{l"au6s5c} \n{l"a5v} +\n{l1"ol} \n{1l"os} \n{l"o1\36t} \n{\c{l"o1\96t}} \n{6l1"ube} 1ma +8mabg ma5chan mad2 ma5el 4magg mag8n ma1la ma8lau mal5d 8malde mali5e +malu8 ma8lut 2m1amp 3man mand2 man3ds 8mangr mani5o 8m5anst 6mappa +4m3arbe mar8kr ma1r4o mar8schm 3mas ma1sc \n{ma1t"o} 4m5auf ma5yo 2m1b +mb6r 2m1c 2m1d \n{md6s"a} 1me me1ch me5isc 5meld mel8sa 8memp me5nal +men4dr men8schl men8schw 8mentsp me1ra mer4gl me1ro 3mes me6s5ei me1th +me8\3 \c{me8\9} 2m1f6 2m1g 2m1h 1mi mi1a mi6ale mi1la 2m1imm mi1na +\n{mi5n"u} mi4s3an mit1h mi5t6ra 3mitt mitta8 mi6\35 \c{mi6\95} 6mj +2m1k8 2m1l 2m1m m6mad m6m5ak m8menth m8mentw mme6ra m2mn mm5sp mm5ums +mmut5s \n{m8m"an} m1n8 m5ni 1mo mo5ar mo4dr 8mof mo8gal mo4kla mol5d +m2on mon8do mo4n3od mont8a 6m5ony mopa6 mo1ra mor8d5a mo1sc mo1sp 5mot +moy5 2mp m1pa mpfa6 mpf3l mphe6 m1pi mpin6 m1pl mp2li m2plu mpo8ste +m1pr \n{mpr"a5} mp8th mput6 mpu5ts \n{m1p"o} 8m1q 2m1r 2ms ms5au m1sc +msch4l ms6po m3spri m1str 2m1t mt1ar m8tein m2t1h mt6se \n{mt8s"a} +mu5e 6m5uh mumi1 1mun mun6dr muse5e mu1ta 2m1v mvol2 mvoll3 2m1w 1my +2m1z \n{m"a6kl} \n{1m"an} \n{m"a1s} \n{m"a5tr} \n{m"au4s3c} \n{3m"a\3} +\n{\c{3m"a\9}} \n{m"ob2} \n{6m"ol} \n{1m"u} \n{5m"un} \n{3m"ut} 1na. +n5ab. 8nabn n1abs n1abz \n{na6b"a} na2c nach3e 3nacht 1nae na5el +n1afr 1nag 1n2ah na8ha na8ho 1nai 6nair na4kol n1akt nal1a 8naly 1nama +na4mer na1mn n1amp 8n1amt 5nanc nan6ce n1and n6and. 2n1ang 1nani +1nann n1ans 8nanw 5napf. 1n2ar. na2ra 2n1arc n8ard 1nari n8ark +6n1arm 5n6ars 2n1art n8arv 6natm nat6s5e 1naue 4nauf n3aug 5naui n5auk +na5um 6nausb 6nauto 1nav 2nax 3naz 1na\3 \c{1na\9} n1b2 nbau5s n1c +nche5e nch5m 2n1d nda8d n2d1ak nd5ans n2d1ei nde8lac ndel6sa n8derhi +nde4se nde8stal n2dj ndnis5 n6d5or6t nd3rec nd3rot nd8samt nd6sau +ndt1h n8dumd 1ne ne5as ne2bl 6n5ebn 2nec 5neei ne5en ne1g4l 2negy +4n1ein 8neis 4n3e4lem 8nemb 2n1emp nen1a 6n5energ nen3k 8nentb +4n3en3th 8nentl 8n5entn 8n5ents ne1ra ne5r8al ne8ras 8nerbi 6n5erde. +nere5i6d nerfor6 \n{6n5erh"o} \n{8nerl"o} 2n1err n8ers. 6n5ertra +2n1erz nesi3e net1h neu4ra neu5sc 8neu\3 \c{8neu\9} n1f nf5f nf2l +nflei8 nf5lin nft8st n8g5ac ng5d ng8en nge8ram ngg2 ng1h n6glic ng3rip +ng8ru ng2se4 ng2si n2g1um n1gy \n{n8g"al} n1h nhe6r5e 1ni ni1bl +\n{ni5ch"a} ni8dee n6ie ni1en nie6s5te niet5h ni8etn 4n3i6gel n6ik +ni1la 2n1imp ni5na 2n1ind 8ninf 6n5inh ni8nit 6n5inn 2n1ins 4n1int +n6is ni3str ni1th ni1tr n1j n6ji n8kad nk5ans n1ke n8kerla n1ki nk5inh +\n{n5kl"o} n1k2n n8k5not nk3rot \n{n8kr"u} nk5spo nk6t5r n8kuh +\n{n6k"ub} n5l6 nli4mi n1m nmen4s n1na n8nerg nni5o n1no nn4t3ak nnt1h +nnu1e n1ny \n{n1n"a} \n{n1n"o} \n{n1n"u} no5a no4b3la 4n3obs 2nobt +noche8 no6die no4dis no8ia no5isc 6n5o6leu no4mal noni6er 2n1onk n1ony +4n3o4per 6nopf 6nopti no3ra no4ram nor6da 4n1org 2n1ort n6os no1st +8nost. no8tan no8ter noty6pe 6n5ox n1p2 n1q n1r \n{nr"os3} 6ns n1sac +ns3ang n1sc n8self n8s5erf n8serg n6serk ns5erw n8sint n1s2pe n1spr +n6s5tat. n5s6te. n6stob n1str n1ta n4t3a4go nt5anh nt3ark nt3art +n1te nt3eis nte5n6ar nte8nei nter3a nte6rei nt1ha nt6har n3ther nt5hie +n3thus n1ti nti1c n8tinh nti1t ntlo6b ntmen8 n1to nt3o4ti n1tr ntra5f +ntra5ut nt8rea nt3rec nt8rep n4t3rin nt8rop n4t3rot \n{n4tr"u} nt1s +nts6an nt2sk n1tu nt1z \n{n1t"a} \n{n1t"o} \n{n8t"ol} \n{n1t"u} 1nu +nu1a nu5el nu5en 4n1uhr nu5ie 8numl 6n5ums 6n5umw 2n1und 6nuni 6n5unr +2n1unt 2nup 2nu6r n5uri nu3skr nu5ta n1v 8n1w 1nys n1za n6zab n2z1ar +n6zaus nzi4ga n8zof n6z5unt n1zw n6zwir \n{1n"ac} \n{5n"ae} \n{5n"ai} +\n{n8"al} \n{n"a6m} \n{n"a6re} \n{n5"arz} \n{5n"aus} \n{n1"ol} +\n{1n"ot} \n{n5"oz} \n{5n"u.} \n{6n1"u2b} \n{5n"u\3} \n{\c{5n"u\9}} +o5ab. oa2l o8ala o1a2m o1an ob1ac obe4ra o6berh 5o4bers o4beru +obe6ser 1obj o1bl o2bli ob5sk 3obst. ob8sta obst5re ob5sz o1che +oche8b o8chec o3chi och1l och3m ocho8f o3chro och3to o3chu och1w o1d +o2d1ag od2dr ode5i ode6n5e od1tr o5e6b o5e6der. oe8du o1ef o1e2l +o1e2p o1er. o5e8x o1fa of8fan 1offi of8fin of6f5la o5fla o1fr 8o1g +og2n o1ha o1he o6h5eis o1hi ohl1a oh1le oh4l3er 5ohm. oh2ni o1ho +oh1re oh1ru o1hu oh1w o1hy \n{o1h"a} o5ia o1id. o8idi oi8dr o5ids +o5isch. oiset6 o1ism o3ist. o5i6tu o1j o1k ok2l ok3lau \n{o8kl"a} +1okta o1la old5am old5r o1le ole5in ole1r ole3u ol6gl ol2kl olk4s1 +ol8lak ol8lauf. ol6lel ol8less o1lo ol1s ol6sk o1lu oly1e2 5olym +o2mab om6an o8mau ombe4 o8merz om5sp o1mu o8munt \n{o1m"a} \n{o1m"o} +o1na ona8m on1ax on8ent o6n5erb 8oni oni5er. on1k on6n5a6b o1no ono1c +o4nokt 1ons onts8 \n{o1n"a} oo8f 1oog oo2pe oo2sa o1pa 3o4pera o3pfli +opf3lo opf3r o1pi o1pl o2pli o5p6n op8pa op6pl o1pr o3p4ter 1opti +\n{o1p"a} \n{o5p"o} o1q o1ra. o3rad o8radd 1oram o6rang o5ras o8rauf +or5cha or4d3a4m or8dei or8deu 1ordn or4dos o1re o5re. ore2h o8r5ein +ore5isc or6enn or8fla or8fli 1orga 5orgel. or2gl o1ri 5o6rient or8nan +\n{or8n"a} o1ro or1r2h or6t5an or8tau or8tere o1rus o1ry \n{o1r"a} +\n{or1"u2} o1sa osa3i 6ose o8serk o1sk o6ske o6ski os2kl os2ko os2kr +osni5e o2s1o2d o3s4per o4stam o6stau o3stra ost3re osu6 o6s5ur o5s6ze +o1ta ot3auf o6taus o1te o6terw o1th othe5u o2th1r o1ti o1to oto1a +ot1re o1tri o1tro ot1sc o3tsu ot6t5erg ot2t3h ot2t5r \n{ot8t"o} o1tu +ou3e ouf1 ou5f6l o5u6gr ou5ie ou6rar ou1t6a o1v o1wa o1we o6wer. o1wi +owid6 o1wo o5wu o1xe oy5al. oy1e oy1i o5yo o1z oza2r 1o2zea ozo3is +\n{o"o8} o\35elt \c{o\95elt} o\31t \c{o\91t} 3paa pa6ce 5pad pag2 1pak +pa1la pa8na8t pani5el pa4nor pan1s2 1pap pap8s pa8rei par8kr paro8n +par5o6ti part8e 5partei 3partn pas6sep pa4tha 1pau 6paug pau3sc p1b +8p5c 4p1d 1pe 4peic pe5isc 2pek pen3k pen8to8 p8er pe1ra pere6 per5ea +per5eb pe4rem 2perr per8ran 3pers 4persi \n{pe3r"u} pe4sta pet2s +p2f1ec p4fei pf1f pf2l 5pflanz pf8leg pf3lei 2pft pf3ta p1g 1ph 2ph. +2p1haf 6phb 8phd 6p5heit ph5eme 6phg phi6e 8phk 6phn p5holl pht2 +ph3tha 4ph3the phu6 6phz pi1en pi5err pi1la pi1na 5pinse pioni8e 1pis +pi1s2k pi1th p1k pl8 5pla p2lau 4plei p3lein 2pler 6p5les 2plig p6lik +6p5ling p2liz plo8min 6p1m p1n 1p2o 8poh 5pol po8lan poly1 po3ny po1ra +2porn por4t3h \n{po5r"o} 5poti p1pa p6p5ei ppe6la pp5f p2p1h p1pi pp1l +ppp6 pp5ren pp1s \n{p5p"o} pr6 3preis 1pres 2p3rig 5prinz 1prob 1prod +5prog pro8pt pro6t5a prote5i 8pro\3 \c{8pro\9} \n{pr"a3l} \n{1pr"as} +\n{pr"ate4} \n{1pr"uf} p5schl 2pst 1p2sy p1t p8to8d pt1s 5p6ty 1pu +pu1b2 2puc pu2dr puf8fr 6p5uh pun8s pu8rei pu5s6h pu1ta p1v p3w 5py +py5l p1z \n{p"a6der} \n{p5"a6m} \n{p"a8nu} \n{8p"ar} \n{p"at5h} +\n{p"at1s} qu6 1qui 8rabk ra6bla 3rable ra2br r1abt 6rabz ra4dan ra2dr +5rafal ra4f3er ra5gla ra2g3n 6raha ral5am 5rald 4ralg ra8lins 2rall +ral5t 8ramei r3anal r6and ran8der ran4dr 8ranf 6ranga 5rangi ran8gli +r3angr rans5pa 8ranw r8anz. ra5or 6rapf ra5pl rap6s5er 2r1arb 1rarh +r1arm ra5ro 2r1art 6r1arz ra8tei ra6t5he 6ratl ra4t3ro r5atta raue4n +6raus. r5austa rau8tel raut5s ray1 r1b rb5lass r6bler rb4lie rbon6n +r8brecht \n{rb6s5t"a} r8ces r1che rch1l rch3m rch3re rch3tr rch1w 8rd +r1da r8dachs r8dap rda5ro rde5ins rdio5 r8dir rd3ost r1dr r8drau 1re. +re1ak 3reakt re3als re6am. re1as 4reben re6bl rech5a r8edi re3er +8reff 3refl 2reh 5reha r4ei. reich6s5 8reier 6reign re5imp 4r3eina +6r3einb 6reing 6r5einn 6reinr 4r3eins r3eint reli3e 8r5elt 6rempf +2remt ren5a6b ren8gl r3enni 1reno 5rente 4r3enth 8rentl 4r3entw 8rentz +ren4zw re1on requi5 1rer rer4bl 6rerbs 4r3erd \n{8rerh"o} 8rerkl +4r3erla \n{8rerl"o} 4r3erns \n{6r5ern"a} rer5o 6r5erreg r5ertr r5erwec +\n{r5er"o} re2sa re8schm 2ress re5u8ni 6rewo 2r1ex r1f r8ferd rf4lie +8r1g r8gah rge4bl rge5na rgest4 rg6ne r2gni2 r8gob r4g3ret rg8sel r1h8 +r2hy 5rhyt ri1ar ri5cha rid2g r2ie rieg4s5 ri8ei ri1el ri6ele ri1en +ri3er. ri5ers. ri6fan ri8fer ri8fr 1r2ig ri8kn ri5la \n{rim"a8} +ri1na r8inde rin4ga rin6gr 1rinn 6rinner rino1 r8insp 4rinst +\n{ri1n"a} ri5o6ch ri1o2d ri3o6st 2r1ir r2is ri3sko ri8spr \n{ri8st"u} +ri5sv r2it 6r5i6tal ri5tr ri6ve. 8r1j 6rk r1ke rkehrs5 r1ki r3klin +r1k2n rk3str rk4t3an rk6to r6kuh \n{rk"a4s3t} r1l r5li rline5a 6r1m +r6manl rma4p r4m3aph r8minf r8mob rm5sa 2rn r1na rna8be r5ne rn2ei +r6neif r6nex r6nh rn1k r1no r6n5oc rn1sp \n{r1n"a} \n{r1n"u} ro6bern +6robs ro1ch 3rock. ro5de ro1e 4rofe ro8hert 1rohr ro5id ro1in ro5isc +6rolym r2on 6roog ro6phan r3ort ro1s2p ro5s6w ro4tau ro1tr ro6ts 5rout +r1p rpe8re rp2f r2ps r2pt r1q 2rr r1ra r1re rrer6 rr6hos \n{r5rh"o} +r1ri r1ro rro8f rr8or rror5a r1ru r3ry \n{r1r"a} \n{r1r"o} \n{r1r"u} +2r1s r6sab r4sanf rse6e rse5na r2sh r6ska r6ski rs2kl r8sko r2sl rs2p +r6stauf r8sterw r8stran rswi3d4 r2sz 2r1t rt3art r8taut r5tei rt5eige +r8tepe r4t3erh r8terla r4t3hei r5t6hu r4t3int rt5reif rt1sc rt6ser +rt6s5o rt6s5u rt5und r8turt rube6 ru1en 1r4uf ruf4st ru1ie 2r1umg +2r1uml 2rums run8der run4d5r 6rundz 6runf 8runs 2r1unt 2r1ur r6us +ru6sta ru3str ru6tr 1ruts r1v rven1 rvi2c r1w r1x r1za rz5ac r6z5al +r8z1ar r8zerd r6z5erf rz8erh rz4t3h r8zum \n{r"a4ste} \n{r"au8sc} +\n{r1"of} \n{5r"ohr} \n{r"o5le} \n{3r"oll} \n{5r"omis} \n{r1"or} +\n{r"o2sc} \n{3r"ump} 1sa. 1saa s3a4ben sa2bl 2s1abs 6s1abt 6sabw +3sack. 6s3a4der 1saf sa1fa 4s1aff sa5fr 1sag 1sai sa1i2k1 4s1akt 1sal +sa1la 4s3alpi 6salter salz3a 1sam s5anb san2c 1sand s5angeh 6sanl +2s1ans 6s3antr 8s1anw s1ap s6aph 8sapo sap5p6 s8ar. 2s1arb 3sarg +s1arm sa5ro 2s1art 6s1arz 1sas 1sat sat8a 2s1atl sa8tom 3s8aue s5auff +sau5i s6aur 2s1aus 5s6ause 2s1b2 2sca s4ce 8sch. 3scha. 5schade +3schaf 3schal sch5ame 8schanc 8schb 1sche 6schef 8schex 2schf 2schg +2schh 1schi 2schk 5schlag 5schlu \n{6schm"a\3} \n{\c{6schm"a\9}} +6schna\3 \c{6schna\9} 1scho 6schord 6schp 3schri 8schric 8schrig +8schrou 6schs 2scht sch3ta sch3tr 1schu 8schunt 6schv 2schz \n{5sch"o} +\n{5sch"u} 2sco scre6 6scu 2s1d 1se se5an se1ap se6ben se5ec see5i6g +se3erl 8seff se6han se8hi \n{se8h"o} 6s5eid. 2s1eig s8eil 5sein. +sei5n6e 6s5einh 3s8eit 3sel. se4lar selb4 6s3e4lem se8lerl 2s1emp +sen3ac se5nec 6s5ents 4sentz s8er. se8reim ser5inn \n{8serm"a} +8s5erzi \n{6ser"of} se1um 8sexa 6sexp 2s1f2 sfal8ler 2s3g2 sge5b2 s1h +s8hew 5s6hip 5s4hop 1si 2siat si1b sicht6s 6s5i6dee siege6s5 si1en +si5err si1f2 si1g2n si6g5r si8kau sik1i si4kin si2kl \n{si8k"u} si1la +sil6br si1na 2s1inf sin5gh 2s1inh sinne6s5 2s1ins si5ru si5str 4s1j +s1k2 6sk. 2skau skel6c skelch5 s6kele 1s2ki. 3s4kin. s6kiz s8kj +6skn 2skow 3skrib 3skrip 2sku \n{8sk"u} s1l s8lal slei3t s4low 2s1m +s1n 6sna 6snot 1so so1ch 2s1odo so4dor 6s5o4fen solo3 s2on so5of 4sope +so1ra 2s1ord 4sorga sou5c so3un 4s3ox sp2 8spaa 5spal 1span 2spap +s2pec s4peis 1spek s6perg 4spers s6pes 2s1pf 8sphi \n{1s2ph"a} 1spi +spi4e 6s5pig 6spinse 2spis 2spla 2spol 5s6pom 6s5pos 6spoti 1spra +3s8prec 6spreis 5spring 6sprob 1spru s2pul 1s2pur 6spy \n{5sp"an} +\n{1sp"u} s1q 2s1r 2s1s2 sse8nu ssini6s ssoi6r 2st. 1sta 4stafe 2stag +sta3la 6stale 4stalg 8stalk 8stamt 6st5anf 4stans 6stanw 6starb sta4te +6staus 2stb 6stc 6std 1ste 4steil 3s2tel st3elb 8stemb 6steppi 8stese +8stesse 6stf 2stg 2sth st1ha st3hei s8t1hi st1ho st5hu 1sti sti4el +4stigm sti3na 6stind 4stinf sti8r 2stk 2stl 2stm 1sto 6stoll. 4st3ope +6stopf. 6stord 6stp 5stra. 4strai 3s4tral 6s5traum 3stra\3 +\c{3stra\9} 3strec 6s3tref 8streib 5streif 6streno 6stres 6strev +5s6tria 6strig 5strik 8strisi 3s4troa s8troma st5rose 4struf 3strum +\n{6str"ag} 2st1s6 2stt 1stu stu5a 4stuc 2stue 8stun. 2stv 2stw s2tyl +6stz \n{1st"a} \n{8st"ag} \n{1st"o} \n{1st"u} \n{8st"uch} \n{4st"ur.} +1su su2b1 3suc su1e su2fe su8mar 6sumfa 8sumk 2s1unt sup1p2 6s5u6ran +6surte 2s1v 2s1w 1sy 8syl. sy5la syn1 sy2na syne4 s1z s4zend 5s6zene. +8szu \n{1s"a} \n{6s5"and} \n{6s"augi} \n{6s"au\3} \n{\c{6s"au\9}} +\n{5s"om} \n{2s1"u2b} \n{1s"uc} \n{s"u8di} \n{1s"un} \n{5s"u\3} +\n{\c{5s"u\9}} taats3 4tab. taba6k ta8ban tab2l ta6bre 4tabs t3absc +8tabz 6t3acht ta6der 6tadr tad6s tad2t 1tafe4 1tag ta6ga6 ta8gei +tage4s tag6s5t tah8 tahl3 tai6ne. ta5ir. tak8ta tal3au 1tale ta8leng +tal5ert 6t5a6mer 6tamp tampe6 2t1amt tan5d6a tan8dr tands5a tani5e +6tanl 2tanr t3ans 8t5antr tanu6 t5anw 8tanwa tan8zw ta8rau 6tarbe +1tari 2tark 2t1arm ta1ro 2tart t3arti 6tarz ta1sc ta6sien ta8stem +ta8sto t5aufb 4taufn 8taus. 5tause 8tausf 6tausg t5ausl 2t1b2 2t1c +t6chu 2t1d te2am tea4s te8ben 5techn 4teff te4g3re te6hau 2tehe te4hel +2t1ehr te5id. teig5l 6teign tei8gr 1teil 4teinh t5einhe 4teis t5eisen +8teiw te8lam te4lar 4telek 8telem te6man te6n5ag ten8erw ten5k tens4p +ten8tro 4t3entw 8tentz te6pli 5teppi ter5a6b te3ral ter5au 8terbar +t5erbe. 6terben 8terbs 4t3erbt t5erde. ter5ebe ter5ein te8rers terf4 +\n{8terh"o} \n{6terkl"a} ter8nor ter6re. t8erscha t5e6sel te8stau +t3euro te1xa tex3e 8texp tex6ta 2t1f2 2t1g2 2th. th6a 5tha. 2thaa +6t1hab 6t5haf t5hah 8thak 3thal. 6thals 6t3hand 2t1hau 1the. 3t4hea +t1heb t5heil t3heit t3helf 1theo 5therap 5therf 6t5herz 1thes 1thet +5thi. 2t1hil t3him 8thir 3this t5hj 2th1l 2th1m th1n t5hob t5hof +4tholz 6thopti 1thr6 4ths t1hum 1thy \n{4t1h"a} \n{2t1h"o} \n{t1h"u} +ti1a2m ti1b tie6fer ti1en ti8gerz tig3l ti8kin ti5lat 1tilg t1ind +tin4k3l ti3spa ti5str 5tite ti5tr ti8vel ti8vr 2t1j 2t1k2 2t1l tl8a +2t1m8 2t1n 3tobe 8tobj to3cha 5tocht 8tock tode4 to8del to8du to1e +6t5o6fen to1in toi6r 5toll. to8mene t2ons 2t1ony to4per 5topf. 6topt +to1ra to1s to6ska tos2l 2toti to1tr t8ou 2t1p2 6t1q tr6 tra5cha +tra8far traf5t 1trag tra6gl tra6gr t3rahm 1trai t6rans tra3sc tra6st +3traue t4re. 2trec t3rech t8reck 6t1red t8ree 4t1reg 3treib 4treif +8t3reis 8trepo tre6t5r t3rev 4t3rez 1trib t6rick tri6er 2trig t8rink +tri6o5d trizi5 tro1a 3troc trocke6 troi8d tro8man. tro3ny 5tropf +6t5rosa t5ro\3 \c{t5ro\9} 5trub 5trup trut5 \n{1tr"ag} \n{6t1r"oh} +\n{5tr"ub} \n{tr"u3bu} \n{t1r"uc} \n{t1r"us} 2ts ts1ab t1sac tsa8d +ts1ak t6s5alt ts1an ts1ar ts3auf t3schr \n{t5sch"a} tse6e tsee5i +tsein6s ts3ent ts1er t8serf t4serk t8sh 5t6sik t4s3int ts5ort. +t5s6por t6sprei t1st t6s5tanz ts1th t6stit t4s3tor 1t2sua t2s1uf +t8sum. t2s1u8n t2s1ur 2t1t tt5eif tte6sa tt1ha tt8ret tt1sc tt8ser +tt5s6z 1tuc tuch5a 1tu1e 6tuh t5uhr tu1i tu6it 1tumh 6t5umr 1tums +8tumt 6tund 6tunf 2t1unt tu5ra tu6rau tu6re. tu4r3er 2t1v 2t1w 1ty1 +ty6a ty8la 8tym 6ty6o 2tz tz5al tz1an tz1ar t8zec tzeh6 tzehn5 t6z5ei. +t6zor t4z3um \n{t6z"au} \n{5t"ag} \n{6t"ah} \n{t5"alt} \n{t8"an} +\n{t"are8} \n{8t"a8st} \n{6t"au\3} \n{\c{6t"au\9}} \n{t5"offen} +\n{8t"o8k} \n{1t"on} \n{4t"ub} \n{t6"u5ber.} \n{5t"uch} \n{1t"ur.} +u3al. u5alb u5alf u3alh u5alk u3alp u3an. ua5na u3and u5ans u5ar. +ua6th u1au ua1y u2bab ubi5er. u6b5rit ubs2k \n{u5b"o} \n{u8b"ub} 2uc +u1che u6ch5ec u1chi uch1l uch3m uch5n uch1r uch5to ucht5re u1chu uch1w +uck1a uck5in u1d ud4a u1ei u6ela uene8 u6ep u1er uer1a ue8rerl uer5o +u8esc u2est u8ev u1fa u2f1ei u4f3ent u8ferh uf1fr uf1l uf1ra uf1re +\n{uf1r"a} \n{uf1r"u} uf1s2p uf1st uft1s u8gabt u8gad u6gap ugeb8 u8gn +ugo3s4 u1ha u1he u1hi uh1le u1ho uh1re u1hu uh1w \n{u1h"a} \n{u1h"o} +6ui ui5en u1ig u3ins uin8tes u5isch. u1j 6uk u1ke u1ki u1kl u8klu +u1k6n u5ky u1la uld8se u1le ul8lac ul6lau ul6le6l ul6lo ulni8 u1lo +ulo6i ult6a ult8e u1lu ul2vr \n{u1l"a} \n{u1l"o} 3umfan 5umlau umo8f +um8pho u1mu umu8s \n{u5m"o} u1n1a un2al un6at unau2 6und. 5undein +un4d3um 3undzw \n{und"u8} \n{un8d"ub} une2b un1ec une2h un3eis 3unfal +\n{1unf"a} 5ungea \n{3ungl"u} ung2s1 \n{un8g"a} 1u2nif un4it un8kro +unk5s u1no unpa2 uns2p unvol4 unvoll5 u5os. u1pa u1pi u1p2l u1pr +up4s3t up2t1a u1q u1ra ur5abs ura8d ur5ah u6rak ur3alt u6rana u6r5ans +u8rap ur5a6ri u8ratt u1re ur3eig ur8gri u1ri ur5ins 3urlau urmen6 +ur8nan u1ro 3ursac ur8sau ur8sei ur4sk 3urtei u1ru uru5i6 uru6r u1ry +ur2za \n{ur6z"a} \n{ur5"a6m} \n{u5r"o} \n{u1r"u} \n{ur"uck3} u1sa +usa4gi u2s1ar u2s1au u8schec usch5wi u2s1ei use8kel u8sl u4st3a4b +us3tau u3s4ter u2s1uf u8surn ut1ac u1tal uta8m u1tan ut1ar u1tas ut1au +u1te u8teic u4tent u8terf u6terin u4t3hei ut5ho ut1hu u1ti utine5 +uti6q u1to uto5c u1tr ut1sa ut1s6p ut6stro u1tu utz5w u1u u1v uve5n +\n{uve3r4"a} u1w u1xe u5ya uy5e6 u1yi u2z1eh u8zerh \n{u5"o} u\3e6n +\c{u\9e6n} u\3en5e \c{u\9en5e} 8vanb 6vang 6varb var8d va6t5a va8tei +va2t1r 2v1b 6v5c 6vd 1ve 6ve5g6 ver1 ver5b verb8l ve2re2 verg8 ve2ru8 +ve1s ve2s3p ve3xe 2v1f 2v1g 6v5h vi6el vie6w5 vi1g4 vi8leh vil6le. +8vint vi1ru vi1tr 2v1k 2v1l 2v1m 4v5n 8vo8f voi6le vol8lend vol8li +v2or1 vo2re vo8rin vo2ro 2v1p 8vra v6re 2v1s 2v1t 2v1v 4v3w 2v1z +waffe8 wa6g5n 1wah wah8n wa5la wal8din wal6ta wan4dr 5ware wa8ru +war4za 1was w5c w1d 5wech we6fl 1weg we8geng weg5h weg3l we2g1r +weh6r5er 5weise weit3r wel2t welt3r we6rat 8werc 5werdu wer4fl 5werk. +wer4ka wer8ku wer4ta wer8term we2sp we8stend we6steu we8str +\n{we8st"o} wet8ta wich6s5t 1wid wi2dr wiede4 wieder5 wik6 wim6ma +win4d3r 5wirt wisch5l 1wj 6wk 2w1l 8w1n wo1c woche6 wol6f wor6t5r 6ws2 +w1sk 6w5t 5wunde. wun6gr wu1sc wu2t1 6w5w wy5a \n{w"arme5} \n{w"a1sc} +1xag x1ak x3a4men 8xamt x1an 8x1b x1c 1xe. x3e4g 1xen xe1ro x1erz +1xes 8xf x1g 8x1h 1xi 8xid xi8so 4xiste x1k 6x1l x1m 8xn 1xo 8x5o6d +8x3p2 x1r x1s6 8x1t x6tak x8terf x2t1h 1xu xu1e x5ul 6x3w x1z 5ya. +y5an. y5ank y1b y1c y6cha y4chia y1d yen6n y5ern y1g y5h y5in y1j +y1k2 y1lak yl1al yla8m y5lax y1le y1lo y5lu y8mn ym1p2 y3mu y1na yno2d +yn1t y1on. y1o4p y5ou ypo1 y1pr y8ps y1r yri3e yr1r2 y1s ys5iat ys8ty +y1t y3w y1z \n{y"a8m} z5a6b zab5l 8za6d 1zah za5is 4z3ak 6z1am 5zange. +8zanl 2z1ara 6z5as z5auf 3zaun 2z1b 6z1c 6z1d 1ze ze4dik 4z3eff 8zein +zei4ta zei8ters ze6la ze8lec zel8th 4zemp 6z5engel zen8zin \n{8zerg"a} +zer8i ze1ro zers8 zerta8 zer8tab zer8tag 8zerz ze8ste zeu6gr 2z1ex +2z1f8 z1g 4z1h 1zi zi1en zi5es. 4z3imp zi1na 6z5inf 6z5inni zin6s5er +8zinsuf zist5r zi5th zi1tr 6z1j 2z1k 2z1l 2z1m 6z1n 1zo zo6gl 4z3oh +zo1on zor6na8 4z1p z5q 6z1r 2z1s8 2z1t z4t3end z4t3hei z8thi 1zu zu3al +zu1b4 zu1f2 6z5uhr zun2a 8zunem zunf8 8zungl zu1o zup8fi zu1s8 zu1z +2z1v zw8 z1wal 5zweck zwei3s z1wel z1wer z6werg 8z5wes 1zwi zwi1s +6z1wo 1zy 2z1z zz8a zzi1s \n{1z"a} \n{1z"o} \n{6z"ol.} \n{z"o1le} +\n{1z"u} \n{2z1"u2b} \n{"a1a6} \n{"ab1l} \n{"a1che} \n{"a3chi} +\n{"ach8sc} \n{"ach8sp} \n{"a5chu} \n{"ack5a} \n{"ad1a} \n{"ad5era} +\n{"a6d5ia} \n{"a1e} \n{"a5fa} \n{"af1l} \n{"aft6s} \n{"ag1h} +\n{"ag3le} \n{"a6g5nan} \n{"ag5str} \n{"a1he} \n{"a1hi} \n{"ah1le} +\n{"ah5ne} \n{1"ahnl} \n{"ah1re} \n{"ah5ri} \n{"ah1ru} \n{"a1hu} +\n{"ah1w} \n{6"ai} \n{"a1isc} \n{"a6ische} \n{"a5ism} \n{"a5j} +\n{"a1k} \n{"al1c} \n{"a1le} \n{"a8lei} \n{"al6schl} \n{"ami1e} +\n{"am8n} \n{"am8s} \n{"a5na} \n{5"anderu} \n{"ane5i8} \n{"ang3l} +\n{"ank5l} \n{"a1no} \n{"an6s5c} \n{"a1pa} \n{"ap6s5c} \n{3"aq} +\n{"ar1c} \n{"a1re} \n{"are8m} \n{5"argern} \n{"ar6gl} \n{"a1ri} +\n{3"armel} \n{"a1ro} \n{"art6s5} \n{"a1ru} \n{3"arztl} \n{"a5r"o} +\n{"a6s5chen} \n{"asen8s} \n{"as1th} \n{"ata8b} \n{"a1te} \n{"ateri4} +\n{"ater5it} \n{"a6thy} \n{"a1ti} \n{3"atk} \n{"a1to} \n{"at8schl} +\n{"ats1p} \n{"a5tu} \n{"aub1l} \n{"au1e} \n{1"aug} \n{"au8ga} +\n{"au5i} \n{"a1um.} \n{"a1us.} \n{1"au\3} \n{\c{1"au\9}} \n{"a1z} +\n{"o1b} \n{"o1che} \n{"o5chi} \n{"och8stei} \n{"och8str} \n{"ocht6} +\n{5"o6dem} \n{5"offn} \n{"o1he} \n{"oh1l8} \n{"oh1re} \n{"o1hu} +\n{"o1is} \n{"o1ke} \n{1"o2ko} \n{1"ol.} \n{"ol6k5l} \n{"ol8pl} +\n{"o1mu} \n{"o5na} \n{"onig6s3} \n{"o1no} \n{"o5o6t} \n{"opf3l} +\n{"op6s5c} \n{"o1re} \n{"or8gli} \n{"o1ri} \n{"or8tr} \n{"o1ru} +\n{5"osterr} \n{"o1te} \n{"o5th} \n{"o1ti} \n{"o1tu} \n{"o1v} \n{"o1w} +\n{"owe8} \n{"o2z} \n{"ub6e2} \n{3"u4ber1} \n{"ub1l} \n{"ub1r} +\n{5"u2bu} \n{"u1che} \n{"u1chi} \n{"u8ch3l} \n{"uch6s5c} \n{"u8ck} +\n{"uck1a} \n{"uck5ers} \n{"ud1a2} \n{"u6deu} \n{"udi8t} \n{"u2d1o4} +\n{"ud5s6} \n{"uge4l5a} \n{"ug1l} \n{"uh5a} \n{"u1he} \n{"u8heh} +\n{"u6h5erk} \n{"uh1le} \n{"uh1re} \n{"uh1ru} \n{"u1hu} \n{"uh1w} +\n{"u3k} \n{"u1le} \n{"ul4l5a} \n{"ul8lo} \n{"ul4ps} \n{"ul6s5c} +\n{"u1lu} \n{"un8da} \n{"un8fei} \n{"unk5l} \n{"un8za} \n{"un6zw} +\n{"u5pi} \n{"u1re} \n{"u8rei} \n{"ur8fl} \n{"ur8fr} \n{"ur8geng} +\n{"u1ri} \n{"u1ro} \n{"ur8sta} \n{"ur8ster} \n{"u1ru} \n{"use8n} +\n{"u8sta} \n{"u8stes} \n{"u6s5tete} \n{"u3ta} \n{"u1te} \n{"u1ti} +\n{"ut8tr} \n{"u1tu} \n{"ut8zei} \n{"u1v} \31a8 \c{\91a8} 5\3a. +\c{5\9a.} \38as \c{\98as} \31b8 \c{\91b8} \31c \c{\91c} \31d \c{\91d} +1\3e \c{1\9e} \35ec \c{\95ec} 8\3e8g \c{8\9e8g} 8\3e8h \c{8\9e8h} +2\31ei \c{2\91ei} 8\3em \c{8\9em} \31f8 \c{\91f8} \31g \c{\91g} \31h +\c{\91h} 1\3i \c{1\9i} \31k \c{\91k} \31l \c{\91l} \31m \c{\91m} +\3mana8 \c{\9mana8} \31n \c{\91n} \31o \c{\91o} \31p8 \c{\91p8} \35q +\c{\95q} \31r \c{\91r} \31s2 \c{\91s2} \3st8 \c{\9st8} \31ta \c{\91ta} +\31te \c{\91te} \3t3hei \c{\9t3hei} \31ti \c{\91ti} \35to \c{\95to} +\31tr \c{\91tr} 1\3u8 \c{1\9u8} 6\35um \c{6\95um} \31v \c{\91v} \31w +\c{\91w} \31z \c{\91z} +}% +\endgroup +\relax\endinput +% +% ----------------------------------------------------------------- +% +% =============== Additional Documentation =============== +% +% +% Older Versions of German Hyphenation Patterns: +% ---------------------------------------------- +% +% All older versions of `ghyphen.tex' distributed as +% +% ghyphen.tex/germhyph.tex as of 1986/11/01 +% ghyphen.min/ghyphen.max as of 1988/10/10 +% ghyphen3.tex as of 1990/09/27 & 1991/02/13 +% ghyph31.tex as of 1994/02/13 +% +% are out of date and it is recommended to replace them +% with the new version `dehypht.tex' as of 1999/03/03. +% +% If you are using `ghyphen.min' (a minor version of `ghyphen') +% because of limited trie memory space, try this version and if +% the space is exceeded get a newer TeX implementation with +% larger or configurable trie memory sizes. +% +% +% +% Trie Memory Requirements/Space for Hyphenation Patterns: +% -------------------------------------------------------- +% +% To load this set of german hyphenation patterns the parameters +% of TeX has to have at least these values: +% +% TeX 3.x: +% IniTeX: trie_size >= 9733 trie_op_size >= 207 +% VirTeX: trie_size >= 8375 trie_op_size >= 207 +% +% TeX 2.x: +% IniTeX: trie_size >= 8675 trie_op_size >= 198 +% VirTeX: trie_size >= 7560 trie_op_size >= 198 +% +% If you want to load more than one set of hyphenation patterns +% (in TeX 3.x), the parameters have to be set to a value larger +% than or equal to the sum of all required values for each set. +% +% +% Setting Trie Memory Parameters: +% ------------------------------- +% +% Some implementations allow the user to change the default value +% of a set of the internal TeX parameters including the trie memory +% size parameter specifying the used memory for the hyphenation +% patterns. +% +% Web2c 7.x (Source), teTeX 0.9 (Unix, Amiga), fpTeX (Win32) +% and newer: +% The used memory size of the true is usually set high enough. +% If needed set the size of the trie using the keyword `trie_size' +% in the configuration file `texmf/web2c/texmf.cnf'. For details +% see the included documentation. +% +% emTeX (OS/2, MS-DOS, Windows 3.x/9x/NT): +% You can set the used memory size of the trie using the +% `-mt' option on the command line or in the +% TEXOPTIONS environment variable. +% +% PasTeX (Amiga): +% The values for the parameters can be set using the keywords +% `triesize', `itriesize' and `trieopsize' in the configuration +% file. +% +% others (binaries only): +% See the documentation of the implementation if it is possible +% and how to change these values without recompilation. +% +% others (with sources) +% If the trie memory is too small, you have to recompile TeX +% using larger values for `trie_size' and `trie_op_size'. +% Modify the change file `tex.ch' and recompile TeX. +% For details see the documentation included in the sources. +% +% +% +% Necessary Settings in TeX macro files: +% -------------------------------------- +% +% \lefthyphenmin, \righthyphenmin: +% You can set both parameters to 2. +% +% \lccode : +% To get correct hyphenation points within words containing +% umlauts or \ss, it's necessary to assign values > 0 to the +% appropriate \lccode positions. +% +% These changes are _not_ done when reading this file and have to +% be included in the language switching mechanism as is done in, +% for example, `german.sty' (\lccode change for ^^Y = \ss in OT1, +% \left-/\righthyphenmin settings). +% +% +%% \CharacterTable +%% {Upper-case \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 +%% Lower-case \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 +%% Digits \0\1\2\3\4\5\6\7\8\9 +%% Exclamation \! Double quote \" Hash (number) \# +%% Dollar \$ Percent \% Ampersand \& +%% Acute accent \' Left paren \( Right paren \) +%% Asterisk \* Plus \+ Comma \, +%% Minus \- Point \. Solidus \/ +%% Colon \: Semicolon \; Less than \< +%% Equals \= Greater than \> Question mark \? +%% Commercial at \@ Left bracket \[ Backslash \\ +%% Right bracket \] Circumflex \^ Underscore \_ +%% Grave accent \` Left brace \{ Vertical bar \| +%% Right brace \} Tilde \~} +%% +\endinput +%% +%% End of file `dehypht.tex'. diff --git a/src/vendormodules/textutil/eshyph_vo.tex b/src/vendormodules/textutil/eshyph_vo.tex new file mode 100644 index 00000000..e15bdc38 --- /dev/null +++ b/src/vendormodules/textutil/eshyph_vo.tex @@ -0,0 +1,1104 @@ +.\'a2 +.\'aa2 +.\'ae2 +.\'ai2 +.\'ao2 +.\'au2 +.\'e2 +.\'ea2 +.\'ee2 +.\'ei2 +.\'eo2 +.\'eu2 +.\'i2 +.\'ia2 +.\'ie2 +.\'ii2 +.\'io2 +.\'iu2 +.\'o2 +.\'oa2 +.\'oe2 +.\'oi2 +.\'oo2 +.\'ou2 +.\'u2 +.\'ua2 +.\'ue2 +.\'ui2 +.\'uo2 +.\'uu2 +.a2 +.a\'a2 +.a\'e2 +.a\'i2 +.a\'o2 +.a\'u2 +.aa2 +.ae2 +.ai2 +.ao2 +.au2 +.e2 +.e\'a2 +.e\'e2 +.e\'i2 +.e\'o2 +.e\'u2 +.ea2 +.ee2 +.ei2 +.eo2 +.eu2 +.i2 +.i\'a2 +.i\'e2 +.i\'i2 +.i\'o2 +.i\'u2 +.ia2 +.ie2 +.ii2 +.io2 +.iu2 +.o2 +.o\'a2 +.o\'e2 +.o\'i2 +.o\'o2 +.o\'u2 +.oa2 +.oe2 +.oi2 +.oo2 +.ou2 +.u2 +.u\'a2 +.u\'e2 +.u\'i2 +.u\'o2 +.u\'u2 +.ua2 +.ue2 +.ui2 +.uo2 +.uu2 +2\'a. +2\'aa. +2\'ae. +2\'ai. +2\'ao. +2\'au. +2\'e. +2\'ea. +2\'ee. +2\'ei. +2\'eo. +2\'eu. +2\'i. +2\'ia. +2\'ie. +2\'ii. +2\'io. +2\'iu. +2\'o. +2\'oa. +2\'oe. +2\'oi. +2\'oo. +2\'ou. +2\'u. +2\'ua. +2\'ue. +2\'ui. +2\'uo. +2\'uu. +2\~n1\~n +2\~n1b +2\~n1c +2\~n1d +2\~n1f +2\~n1g +2\~n1h +2\~n1j +2\~n1k +2\~n1m +2\~n1n +2\~n1p +2\~n1q +2\~n1s +2\~n1t +2\~n1v +2\~n1w +2\~n1x +2\~n1y +2\~n1z +2a. +2a\'a. +2a\'e. +2a\'i. +2a\'o. +2a\'u. +2aa. +2ae. +2ai. +2ao. +2au. +2b1\~n +2b1b +2b1c +2b1d +2b1f +2b1g +2b1h +2b1j +2b1k +2b1m +2b1n +2b1p +2b1q +2b1s +2b1t +2b1v +2b1w +2b1x +2b1y +2b1z +2c1\~n +2c1b +2c1c +2c1d +2c1f +2c1g +2c1j +2c1k +2c1m +2c1n +2c1p +2c1q +2c1s +2c1t +2c1v +2c1w +2c1x +2c1y +2c1z +2d1\~n +2d1b +2d1c +2d1d +2d1f +2d1g +2d1h +2d1j +2d1k +2d1m +2d1n +2d1p +2d1q +2d1s +2d1t +2d1v +2d1w +2d1x +2d1y +2d1z +2e. +2e\'a. +2e\'e. +2e\'i. +2e\'o. +2e\'u. +2ea. +2ee. +2ei. +2eo. +2eu. +2f1\~n +2f1b +2f1c +2f1d +2f1f +2f1g +2f1h +2f1j +2f1k +2f1m +2f1n +2f1p +2f1q +2f1s +2f1t +2f1v +2f1w +2f1x +2f1y +2f1z +2g1\~n +2g1b +2g1c +2g1d +2g1f +2g1g +2g1h +2g1j +2g1k +2g1m +2g1n +2g1p +2g1q +2g1s +2g1t +2g1v +2g1w +2g1x +2g1y +2g1z +2h1\~n +2h1b +2h1c +2h1d +2h1f +2h1g +2h1h +2h1j +2h1k +2h1m +2h1n +2h1p +2h1q +2h1s +2h1t +2h1v +2h1w +2h1x +2h1y +2h1z +2i. +2i\'a. +2i\'e. +2i\'i. +2i\'o. +2i\'u. +2ia. +2ie. +2ii. +2io. +2iu. +2j1\~n +2j1b +2j1c +2j1d +2j1f +2j1g +2j1h +2j1j +2j1k +2j1m +2j1n +2j1p +2j1q +2j1s +2j1t +2j1v +2j1w +2j1x +2j1y +2j1z +2k1\~n +2k1b +2k1c +2k1d +2k1f +2k1g +2k1h +2k1j +2k1k +2k1m +2k1n +2k1p +2k1q +2k1s +2k1t +2k1v +2k1w +2k1x +2k1y +2k1z +2l1\~n +2l1b +2l1c +2l1d +2l1f +2l1g +2l1h +2l1j +2l1k +2l1m +2l1n +2l1p +2l1q +2l1s +2l1t +2l1v +2l1w +2l1x +2l1y +2l1z +2m1\~n +2m1b +2m1c +2m1d +2m1f +2m1g +2m1h +2m1j +2m1k +2m1l +2m1m +2m1n +2m1p +2m1q +2m1r +2m1s +2m1t +2m1v +2m1w +2m1x +2m1y +2m1z +2n1\~n +2n1b +2n1c +2n1d +2n1f +2n1g +2n1h +2n1j +2n1k +2n1l +2n1m +2n1n +2n1p +2n1q +2n1r +2n1s +2n1t +2n1v +2n1w +2n1x +2n1y +2n1z +2o. +2o\'a. +2o\'e. +2o\'i. +2o\'o. +2o\'u. +2oa. +2oe. +2oi. +2oo. +2ou. +2p1\~n +2p1b +2p1c +2p1d +2p1f +2p1g +2p1h +2p1j +2p1k +2p1m +2p1n +2p1p +2p1q +2p1s +2p1t +2p1v +2p1w +2p1x +2p1y +2p1z +2q1\~n +2q1b +2q1c +2q1d +2q1f +2q1g +2q1h +2q1j +2q1k +2q1m +2q1n +2q1p +2q1q +2q1s +2q1t +2q1v +2q1w +2q1x +2q1y +2q1z +2r1\~n +2r1b +2r1c +2r1d +2r1f +2r1g +2r1h +2r1j +2r1k +2r1m +2r1n +2r1p +2r1q +2r1s +2r1t +2r1v +2r1w +2r1x +2r1y +2r1z +2s1\~n +2s1b +2s1c +2s1d +2s1f +2s1g +2s1h +2s1j +2s1k +2s1m +2s1n +2s1p +2s1q +2s1s +2s1t +2s1v +2s1w +2s1x +2s1y +2s1z +2t1\~n +2t1b +2t1c +2t1d +2t1f +2t1g +2t1h +2t1j +2t1k +2t1m +2t1n +2t1p +2t1q +2t1s +2t1t +2t1v +2t1w +2t1x +2t1y +2t1z +2u. +2u\'a. +2u\'e. +2u\'i. +2u\'o. +2u\'u. +2ua. +2ue. +2ui. +2uo. +2uu. +2v1\~n +2v1b +2v1c +2v1d +2v1f +2v1g +2v1h +2v1j +2v1k +2v1m +2v1n +2v1p +2v1q +2v1s +2v1t +2v1v +2v1w +2v1x +2v1y +2v1z +2w1\~n +2w1b +2w1c +2w1d +2w1f +2w1g +2w1h +2w1j +2w1k +2w1m +2w1n +2w1p +2w1q +2w1s +2w1t +2w1v +2w1w +2w1x +2w1y +2w1z +2x1\~n +2x1b +2x1c +2x1d +2x1f +2x1g +2x1h +2x1j +2x1k +2x1m +2x1n +2x1p +2x1q +2x1s +2x1t +2x1v +2x1w +2x1x +2x1y +2x1z +2y1\~n +2y1b +2y1c +2y1d +2y1f +2y1g +2y1h +2y1j +2y1k +2y1m +2y1n +2y1p +2y1q +2y1s +2y1t +2y1v +2y1w +2y1x +2y1y +2y1z +2z1\~n +2z1b +2z1c +2z1d +2z1f +2z1g +2z1h +2z1j +2z1k +2z1m +2z1n +2z1p +2z1q +2z1s +2z1t +2z1v +2z1w +2z1x +2z1y +2z1z +\'a1\'i +\'a1\'u +\'a1\~n +\'a1a +\'a1b +\'a1c +\'a1d +\'a1e +\'a1f +\'a1g +\'a1h +\'a1j +\'a1k +\'a1l +\'a1m +\'a1n +\'a1o +\'a1p +\'a1q +\'a1r +\'a1s +\'a1t +\'a1v +\'a1w +\'a1x +\'a1y +\'a1z +\'a2\~n. +\'a2b. +\'a2c. +\'a2d. +\'a2f. +\'a2g. +\'a2h. +\'a2j. +\'a2k. +\'a2l. +\'a2m. +\'a2n. +\'a2p. +\'a2q. +\'a2r. +\'a2s. +\'a2t. +\'a2v. +\'a2w. +\'a2x. +\'a2y. +\'a2z. +\'e1\'i +\'e1\'u +\'e1\~n +\'e1a +\'e1b +\'e1c +\'e1d +\'e1e +\'e1f +\'e1g +\'e1h +\'e1j +\'e1k +\'e1l +\'e1m +\'e1n +\'e1o +\'e1p +\'e1q +\'e1r +\'e1s +\'e1t +\'e1v +\'e1w +\'e1x +\'e1y +\'e1z +\'e2\~n. +\'e2b. +\'e2c. +\'e2d. +\'e2f. +\'e2g. +\'e2h. +\'e2j. +\'e2k. +\'e2l. +\'e2m. +\'e2n. +\'e2p. +\'e2q. +\'e2r. +\'e2s. +\'e2t. +\'e2v. +\'e2w. +\'e2x. +\'e2y. +\'e2z. +\'i1\'a +\'i1\'e +\'i1\'o +\'i1\~n +\'i1a +\'i1b +\'i1c +\'i1d +\'i1e +\'i1f +\'i1g +\'i1h +\'i1j +\'i1k +\'i1l +\'i1m +\'i1n +\'i1o +\'i1p +\'i1q +\'i1r +\'i1s +\'i1t +\'i1v +\'i1w +\'i1x +\'i1y +\'i1z +\'i2\~n. +\'i2b. +\'i2c. +\'i2d. +\'i2f. +\'i2g. +\'i2h. +\'i2j. +\'i2k. +\'i2l. +\'i2m. +\'i2n. +\'i2p. +\'i2q. +\'i2r. +\'i2s. +\'i2t. +\'i2v. +\'i2w. +\'i2x. +\'i2y. +\'i2z. +\'o1\'i +\'o1\'u +\'o1\~n +\'o1a +\'o1b +\'o1c +\'o1d +\'o1e +\'o1f +\'o1g +\'o1h +\'o1j +\'o1k +\'o1l +\'o1m +\'o1n +\'o1o +\'o1p +\'o1q +\'o1r +\'o1s +\'o1t +\'o1v +\'o1w +\'o1x +\'o1y +\'o1z +\'o2\~n. +\'o2b. +\'o2c. +\'o2d. +\'o2f. +\'o2g. +\'o2h. +\'o2j. +\'o2k. +\'o2l. +\'o2m. +\'o2n. +\'o2p. +\'o2q. +\'o2r. +\'o2s. +\'o2t. +\'o2v. +\'o2w. +\'o2x. +\'o2y. +\'o2z. +\'u1\'a +\'u1\'e +\'u1\'o +\'u1\~n +\'u1a +\'u1b +\'u1c +\'u1d +\'u1e +\'u1f +\'u1g +\'u1h +\'u1j +\'u1k +\'u1l +\'u1m +\'u1n +\'u1o +\'u1p +\'u1q +\'u1r +\'u1s +\'u1t +\'u1v +\'u1w +\'u1x +\'u1y +\'u1z +\'u2\~n. +\'u2b. +\'u2c. +\'u2d. +\'u2f. +\'u2g. +\'u2h. +\'u2j. +\'u2k. +\'u2l. +\'u2m. +\'u2n. +\'u2p. +\'u2q. +\'u2r. +\'u2s. +\'u2t. +\'u2v. +\'u2w. +\'u2x. +\'u2y. +\'u2z. +a1\'a +a1\'e +a1\'i +a1\'o +a1\'u +a1\~n +a1a +a1b +a1c +a1d +a1e +a1f +a1g +a1h +a1j +a1k +a1l +a1m +a1n +a1o +a1p +a1q +a1r +a1s +a1t +a1v +a1w +a1x +a1y +a1z +a2\~n. +a2b. +a2c. +a2d. +a2f. +a2g. +a2h. +a2j. +a2k. +a2l. +a2m. +a2n. +a2p. +a2q. +a2r. +a2s. +a2t. +a2v. +a2w. +a2x. +a2y. +a2z. +e1\'a +e1\'e +e1\'i +e1\'o +e1\'u +e1\~n +e1a +e1b +e1c +e1d +e1e +e1f +e1g +e1h +e1j +e1k +e1l +e1m +e1n +e1o +e1p +e1q +e1r +e1s +e1t +e1v +e1w +e1x +e1y +e1z +e2\~n. +e2b. +e2c. +e2d. +e2f. +e2g. +e2h. +e2j. +e2k. +e2l. +e2m. +e2n. +e2p. +e2q. +e2r. +e2s. +e2t. +e2v. +e2w. +e2x. +e2y. +e2z. +i1\~n +i1b +i1c +i1d +i1f +i1g +i1h +i1j +i1k +i1l +i1m +i1n +i1p +i1q +i1r +i1s +i1t +i1v +i1w +i1x +i1y +i1z +i2\~n. +i2b. +i2c. +i2d. +i2f. +i2g. +i2h. +i2j. +i2k. +i2l. +i2m. +i2n. +i2p. +i2q. +i2r. +i2s. +i2t. +i2v. +i2w. +i2x. +i2y. +i2z. +o1\'a +o1\'e +o1\'i +o1\'o +o1\'u +o1\~n +o1a +o1b +o1c +o1d +o1e +o1f +o1g +o1h +o1j +o1k +o1l +o1m +o1n +o1o +o1p +o1q +o1r +o1s +o1t +o1v +o1w +o1x +o1y +o1z +o2\~n. +o2b. +o2c. +o2d. +o2f. +o2g. +o2h. +o2j. +o2k. +o2l. +o2m. +o2n. +o2p. +o2q. +o2r. +o2s. +o2t. +o2v. +o2w. +o2x. +o2y. +o2z. +u1\~n +u1b +u1c +u1d +u1f +u1g +u1h +u1j +u1k +u1l +u1m +u1n +u1p +u1q +u1r +u1s +u1t +u1v +u1w +u1x +u1y +u1z +u2\~n. +u2b. +u2c. +u2d. +u2f. +u2g. +u2h. +u2j. +u2k. +u2l. +u2m. +u2n. +u2p. +u2q. +u2r. +u2s. +u2t. +u2v. +u2w. +u2x. +u2y. +u2z. diff --git a/src/vendormodules/textutil/expander-1.3.1.tm b/src/vendormodules/textutil/expander-1.3.1.tm new file mode 100644 index 00000000..9ce76d84 --- /dev/null +++ b/src/vendormodules/textutil/expander-1.3.1.tm @@ -0,0 +1,1122 @@ +#--------------------------------------------------------------------- +# TITLE: +# expander.tcl +# +# AUTHOR: +# Will Duquette +# +# DESCRIPTION: +# +# An expander is an object that takes as input text with embedded +# Tcl code and returns text with the embedded code expanded. The +# text can be provided all at once or incrementally. +# +# See expander.[e]html for usage info. +# Also expander.n +# +# LICENSE: +# Copyright (C) 2001 by William H. Duquette. See expander_license.txt, +# distributed with this file, for license information. +# +# CHANGE LOG: +# +# 10/31/01: V0.9 code is complete. +# 11/23/01: Added "evalcmd"; V1.0 code is complete. + +# Provide the package. + +# Create the package's namespace. + +namespace eval ::textutil { + namespace eval expander { + # All indices are prefixed by "$exp-". + # + # lb The left bracket sequence + # rb The right bracket sequence + # errmode How to handle macro errors: + # nothing, macro, error, fail. + # evalcmd The evaluation command. + # textcmd The plain text processing command. + # level The context level + # output-$level The accumulated text at this context level. + # name-$level The tag name of this context level + # data-$level-$var A variable of this context level + + variable Info + + # In methods, the current object: + variable This "" + + # Export public commands + namespace export expander + } + + #namespace import expander::* + namespace export expander + + proc expander {name} {uplevel ::textutil::expander::expander [list $name]} +} + +#--------------------------------------------------------------------- +# FUNCTION: +# expander name +# +# INPUTS: +# name A proc name for the new object. If not +# fully-qualified, it is assumed to be relative +# to the caller's namespace. +# +# RETURNS: +# nothing +# +# DESCRIPTION: +# Creates a new expander object. + +proc ::textutil::expander::expander {name} { + variable Info + + # FIRST, qualify the name. + if {![string match "::*" $name]} { + # Get caller's namespace; append :: if not global namespace. + set ns [uplevel 1 namespace current] + if {"::" != $ns} { + append ns "::" + } + + set name "$ns$name" + } + + # NEXT, Check the name + if {"" != [info commands $name]} { + return -code error "command name \"$name\" already exists" + } + + # NEXT, Create the object. + proc $name {method args} [format { + if {[catch {::textutil::expander::Methods %s $method $args} result]} { + return -code error $result + } else { + return $result + } + } $name] + + # NEXT, Initialize the object + Op_reset $name + + return $name +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Methods name method argList +# +# INPUTS: +# name The object's fully qualified procedure name. +# This argument is provided by the object command +# itself. +# method The method to call. +# argList Arguments for the specific method. +# +# RETURNS: +# Depends on the method +# +# DESCRIPTION: +# Handles all method dispatch for a expander object. +# The expander's object command merely passes its arguments to +# this function, which dispatches the arguments to the +# appropriate method procedure. If the method raises an error, +# the method procedure's name in the error message is replaced +# by the object and method names. + +proc ::textutil::expander::Methods {name method argList} { + variable Info + variable This + + switch -exact -- $method { + expand - + lb - + rb - + setbrackets - + errmode - + evalcmd - + textcmd - + cpush - + ctopandclear - + cis - + cname - + cset - + cget - + cvar - + cpop - + cappend - + where - + reset { + # FIRST, execute the method, first setting This to the object + # name; then, after the method has been called, restore the + # old object name. + set oldThis $This + set This $name + + set retval [catch "Op_$method $name $argList" result] + + set This $oldThis + + # NEXT, handle the result based on the retval. + if {$retval} { + regsub -- "Op_$method" $result "$name $method" result + return -code error $result + } else { + return $result + } + } + default { + return -code error "\"$name $method\" is not defined" + } + } +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Get key +# +# INPUTS: +# key A key into the Info array, excluding the +# object name. E.g., "lb" +# +# RETURNS: +# The value from the array +# +# DESCRIPTION: +# Gets the value of an entry from Info for This. + +proc ::textutil::expander::Get {key} { + variable Info + variable This + + return $Info($This-$key) +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Set key value +# +# INPUTS: +# key A key into the Info array, excluding the +# object name. E.g., "lb" +# +# value A Tcl value +# +# RETURNS: +# The value +# +# DESCRIPTION: +# Sets the value of an entry in Info for This. + +proc ::textutil::expander::Set {key value} { + variable Info + variable This + + return [set Info($This-$key) $value] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Var key +# +# INPUTS: +# key A key into the Info array, excluding the +# object name. E.g., "lb" +# +# RETURNS: +# The full variable name, suitable for setting or lappending + +proc ::textutil::expander::Var {key} { + variable Info + variable This + + return ::textutil::expander::Info($This-$key) +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Contains list value +# +# INPUTS: +# list any list +# value any value +# +# RETURNS: +# TRUE if the list contains the value, and false otherwise. + +proc ::textutil::expander::Contains {list value} { + if {[lsearch -exact $list $value] == -1} { + return 0 + } else { + return 1 + } +} + + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_lb ?newbracket? +# +# INPUTS: +# newbracket If given, the new bracket token. +# +# RETURNS: +# The current left bracket +# +# DESCRIPTION: +# Returns the current left bracket token. + +proc ::textutil::expander::Op_lb {name {newbracket ""}} { + if {[string length $newbracket] != 0} { + Set lb $newbracket + } + return [Get lb] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_rb ?newbracket? +# +# INPUTS: +# newbracket If given, the new bracket token. +# +# RETURNS: +# The current left bracket +# +# DESCRIPTION: +# Returns the current left bracket token. + +proc ::textutil::expander::Op_rb {name {newbracket ""}} { + if {[string length $newbracket] != 0} { + Set rb $newbracket + } + return [Get rb] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_setbrackets lbrack rbrack +# +# INPUTS: +# lbrack The new left bracket +# rbrack The new right bracket +# +# RETURNS: +# nothing +# +# DESCRIPTION: +# Sets the brackets as a pair. + +proc ::textutil::expander::Op_setbrackets {name lbrack rbrack} { + Set lb $lbrack + Set rb $rbrack + return +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_errmode ?newErrmode? +# +# INPUTS: +# newErrmode If given, the new error mode. +# +# RETURNS: +# The current error mode +# +# DESCRIPTION: +# Returns the current error mode. + +proc ::textutil::expander::Op_errmode {name {newErrmode ""}} { + if {[string length $newErrmode] != 0} { + if {![Contains "macro nothing error fail" $newErrmode]} { + error "$name errmode: Invalid error mode: $newErrmode" + } + + Set errmode $newErrmode + } + return [Get errmode] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_evalcmd ?newEvalCmd? +# +# INPUTS: +# newEvalCmd If given, the new eval command. +# +# RETURNS: +# The current eval command +# +# DESCRIPTION: +# Returns the current eval command. This is the command used to +# evaluate macros; it defaults to "uplevel #0". + +proc ::textutil::expander::Op_evalcmd {name {newEvalCmd ""}} { + if {[string length $newEvalCmd] != 0} { + Set evalcmd $newEvalCmd + } + return [Get evalcmd] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_textcmd ?newTextCmd? +# +# INPUTS: +# newTextCmd If given, the new text command. +# +# RETURNS: +# The current text command +# +# DESCRIPTION: +# Returns the current text command. This is the command used to +# process plain text. It defaults to {}, meaning identity. + +proc ::textutil::expander::Op_textcmd {name args} { + switch -exact [llength $args] { + 0 {} + 1 {Set textcmd [lindex $args 0]} + default { + return -code error "wrong#args for textcmd: name ?newTextcmd?" + } + } + return [Get textcmd] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_reset +# +# INPUTS: +# none +# +# RETURNS: +# nothing +# +# DESCRIPTION: +# Resets all object values, as though it were brand new. + +proc ::textutil::expander::Op_reset {name} { + variable Info + + if {[info exists Info($name-lb)]} { + foreach elt [array names Info "$name-*"] { + unset Info($elt) + } + } + + set Info($name-lb) "\[" + set Info($name-rb) "\]" + set Info($name-errmode) "fail" + set Info($name-evalcmd) "uplevel #0" + set Info($name-textcmd) "" + set Info($name-level) 0 + set Info($name-output-0) "" + set Info($name-name-0) ":0" + + return +} + +#------------------------------------------------------------------------- +# Context: Every expansion takes place in its own context; however, +# a macro can push a new context, causing the text it returns and all +# subsequent text to be saved separately. Later, a matching macro can +# pop the context, acquiring all text saved since the first command, +# and use that in its own output. + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_cpush cname +# +# INPUTS: +# cname The context name +# +# RETURNS: +# nothing +# +# DESCRIPTION: +# Pushes an empty macro context onto the stack. All expanded text +# will be added to this context until it is popped. + +proc ::textutil::expander::Op_cpush {name cname} { + # FRINK: nocheck + incr [Var level] + # FRINK: nocheck + set [Var output-[Get level]] {} + # FRINK: nocheck + set [Var name-[Get level]] $cname + + # The first level is init'd elsewhere (Op_expand) + if {[set [Var level]] < 2} return + + # Initialize the location information, inherit from the outer + # context. + + LocInit $cname + catch {LocSet $cname [LocGet $name]} + return +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_cis cname +# +# INPUTS: +# cname A context name +# +# RETURNS: +# true or false +# +# DESCRIPTION: +# Returns true if the current context has the specified name, and +# false otherwise. + +proc ::textutil::expander::Op_cis {name cname} { + return [expr {[string compare $cname [Op_cname $name]] == 0}] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_cname +# +# INPUTS: +# none +# +# RETURNS: +# The context name +# +# DESCRIPTION: +# Returns the name of the current context. + +proc ::textutil::expander::Op_cname {name} { + return [Get name-[Get level]] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_cset varname value +# +# INPUTS: +# varname The name of a context variable +# value The new value for the context variable +# +# RETURNS: +# The value +# +# DESCRIPTION: +# Sets a variable in the current context. + +proc ::textutil::expander::Op_cset {name varname value} { + Set data-[Get level]-$varname $value +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_cget varname +# +# INPUTS: +# varname The name of a context variable +# +# RETURNS: +# The value +# +# DESCRIPTION: +# Returns the value of a context variable. It's an error if +# the variable doesn't exist. + +proc ::textutil::expander::Op_cget {name varname} { + if {![info exists [Var data-[Get level]-$varname]]} { + error "$name cget: $varname doesn't exist in this context ([Get level])" + } + return [Get data-[Get level]-$varname] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_cvar varname +# +# INPUTS: +# varname The name of a context variable +# +# RETURNS: +# The index to the variable +# +# DESCRIPTION: +# Returns the index to a context variable, for use with set, +# lappend, etc. + +proc ::textutil::expander::Op_cvar {name varname} { + if {![info exists [Var data-[Get level]-$varname]]} { + error "$name cvar: $varname doesn't exist in this context" + } + + return [Var data-[Get level]-$varname] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_cpop cname +# +# INPUTS: +# cname The expected context name. +# +# RETURNS: +# The accumulated output in this context +# +# DESCRIPTION: +# Returns the accumulated output for the current context, first +# popping the context from the stack. The expected context name +# must match the real name, or an error occurs. + +proc ::textutil::expander::Op_cpop {name cname} { + variable Info + + if {[Get level] == 0} { + error "$name cpop underflow on '$cname'" + } + + if {[string compare [Op_cname $name] $cname] != 0} { + error "$name cpop context mismatch: expected [Op_cname $name], got $cname" + } + + set result [Get output-[Get level]] + # FRINK: nocheck + set [Var output-[Get level]] "" + # FRINK: nocheck + set [Var name-[Get level]] "" + + foreach elt [array names "Info data-[Get level]-*"] { + unset Info($elt) + } + + # FRINK: nocheck + incr [Var level] -1 + return $result +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_ctopandclear +# +# INPUTS: +# None. +# +# RETURNS: +# The accumulated output in the topmost context, clears the context, +# but does not pop it. +# +# DESCRIPTION: +# Returns the accumulated output for the current context, first +# popping the context from the stack. The expected context name +# must match the real name, or an error occurs. + +proc ::textutil::expander::Op_ctopandclear {name} { + variable Info + + if {[Get level] == 0} { + error "$name cpop underflow on '[Op_cname $name]'" + } + + set result [Get output-[Get level]] + Set output-[Get level] "" + return $result +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_cappend text +# +# INPUTS: +# text Text to add to the output +# +# RETURNS: +# The accumulated output +# +# DESCRIPTION: +# Appends the text to the accumulated output in the current context. + +proc ::textutil::expander::Op_cappend {name text} { + # FRINK: nocheck + append [Var output-[Get level]] $text +} + +#------------------------------------------------------------------------- +# Macro-expansion: The following code is the heart of the module. +# Given a text string, and the current variable settings, this code +# returns an expanded string, with all macros replaced. + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_expand inputString ?brackets? +# +# INPUTS: +# inputString The text to expand. +# brackets A list of two bracket tokens. +# +# RETURNS: +# The expanded text. +# +# DESCRIPTION: +# Finds all embedded macros in the input string, and expands them. +# If ?brackets? is given, it must be list of length 2, containing +# replacement left and right macro brackets; otherwise the default +# brackets are used. + +proc ::textutil::expander::Op_expand {name inputString {brackets ""}} { + # FIRST, push a new context onto the stack, and save the current + # brackets. + + Op_cpush $name expand + Op_cset $name lb [Get lb] + Op_cset $name rb [Get rb] + + # Keep position information in context variables as well. + # Line we are in, counting from 1; column we are at, + # counting from 0, and index of character we are at, + # counting from 0. Tabs counts as '1' when computing + # the column. + + LocInit $name + + # SF Tcllib Bug #530056. + set start_level [Get level] ; # remember this for check at end + + # NEXT, use the user's brackets, if given. + if {[llength $brackets] == 2} { + Set lb [lindex $brackets 0] + Set rb [lindex $brackets 1] + } + + # NEXT, loop over the string, finding and expanding macros. + while {[string length $inputString] > 0} { + set plainText [ExtractToToken inputString [Get lb] exclude] + + # FIRST, If there was plain text, append it to the output, and + # continue. + if {$plainText != ""} { + set input $plainText + set tc [Get textcmd] + if {[string length $tc] > 0} { + lappend tc $plainText + + if {![catch "[Get evalcmd] [list $tc]" result]} { + set plainText $result + } else { + HandleError $name {plain text} $tc $result + } + } + Op_cappend $name $plainText + LocUpdate $name $input + + if {[string length $inputString] == 0} { + break + } + } + + # NEXT, A macro is the next thing; process it. + if {[catch {GetMacro inputString} macro]} { + # SF tcllib bug 781973 ... Do not throw a regular + # error. Use HandleError to give the user control of the + # situation, via the defined error mode. The continue + # intercepts if the user allows the expansion to run on, + # yet we must not try to run the non-existing macro. + + HandleError $name {reading macro} $inputString $macro + continue + } + + # Expand the macro, and output the result, or + # handle an error. + if {![catch "[Get evalcmd] [list $macro]" result]} { + Op_cappend $name $result + + # We have to advance the location by the length of the + # macro, plus the two brackets. They were stripped by + # GetMacro, so we have to add them here again to make + # computation correct. + + LocUpdate $name [Get lb]${macro}[Get rb] + continue + } + + HandleError $name macro $macro $result + } + + # SF Tcllib Bug #530056. + if {[Get level] > $start_level} { + # The user macros pushed additional contexts, but forgot to + # pop them all. The main work here is to place all the still + # open contexts into the error message, and to produce + # syntactically correct english. + + set c [list] + set n [expr {[Get level] - $start_level}] + if {$n == 1} { + set ctx context + set verb was + } else { + set ctx contexts + set verb were + } + for {incr n -1} {$n >= 0} {incr n -1} { + lappend c [Get name-[expr {[Get level]-$n}]] + } + return -code error \ + "The following $ctx pushed by the macros $verb not popped: [join $c ,]." + } elseif {[Get level] < $start_level} { + set n [expr {$start_level - [Get level]}] + if {$n == 1} { + set ctx context + } else { + set ctx contexts + } + return -code error \ + "The macros popped $n more $ctx than they had pushed." + } + + Op_lb $name [Op_cget $name lb] + Op_rb $name [Op_cget $name rb] + + return [Op_cpop $name expand] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# Op_where +# +# INPUTS: +# None. +# +# RETURNS: +# The current location in the input. +# +# DESCRIPTION: +# Retrieves the current location the expander +# is at during processing. + +proc ::textutil::expander::Op_where {name} { + return [LocGet $name] +} + +#--------------------------------------------------------------------- +# FUNCTION +# HandleError name title command errmsg +# +# INPUTS: +# name The name of the expander object in question. +# title A title text +# command The command which caused the error. +# errmsg The error message to report +# +# RETURNS: +# Nothing +# +# DESCRIPTIONS +# Is executed when an error in a macro or the plain text handler +# occurs. Generates an error message according to the current +# error mode. + +proc ::textutil::expander::HandleError {name title command errmsg} { + switch [Get errmode] { + nothing { } + macro { + # The location is irrelevant here. + Op_cappend $name "[Get lb]$command[Get rb]" + } + error { + foreach {ch line col} [LocGet $name] break + set display [DisplayOf $command] + + Op_cappend $name "\n=================================\n" + Op_cappend $name "*** Error in $title at line $line, column $col:\n" + Op_cappend $name "*** [Get lb]$display[Get rb]\n--> $errmsg\n" + Op_cappend $name "=================================\n" + } + fail { + foreach {ch line col} [LocGet $name] break + set display [DisplayOf $command] + + return -code error "Error in $title at line $line,\ + column $col:\n[Get lb]$display[Get rb]\n-->\ + $errmsg" + } + default { + return -code error "Unknown error mode: [Get errmode]" + } + } +} + +#--------------------------------------------------------------------- +# FUNCTION: +# ExtractToToken string token mode +# +# INPUTS: +# string The text to process. +# token The token to look for +# mode include or exclude +# +# RETURNS: +# The extracted text +# +# DESCRIPTION: +# Extract text from a string, up to or including a particular +# token. Remove the extracted text from the string. +# mode determines whether the found token is removed; +# it should be "include" or "exclude". The string is +# modified in place, and the extracted text is returned. + +proc ::textutil::expander::ExtractToToken {string token mode} { + upvar $string theString + + # First, determine the offset + switch $mode { + include { set offset [expr {[string length $token] - 1}] } + exclude { set offset -1 } + default { error "::expander::ExtractToToken: unknown mode $mode" } + } + + # Next, find the first occurrence of the token. + set tokenPos [string first $token $theString] + + # Next, return the entire string if it wasn't found, or just + # the part upto or including the character. + if {$tokenPos == -1} { + set theText $theString + set theString "" + } else { + set newEnd [expr {$tokenPos + $offset}] + set newBegin [expr {$newEnd + 1}] + set theText [string range $theString 0 $newEnd] + set theString [string range $theString $newBegin end] + } + + return $theText +} + +#--------------------------------------------------------------------- +# FUNCTION: +# GetMacro string +# +# INPUTS: +# string The text to process. +# +# RETURNS: +# The macro, stripped of its brackets. +# +# DESCRIPTION: + +proc ::textutil::expander::GetMacro {string} { + upvar $string theString + + # FIRST, it's an error if the string doesn't begin with a + # bracket. + if {[string first [Get lb] $theString] != 0} { + error "::expander::GetMacro: assertion failure, next text isn't a command! '$theString'" + } + + # NEXT, extract a full macro + set macro [ExtractToToken theString [Get lb] include] + while {[string length $theString] > 0} { + append macro [ExtractToToken theString [Get rb] include] + + # Verify that the command really ends with the [rb] characters, + # whatever they are. If not, break because of unexpected + # end of file. + if {![IsBracketed $macro]} { + break; + } + + set strippedMacro [StripBrackets $macro] + + if {[info complete "puts \[$strippedMacro\]"]} { + return $strippedMacro + } + } + + if {[string length $macro] > 40} { + set macro "[string range $macro 0 39]...\n" + } + error "Unexpected EOF in macro:\n$macro" +} + +# Strip left and right bracket tokens from the ends of a macro, +# provided that it's properly bracketed. +proc ::textutil::expander::StripBrackets {macro} { + set llen [string length [Get lb]] + set rlen [string length [Get rb]] + set tlen [string length $macro] + + return [string range $macro $llen [expr {$tlen - $rlen - 1}]] +} + +# Return 1 if the macro is properly bracketed, and 0 otherwise. +proc ::textutil::expander::IsBracketed {macro} { + set llen [string length [Get lb]] + set rlen [string length [Get rb]] + set tlen [string length $macro] + + set leftEnd [string range $macro 0 [expr {$llen - 1}]] + set rightEnd [string range $macro [expr {$tlen - $rlen}] end] + + if {$leftEnd != [Get lb]} { + return 0 + } elseif {$rightEnd != [Get rb]} { + return 0 + } else { + return 1 + } +} + +#--------------------------------------------------------------------- +# FUNCTION: +# LocInit name +# +# INPUTS: +# name The expander object to use. +# +# RETURNS: +# No result. +# +# DESCRIPTION: +# A convenience wrapper around LocSet. Initializes the location +# to the start of the input (char 0, line 1, column 0). + +proc ::textutil::expander::LocInit {name} { + LocSet $name {0 1 0} + return +} + +#--------------------------------------------------------------------- +# FUNCTION: +# LocSet name loc +# +# INPUTS: +# name The expander object to use. +# loc Location, list containing character position, +# line number and column, in this order. +# +# RETURNS: +# No result. +# +# DESCRIPTION: +# Sets the current location in the expander to 'loc'. + +proc ::textutil::expander::LocSet {name loc} { + foreach {ch line col} $loc break + Op_cset $name char $ch + Op_cset $name line $line + Op_cset $name col $col + return +} + +#--------------------------------------------------------------------- +# FUNCTION: +# LocGet name +# +# INPUTS: +# name The expander object to use. +# +# RETURNS: +# A list containing the current character position, line number +# and column, in this order. +# +# DESCRIPTION: +# Returns the current location as stored in the expander. + +proc ::textutil::expander::LocGet {name} { + list [Op_cget $name char] [Op_cget $name line] [Op_cget $name col] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# LocUpdate name text +# +# INPUTS: +# name The expander object to use. +# text The text to process. +# +# RETURNS: +# No result. +# +# DESCRIPTION: +# Takes the current location as stored in the expander, computes +# a new location based on the string (its length and contents +# (number of lines)), and makes that new location the current +# location. + +proc ::textutil::expander::LocUpdate {name text} { + foreach {ch line col} [LocGet $name] break + set numchars [string length $text] + #8.4+ set numlines [regexp -all "\n" $text] + set numlines [expr {[llength [split $text \n]]-1}] + + incr ch $numchars + incr line $numlines + if {$numlines} { + set col [expr {$numchars - [string last \n $text] - 1}] + } else { + incr col $numchars + } + + LocSet $name [list $ch $line $col] + return +} + +#--------------------------------------------------------------------- +# FUNCTION: +# LocRange name text +# +# INPUTS: +# name The expander object to use. +# text The text to process. +# +# RETURNS: +# A text range description, compatible with the 'location' data +# used in the tcl debugger/checker. +# +# DESCRIPTION: +# Takes the current location as stored in the expander object +# and the length of the text to generate a character range. + +proc ::textutil::expander::LocRange {name text} { + # Note that the structure is compatible with + # the ranges uses by tcl debugger and checker. + # {line {charpos length}} + + foreach {ch line col} [LocGet $name] break + return [list $line [list $ch [string length $text]]] +} + +#--------------------------------------------------------------------- +# FUNCTION: +# DisplayOf text +# +# INPUTS: +# text The text to process. +# +# RETURNS: +# The text, cut down to at most 30 bytes. +# +# DESCRIPTION: +# Cuts the incoming text down to contain no more than 30 +# characters of the input. Adds an ellipsis (...) if characters +# were actually removed from the input. + +proc ::textutil::expander::DisplayOf {text} { + set ellip "" + while {[string bytelength $text] > 30} { + set ellip ... + set text [string range $text 0 end-1] + } + set display $text$ellip +} + +#--------------------------------------------------------------------- +# Provide the package only if the code above was read and executed +# without error. + +package provide textutil::expander 1.3.1 diff --git a/src/vendormodules/textutil/ithyph.tex b/src/vendormodules/textutil/ithyph.tex new file mode 100644 index 00000000..755e1085 --- /dev/null +++ b/src/vendormodules/textutil/ithyph.tex @@ -0,0 +1,223 @@ + +%%%%%%%%%%%%%%%%%%%% file ithyph.tex + +%%%%%%%%%%%%%%%%%%%%%%%%%%% file ithyph.tex %%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% +% Prepared by Claudio Beccari e-mail beccari@polito.it +% +% Dipartimento di Elettronica +% Politecnico di Torino +% Corso Duca degli Abruzzi, 24 +% 10129 TORINO +% +% Copyright 1998, 2001 Claudio Beccari +% +% This program can be redistributed and/or modified under the terms +% of the LaTeX Project Public License Distributed from CTAN +% archives in directory macros/latex/base/lppl.txt; either +% version 1 of the License, or any later version. +% +% \versionnumber{4.8d} \versiondate{2001/11/21} +% +% These hyphenation patterns for the Italian language are supposed to comply +% with the Reccomendation UNI 6461 on hyphenation issued by the Italian +% Standards Institution (Ente Nazionale di Unificazione UNI). No guarantee +% or declaration of fitness to any particular purpose is given and any +% liability is disclaimed. +% +% See comments and loading instructions at the end of the file after the +% \endinput line +% +{\lccode`\'=`\' % Apostrophe has its own lccode so that it is treated + % as a letter + %>> 1998/04/14 inserted grouping + % +%\lccode23=23 % Compound word mark is a letter in encoding T1 +%\def\W{^^W} % ^^W =\char23 = \char"17 =\char'27 +% +\patterns{ +.a3p2n % After the Garzanti dictionary: a-pnea, a-pnoi-co,... +.anti1 .anti3m2n +.bio1 +.ca4p3s +.circu2m1 +.di2s3cine +%.e2x +.fran2k3 +.free3 +.narco1 +.opto1 +.orto3p2 +.para1 +.poli3p2 +.pre1 +.p2s +%.ri1a2 .ri1e2 .re1i2 .ri1o2 .ri1u2 +.sha2re3 +.tran2s3c .tran2s3d .tran2s3f .tran2s3l .tran2s3n .tran2s3p .tran2s3r .tran2s3t +.su2b3lu .su2b3r +.wa2g3n +.wel2t1 +a1ia a1ie a1io a1iu a1uo a1ya 2at. +e1iu e2w +o1ia o1ie o1io o1iu +%u1u +% +%1\W0a2 1\W0e2 1\W0i2 1\W0o2 1\W0u2 +'2 +1b 2bb 2bc 2bd 2bf 2bm 2bn 2bp 2bs 2bt 2bv + b2l b2r 2b. 2b'. 2b'' +1c 2cb 2cc 2cd 2cf 2ck 2cm 2cn 2cq 2cs 2ct 2cz + 2chh c2h 2chb ch2r 2chn c2l c2r 2c. 2c'. 2c'' .c2 +1d 2db 2dd 2dg 2dl 2dm 2dn 2dp d2r 2ds 2dt 2dv 2dw + 2d. 2d'. 2d'' .d2 +1f 2fb 2fg 2ff 2fn f2l f2r 2fs 2ft 2f. 2f'. 2f'' +1g 2gb 2gd 2gf 2gg g2h g2l 2gm g2n 2gp g2r 2gs 2gt + 2gv 2gw 2gz 2gh2t 2g. 2g'. 2g'' +1h 2hb 2hd 2hh hi3p2n h2l 2hm 2hn 2hr 2hv 2h. 2h'. 2h'' +1j 2j. 2j'. 2j'' +1k 2kg 2kf k2h 2kk k2l 2km k2r 2ks 2kt 2k. 2k'. 2k'' +1l 2lb 2lc 2ld 2l3f2 2lg l2h 2lk 2ll 2lm 2ln 2lp + 2lq 2lr 2ls 2lt 2lv 2lw 2lz 2l. 2l'. 2l'' +1m 2mb 2mc 2mf 2ml 2mm 2mn 2mp 2mq 2mr 2ms 2mt 2mv 2mw + 2m. 2m'. 2m'' +1n 2nb 2nc 2nd 2nf 2ng 2nk 2nl 2nm 2nn 2np 2nq 2nr + 2ns 2nt 2nv 2nz n2g3n 2nheit. 2n. 2n' 2n'' +1p 2pd p2h p2l 2pn 3p2ne 2pp p2r 2ps 3p2sic 2pt 2pz 2p. 2p'. 2p'' +1q 2qq 2q. 2q'. 2q'' +1r 2rb 2rc 2rd 2rf r2h 2rg 2rk 2rl 2rm 2rn 2rp + 2rq 2rr 2rs 2rt rt2s3 2rv 2rx 2rw 2rz 2r. 2r'. 2r'' +1s2 2shm 2s3s s4s3m 2s3p2n 2stb 2stc 2std 2stf 2stg 2stm 2stn + 2stp 2sts 2stt 2stv 2sz 4s. 4s'. 4s'' +1t 2tb 2tc 2td 2tf 2tg t2h t2l 2tm 2tn 2tp t2r 2ts + 3t2sch 2tt 2tv 2tw t2z 2tzk 2tzs 2t. 2t'. 2t'' +1v 2vc v2l v2r 2vv 2v. 2v'. 2v'' +1w w2h wa2r 2w1y 2w. 2w'. 2w'' +1x 2xt 2xw 2x. 2x'. 2x'' +y1ou y1i +1z 2zb 2zd 2zl 2zn 2zp 2zt 2zs 2zv 2zz 2z. 2z'. 2z'' .z2 +}} % Pattern end + +\endinput + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Information %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + LOADING THESE PATTERNS + +These patterns, as well as those for any other language, do not become +effective until they are loaded in a special form into a format file; this +task is performed by the TeX initializer; any TeX system has its own +initializer with its special way of being activated. Before loading these +patterns, then, it is necessary to read very carefully the instructions that +come with your TeX system. + +Here I describe how to load the patterns with the freeware TeX system named +MiKTeX version 2.x for Windows 9x, NT, 2000, XP; with minor changes the +whole procedure is applicable with other TeX systems, but the details must +be deduced from your TeX system documentation at the section/chapter "How to +build or to rebuild a format file". + +With MikTeX: + +a) copy this file and replace the existing file ithyph.tex in the directory + \texmf\tex\generic\hyphen if the existing one has an older version date + and number. +b) select Start|Programs|MiKTeX|MiKTeX options. +c) in the Language tab add a check mark to the line concerning the Italian + language. +d) in the Geneal tab click "Update format files". +e) That's all! + +For the activation of these patterns with the specific Italian typesetting +features, use the babel package as this: + +\documentclass{article} % Or whatever other class +\usepackage[italian]{babel} +... +\begin{document} +... +\end{document} + + + ON ITALIAN HYPHENATION + +I have been working on patterns for the Italian language since 1987; in 1992 +I published + +C. Beccari, "Computer aided hyphenation for Italian and Modern + Latin", TUG vol. 13, n. 1, pp. 23-33 (1992) + +which contained a set of patterns that allowed hyphenation for both Italian +and Latin; a slightly modified version of the patterns published in the +above paper is contained in LAHYPH.TEX available on the CTAN archives. + +From the above patterns I extracted the minimum set necessary for +hyphenating Italian that was made available on the CTAN archives with the +name ITHYPH.tex the version number 3.5 on the 16th of August 1994. + +The original pattern set required 37 ops; being interested in a local +version of TeX/LaTeX capable of dealing with half a dozen languages, I +wanted to reduce memory occupation and therefore the number of ops. + +Th new version (4.0 released in 1996) of ITHYPH.TEX is much simpler than +version 3.5 and requires just 29 ops while it retains all the power of +version 3.5; it contains many more new patterns that allow to hyphenate +unusual words that generally have a root borrowed from a foreign language. +Updated versions 4.x contain minor additions and the number of ops is +increased to 30 (version 4.7 of 1998/06/01). + +This new pattern set has been tested with the same set of difficult Italian +words that was used to test version 3.5 and it yields the same results (a +part a minor change that was deliberately introduced so as to reduce the +typographical hyphenation with hyathi, since hyphenated hyathi are not +appreciated by Italian readers). A new enlarged word set for testing +purposes gets correct hyphen points that were missed or wrongly placed with +version 3.5, although no error had been reported, because such words are of +very specialized nature and are seldom used. + +As the previous version, this new set of patterns does not contain any +accented character so that the hyphenation algorithm behaves properly in +both cases, that is with cm and with dc/ec fonts. With LaTeXe terminology +the difference is between OT1 and T1 encodings; with the former encoding +fonts do not contain accented characters, while with the latter accented +characters are present and sequences such as \`a map directly to slot "E0 +that contains "agrave". + +Of course if you use dc/ec fonts (or any other real or virtual font with T1 +encoding) you get the full power of the hyphenation algorithm, while if you +use cm fonts (or any other real or virtual font with OT1 encoding) you miss +some possible break points; this is not a big inconvenience in Italian +because: + +1) The Regulation UNI 6015 on accents specifies that compulsory accents + appear only on the ending vowel of oxitone words; this means that it is + almost indifferent to have or to miss the dc/ec fonts because the only + difference consists in how TeX evaluates the end of the word; in practice + if you have these special facilities you get "qua-li-t\`a", while if you + miss them, you get "qua-lit\`a" (assuming that \righthyphenmin > 1). + +2) Optional accents are so rare in Italian, that if you absolutely want to + use them in those rare instances, and you miss the T1 encoding + facilities, you should also provide explicit discretionary hyphens as in + "s\'e\-gui\-to". + +There is no explicit hyphenation exception list because these patterns +proved to hyphenate correctly a very large set of words suitably chosen in +order to test them in the most heavy circumstances; these patterns were used +in the preparation of a number of books and no errors were discovered. + +Nevertheless if you frequently use technical terms that you want hyphenated +differently from what is normally done (for example if you prefer +etymological hyphenation of prefixed and/or suffixed words) you should +insert a specific hyphenation list in the preamble of your document, for +example: + +\hyphenation{su-per-in-dut-to-re su-per-in-dut-to-ri} + +Should you find any word that gets hyphenated in a wrong way, please, AFTER +CHECKING ON A RELIABLE MODERN DICTIONARY, report to the author, preferably +by e-mail. + + + Happy multilingual typesetting ! diff --git a/src/vendormodules/textutil/patch-0.1.tm b/src/vendormodules/textutil/patch-0.1.tm new file mode 100644 index 00000000..cf68959d --- /dev/null +++ b/src/vendormodules/textutil/patch-0.1.tm @@ -0,0 +1,180 @@ +# patch.tcl -- +# +# Application of a diff -ruN patch to a directory tree. +# +# Copyright (c) 2019 Christian Gollwitzer +# with tweaks by Andreas Kupries +# - Factored patch parsing into a helper +# - Replaced `puts` with report callback. + +package require Tcl 8.5 +package provide textutil::patch 0.1 + +# # ## ### ##### ######## ############# ##################### + +namespace eval ::textutil::patch { + namespace export apply + namespace ensemble create +} + +# # ## ### ##### ######## ############# ##################### + +proc ::textutil::patch::apply {dir striplevel patch reportcmd} { + set patchdict [Parse $dir $striplevel $patch] + + # Apply, now that we have parsed the patch. + dict for {fn hunks} $patchdict { + Report apply $fn + if {[catch {open $fn} fd]} { + set orig {} + } else { + set orig [split [read $fd] \n] + } + close $fd + + set patched $orig + + set fail false + set already_applied false + set hunknr 1 + foreach hunk $hunks { + dict with hunk { + set oldend [expr {$oldstart+[llength $oldcode]-1}] + set newend [expr {$newstart+[llength $newcode]-1}] + # check if the hunk matches + set origcode [lrange $orig $oldstart $oldend] + if {$origcode ne $oldcode} { + set fail true + # check if the patch is already applied + set origcode_applied [lrange $orig $newstart $newend] + if {$origcode_applied eq $newcode} { + set already_applied true + Report fail-already $fn $hunknr + } else { + Report fail $fn $hunknr $oldcode $origcode + } + break + } + # apply patch + set patched [list \ + {*}[lrange $patched 0 $newstart-1] \ + {*}$newcode \ + {*}[lrange $orig $oldend+1 end]] + } + incr hunknr + } + + if {!$fail} { + # success - write the result back + set fd [open $fn w] + puts -nonewline $fd [join $patched \n] + close $fd + } + } + + return +} + +# # ## ### ##### ######## ############# ##################### + +proc ::textutil::patch::Report args { + upvar 1 reportcmd reportcmd + uplevel #0 [list {*}$reportcmd {*}$args] + ## + # apply $fname + # fail-already $fname $hunkno + # fail $fname $hunkno $expected $seen + ## +} + +proc ::textutil::patch::Parse {dir striplevel patch} { + set patchlines [split $patch \n] + set inhunk false + set oldcode {} + set newcode {} + set n [llength $patchlines] + + set patchdict {} + for {set lineidx 0} {$lineidx < $n} {incr lineidx} { + set line [lindex $patchlines $lineidx] + if {[string match ---* $line]} { + # a diff block starts. Current line should be + # --- oldfile date time TZ + # Next line should be + # +++ newfile date time TZ + set in $line + incr lineidx + set out [lindex $patchlines $lineidx] + + if {![string match ---* $in] || ![string match +++* $out]} { + #puts $in + #puts $out + return -code error "Patch not in unified diff format, line $lineidx $in $out" + } + + # the quoting is compatible with list + lassign $in -> oldfile + lassign $out -> newfile + + set fntopatch [file join $dir {*}[lrange [file split $oldfile] $striplevel end]] + set inhunk false + #puts "Found diffline for $fntopatch" + continue + } + + # state machine for parsing the hunks + set typechar [string index $line 0] + set codeline [string range $line 1 end] + switch $typechar { + @ { + if {![regexp {@@\s+\-(\d+),(\d+)\s+\+(\d+),(\d+)\s+@@} $line \ + -> oldstart oldlen newstart newlen]} { + return code -error "Erroneous hunk in line $lindeidx, $line" + } + # adjust line numbers for 0-based indexing + incr oldstart -1 + incr newstart -1 + #puts "New hunk" + set newcode {} + set oldcode {} + set inhunk true + } + - { # line only in old code + if {$inhunk} { + lappend oldcode $codeline + } + } + + { # line only in new code + if {$inhunk} { + lappend newcode $codeline + } + } + " " { # common line + if {$inhunk} { + lappend oldcode $codeline + lappend newcode $codeline + } + } + default { + # puts "Junk: $codeline"; + continue + } + } + # test if the hunk is complete + if {[llength $oldcode]==$oldlen && [llength $newcode]==$newlen} { + set hunk [dict create \ + oldcode $oldcode \ + newcode $newcode \ + oldstart $oldstart \ + newstart $newstart] + #puts "hunk complete: $hunk" + set inhunk false + dict lappend patchdict $fntopatch $hunk + } + } + + return $patchdict +} + +# # ## ### ##### ######## ############# ##################### +return diff --git a/src/vendormodules/textutil/repeat-0.7.tm b/src/vendormodules/textutil/repeat-0.7.tm new file mode 100644 index 00000000..24f8693c --- /dev/null +++ b/src/vendormodules/textutil/repeat-0.7.tm @@ -0,0 +1,91 @@ +# repeat.tcl -- +# +# Emulation of string repeat for older +# revisions of Tcl. +# +# Copyright (c) 2000 by Ajuba Solutions. +# Copyright (c) 2001-2006 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: repeat.tcl,v 1.1 2006/04/21 04:42:28 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.2 + +namespace eval ::textutil::repeat {} + +# ### ### ### ######### ######### ######### + +namespace eval ::textutil::repeat { + variable HaveBuiltin [expr {![catch {string repeat a 1}]}] +} + +if {0} { + # Problems with the deactivated code: + # - Linear in 'num'. + # - Tests for 'string repeat' in every call! + # (Ok, just the variable, still a test every call) + # - Fails for 'num == 0' because of undefined 'str'. + + proc textutil::repeat::StrRepeat { char num } { + variable HaveBuiltin + if { $HaveBuiltin == 0 } then { + for { set i 0 } { $i < $num } { incr i } { + append str $char + } + } else { + set str [ string repeat $char $num ] + } + return $str + } +} + +if {$::textutil::repeat::HaveBuiltin} { + proc ::textutil::repeat::strRepeat {char num} { + return [string repeat $char $num] + } + + proc ::textutil::repeat::blank {n} { + return [string repeat " " $n] + } +} else { + proc ::textutil::repeat::strRepeat {char num} { + if {$num <= 0} { + # No replication required + return "" + } elseif {$num == 1} { + # Quick exit for recursion + return $char + } elseif {$num == 2} { + # Another quick exit for recursion + return $char$char + } elseif {0 == ($num % 2)} { + # Halving the problem results in O (log n) complexity. + set result [strRepeat $char [expr {$num / 2}]] + return "$result$result" + } else { + # Uneven length, reduce problem by one + return "$char[strRepeat $char [incr num -1]]" + } + } + + proc ::textutil::repeat::blank {n} { + return [strRepeat " " $n] + } +} + +# ### ### ### ######### ######### ######### +## Data structures + +namespace eval ::textutil::repeat { + namespace export strRepeat blank +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide textutil::repeat 0.7 diff --git a/src/vendormodules/textutil/split-0.8.tm b/src/vendormodules/textutil/split-0.8.tm new file mode 100644 index 00000000..18ee13b5 --- /dev/null +++ b/src/vendormodules/textutil/split-0.8.tm @@ -0,0 +1,176 @@ +# split.tcl -- +# +# Various ways of splitting a string. +# +# Copyright (c) 2000 by Ajuba Solutions. +# Copyright (c) 2000 by Eric Melski +# Copyright (c) 2001 by Reinhard Max +# Copyright (c) 2003 by Pat Thoyts +# Copyright (c) 2001-2006 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: split.tcl,v 1.7 2006/04/21 04:42:28 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.2 + +namespace eval ::textutil::split {} + +######################################################################## +# This one was written by Bob Techentin (RWT in Tcl'ers Wiki): +# http://www.techentin.net +# mailto:techentin.robert@mayo.edu +# +# Later, he send me an email stated that I can use it anywhere, because +# no copyright was added, so the code is defacto in the public domain. +# +# You can found it in the Tcl'ers Wiki here: +# http://mini.net/cgi-bin/wikit/460.html +# +# Bob wrote: +# If you need to split string into list using some more complicated rule +# than builtin split command allows, use following function. It mimics +# Perl split operator which allows regexp as element separator, but, +# like builtin split, it expects string to split as first arg and regexp +# as second (optional) By default, it splits by any amount of whitespace. +# Note that if you add parenthesis into regexp, parenthesed part of separator +# would be added into list as additional element. Just like in Perl. -- cary +# +# Speed improvement by Reinhard Max: +# Instead of repeatedly copying around the not yet matched part of the +# string, I use [regexp]'s -start option to restrict the match to that +# part. This reduces the complexity from something like O(n^1.5) to +# O(n). My test case for that was: +# +# foreach i {1 10 100 1000 10000} { +# set s [string repeat x $i] +# puts [time {splitx $s .}] +# } +# + +if {[package vsatisfies [package provide Tcl] 8.3]} { + + proc ::textutil::split::splitx {str {regexp {[\t \r\n]+}}} { + # Bugfix 476988 + if {[string length $str] == 0} { + return {} + } + if {[string length $regexp] == 0} { + return [::split $str ""] + } + if {[regexp $regexp {}]} { + return -code error \ + "splitting on regexp \"$regexp\" would cause infinite loop" + } + + set list {} + set start 0 + while {[regexp -start $start -indices -- $regexp $str match submatch]} { + foreach {subStart subEnd} $submatch break + foreach {matchStart matchEnd} $match break + incr matchStart -1 + incr matchEnd + lappend list [string range $str $start $matchStart] + if {$subStart >= $start} { + lappend list [string range $str $subStart $subEnd] + } + set start $matchEnd + } + lappend list [string range $str $start end] + return $list + } + +} else { + # For tcl <= 8.2 we do not have regexp -start... + proc ::textutil::split::splitx [list str [list regexp "\[\t \r\n\]+"]] { + + if {[string length $str] == 0} { + return {} + } + if {[string length $regexp] == 0} { + return [::split $str {}] + } + if {[regexp $regexp {}]} { + return -code error \ + "splitting on regexp \"$regexp\" would cause infinite loop" + } + + set list {} + while {[regexp -indices -- $regexp $str match submatch]} { + lappend list [string range $str 0 [expr {[lindex $match 0] -1}]] + if {[lindex $submatch 0] >= 0} { + lappend list [string range $str [lindex $submatch 0] \ + [lindex $submatch 1]] + } + set str [string range $str [expr {[lindex $match 1]+1}] end] + } + lappend list $str + return $list + } + +} + +# +# splitn -- +# +# splitn splits the string $str into chunks of length $len. These +# chunks are returned as a list. +# +# If $str really contains a ByteArray object (as retrieved from binary +# encoded channels) splitn must honor this by splitting the string +# into chunks of $len bytes. +# +# It is an error to call splitn with a nonpositive $len. +# +# If splitn is called with an empty string, it returns the empty list. +# +# If the length of $str is not an entire multiple of the chunk length, +# the last chunk in the generated list will be shorter than $len. +# +# The implementation presented here was given by Bryan Oakley, as +# part of a ``contest'' I staged on c.l.t in July 2004. I selected +# this version, as it does not rely on runtime generated code, is +# very fast for chunk size one, not too bad in all the other cases, +# and uses [split] or [string range] which have been around for quite +# some time. +# +# -- Robert Suetterlin (robert@mpe.mpg.de) +# +proc ::textutil::split::splitn {str {len 1}} { + + if {$len <= 0} { + return -code error "len must be > 0" + } + + if {$len == 1} { + return [split $str {}] + } + + set result [list] + set max [string length $str] + set i 0 + set j [expr {$len -1}] + while {$i < $max} { + lappend result [string range $str $i $j] + incr i $len + incr j $len + } + + return $result +} + +# ### ### ### ######### ######### ######### +## Data structures + +namespace eval ::textutil::split { + namespace export splitx splitn +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide textutil::split 0.8 diff --git a/src/vendormodules/textutil/string-0.8.tm b/src/vendormodules/textutil/string-0.8.tm new file mode 100644 index 00000000..f1ad5a46 --- /dev/null +++ b/src/vendormodules/textutil/string-0.8.tm @@ -0,0 +1,144 @@ +# string.tcl -- +# +# Utilities for manipulating strings, words, single lines, +# paragraphs, ... +# +# Copyright (c) 2000 by Ajuba Solutions. +# Copyright (c) 2000 by Eric Melski +# Copyright (c) 2002 by Joe English +# Copyright (c) 2001-2014 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: string.tcl,v 1.2 2008/03/22 16:03:11 mic42 Exp $ + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.2 + +namespace eval ::textutil::string {} + +# ### ### ### ######### ######### ######### +## API implementation + +# @c Removes the last character from the given . +# +# @a string: The string to manipulate. +# +# @r The without its last character. +# +# @i chopping + +proc ::textutil::string::chop {string} { + return [string range $string 0 [expr {[string length $string]-2}]] +} + +# @c Removes the first character from the given . +# @c Convenience procedure. +# +# @a string: string to manipulate. +# +# @r The without its first character. +# +# @i tail + +proc ::textutil::string::tail {string} { + return [string range $string 1 end] +} + +# @c Capitalizes first character of the given . +# @c Complementary procedure to

. +# +# @a string: string to manipulate. +# +# @r The with its first character capitalized. +# +# @i capitalize + +proc ::textutil::string::cap {string} { + return [string toupper [string index $string 0]][string range $string 1 end] +} + +# @c unCapitalizes first character of the given . +# @c Complementary procedure to

. +# +# @a string: string to manipulate. +# +# @r The with its first character uncapitalized. +# +# @i uncapitalize + +proc ::textutil::string::uncap {string} { + return [string tolower [string index $string 0]][string range $string 1 end] +} + +# @c Capitalizes first character of each word of the given . +# +# @a sentence: string to manipulate. +# +# @r The with the first character of each word capitalized. +# +# @i capitalize + +proc ::textutil::string::capEachWord {sentence} { + regsub -all {\S+} [string map {\\ \\\\ \$ \\$} $sentence] {[string toupper [string index & 0]][string range & 1 end]} cmd + return [subst -nobackslashes -novariables $cmd] +} + +# Compute the longest string which is common to all strings given to +# the command, and at the beginning of said strings, i.e. a prefix. If +# only one argument is specified it is treated as a list of the +# strings to look at. If more than one argument is specified these +# arguments are the strings to be looked at. If only one string is +# given, in either form, the string is returned, as it is its own +# longest common prefix. + +proc ::textutil::string::longestCommonPrefix {args} { + return [longestCommonPrefixList $args] +} + +proc ::textutil::string::longestCommonPrefixList {list} { + if {[llength $list] <= 1} { + return [lindex $list 0] + } + + set list [lsort $list] + set min [lindex $list 0] + set max [lindex $list end] + + # Min and max are the two strings which are most different. If + # they have a common prefix, it will also be the common prefix for + # all of them. + + # Fast bailouts for common cases. + + set n [string length $min] + if {$n == 0} {return ""} + if {0 == [string compare $min $max]} {return $min} + + set prefix "" + set i 0 + while {[string index $min $i] == [string index $max $i]} { + append prefix [string index $min $i] + if {[incr i] > $n} {break} + } + set prefix +} + +# ### ### ### ######### ######### ######### +## Data structures + +namespace eval ::textutil::string { + # Export the imported commands + + namespace export chop tail cap uncap capEachWord + namespace export longestCommonPrefix + namespace export longestCommonPrefixList +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide textutil::string 0.8 diff --git a/src/vendormodules/textutil/tabify-0.7.tm b/src/vendormodules/textutil/tabify-0.7.tm new file mode 100644 index 00000000..543b96cc --- /dev/null +++ b/src/vendormodules/textutil/tabify-0.7.tm @@ -0,0 +1,289 @@ +# +# As the author of the procs 'tabify2' and 'untabify2' I suggest that the +# comments explaining their behaviour be kept in this file. +# 1) Beginners in any programming language (I am new to Tcl so I know what I +# am talking about) can profit enormously from studying 'correct' code. +# Of course comments will help a lot in this regard. +# 2) Many problems newbies face can be solved by directing them towards +# available libraries - after all, libraries have been written to solve +# recurring problems. Then they can just use them, or have a closer look +# to see and to discover how things are done the 'Tcl way'. +# 3) And if ever a proc from a library should be less than perfect, having +# comments explaining the behaviour of the code will surely help. +# +# This said, I will welcome any error reports or suggestions for improvements +# (especially on the 'doing things the Tcl way' aspect). +# +# Use of these sources is licensed under the same conditions as is Tcl. +# +# June 2001, Helmut Giese (hgiese@ratiosoft.com) +# +# ---------------------------------------------------------------------------- +# +# The original procs 'tabify' and 'untabify' each work with complete blocks +# of $num spaces ('num' holding the tab size). While this is certainly useful +# in some circumstances, it does not reflect the way an editor works: +# Counting columns from 1, assuming a tab size of 8 and entering '12345' +# followed by a tab, you expect to advance to column 9. Your editor might +# put a tab into the file or 3 spaces, depending on its configuration. +# Now, on 'tabifying' you will expect to see those 3 spaces converted to a +# tab (and on the other hand expect the tab *at this position* to be +# converted to 3 spaces). +# +# This behaviour is mimicked by the new procs 'tabify2' and 'untabify2'. +# Both have one feature in common: They accept multi-line strings (a whole +# file if you want to) but in order to make life simpler for the programmer, +# they split the incoming string into individual lines and hand each line to +# a proc that does the real work. +# +# One design decision worth mentioning here: +# A single space is never converted to a tab even if its position would +# allow to do so. +# Single spaces occur very often, say in arithmetic expressions like +# [expr (($a + $b) * $c) < $d]. If we didn't follow the above rule we might +# need to replace one or more of them to tabs. However if the tab size gets +# changed, this expression would be formatted quite differently - which is +# probably not a good idea. +# +# 'untabifying' on the other hand might need to replace a tab with a single +# space: If the current position requires it, what else to do? +# As a consequence those two procs are unsymmetric in this aspect, but I +# couldn't think of a better solution. Could you? +# +# ---------------------------------------------------------------------------- +# + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.2 +package require textutil::repeat + +namespace eval ::textutil::tabify {} + +# ### ### ### ######### ######### ######### +## API implementation + +namespace eval ::textutil::tabify { + namespace import -force ::textutil::repeat::strRepeat +} + +proc ::textutil::tabify::tabify { string { num 8 } } { + return [string map [list [MakeTabStr $num] \t] $string] +} + +proc ::textutil::tabify::untabify { string { num 8 } } { + return [string map [list \t [MakeTabStr $num]] $string] +} + +proc ::textutil::tabify::MakeTabStr { num } { + variable TabStr + variable TabLen + + if { $TabLen != $num } then { + set TabLen $num + set TabStr [strRepeat " " $num] + } + + return $TabStr +} + +# ---------------------------------------------------------------------------- +# +# tabifyLine: Works on a single line of text, replacing 'spaces at correct +# positions' with tabs. $num is the requested tab size. +# Returns the (possibly modified) line. +# +# 'spaces at correct positions': Only spaces which 'fill the space' between +# an arbitrary position and the next tab stop can be replaced. +# Example: With tab size 8, spaces at positions 11 - 13 will *not* be replaced, +# because an expansion of a tab at position 11 will jump up to 16. +# See also the comment at the beginning of this file why single spaces are +# *never* replaced by a tab. +# +# The proc works backwards, from the end of the string up to the beginning: +# - Set the position to start the search from ('lastPos') to 'end'. +# - Find the last occurrence of ' ' in 'line' with respect to 'lastPos' +# ('currPos' below). This is a candidate for replacement. +# - Find to 'currPos' the following tab stop using the expression +# set nextTab [expr ($currPos + $num) - ($currPos % $num)] +# and get the previous tab stop as well (this will be the starting +# point for the next iteration). +# - The ' ' at 'currPos' is only a candidate for replacement if +# 1) it is just one position before a tab stop *and* +# 2) there is at least one space at its left (see comment above on not +# touching an isolated space). +# Continue, if any of these conditions is not met. +# - Determine where to put the tab (that is: how many spaces to replace?) +# by stepping up to the beginning until +# -- you hit a non-space or +# -- you are at the previous tab position +# - Do the replacement and continue. +# +# This algorithm only works, if $line does not contain tabs. Otherwise our +# interpretation of any position beyond the tab will be wrong. (Imagine you +# find a ' ' at position 4 in $line. If you got 3 leading tabs, your *real* +# position might be 25 (tab size of 8). Since in real life some strings might +# already contain tabs, we test for it (and eventually call untabifyLine). +# + +proc ::textutil::tabify::tabifyLine { line num } { + if { [string first \t $line] != -1 } { + # assure array 'Spaces' is set up 'comme il faut' + checkArr $num + # remove existing tabs + set line [untabifyLine $line $num] + } + + set lastPos end + + while { $lastPos > 0 } { + set currPos [string last " " $line $lastPos] + if { $currPos == -1 } { + # no more spaces + break; + } + + set nextTab [expr {($currPos + $num) - ($currPos % $num)}] + set prevTab [expr {$nextTab - $num}] + + # prepare for next round: continue at 'previous tab stop - 1' + set lastPos [expr {$prevTab - 1}] + + if { ($currPos + 1) != $nextTab } { + continue ;# crit. (1) + } + + if { [string index $line [expr {$currPos - 1}]] != " " } { + continue ;# crit. (2) + } + + # now step backwards while there are spaces + for {set pos [expr {$currPos - 2}]} {$pos >= $prevTab} {incr pos -1} { + if { [string index $line $pos] != " " } { + break; + } + } + + # ... and replace them + set line [string replace $line [expr {$pos + 1}] $currPos \t] + } + return $line +} + +# +# Helper proc for 'untabifyLine': Checks if all needed elements of array +# 'Spaces' exist and creates the missing ones if needed. +# + +proc ::textutil::tabify::checkArr { num } { + variable TabLen2 + variable Spaces + + if { $num > $TabLen2 } { + for { set i [expr {$TabLen2 + 1}] } { $i <= $num } { incr i } { + set Spaces($i) [strRepeat " " $i] + } + set TabLen2 $num + } +} + + +# untabifyLine: Works on a single line of text, replacing tabs with enough +# spaces to get to the next tab position. +# Returns the (possibly modified) line. +# +# The procedure is straight forward: +# - Find the next tab. +# - Calculate the next tab position following it. +# - Delete the tab and insert as many spaces as needed to get there. +# + +proc ::textutil::tabify::untabifyLine { line num } { + variable Spaces + + set currPos 0 + while { 1 } { + set currPos [string first \t $line $currPos] + if { $currPos == -1 } { + # no more tabs + break + } + + # how far is the next tab position ? + set dist [expr {$num - ($currPos % $num)}] + # replace '\t' at $currPos with $dist spaces + set line [string replace $line $currPos $currPos $Spaces($dist)] + + # set up for next round (not absolutely necessary but maybe a trifle + # more efficient) + incr currPos $dist + } + return $line +} + +# tabify2: Replace all 'appropriate' spaces as discussed above with tabs. +# 'string' might hold any number of lines, 'num' is the requested tab size. +# Returns (possibly modified) 'string'. +# +proc ::textutil::tabify::tabify2 { string { num 8 } } { + + # split string into individual lines + set inLst [split $string \n] + + # now work on each line + set outLst [list] + foreach line $inLst { + lappend outLst [tabifyLine $line $num] + } + + # return all as one string + return [join $outLst \n] +} + + +# untabify2: Replace all tabs with the appropriate number of spaces. +# 'string' might hold any number of lines, 'num' is the requested tab size. +# Returns (possibly modified) 'string'. +# +proc ::textutil::tabify::untabify2 { string { num 8 } } { + + # assure array 'Spaces' is set up 'comme il faut' + checkArr $num + + set inLst [split $string \n] + + set outLst [list] + foreach line $inLst { + lappend outLst [untabifyLine $line $num] + } + + return [join $outLst \n] +} + + + +# ### ### ### ######### ######### ######### +## Data structures + +namespace eval ::textutil::tabify { + variable TabLen 8 + variable TabStr [strRepeat " " $TabLen] + + namespace export tabify untabify tabify2 untabify2 + + # The proc 'untabify2' uses the following variables for efficiency. + # Since a tab can be replaced by one up to 'tab size' spaces, it is handy + # to have the appropriate 'space strings' available. This is the use of + # the array 'Spaces', where 'Spaces(n)' contains just 'n' spaces. + # The variable 'TabLen2' remembers the biggest tab size used. + + variable TabLen2 0 + variable Spaces + array set Spaces {0 ""} +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide textutil::tabify 0.7 diff --git a/src/vendormodules/textutil/trim-0.7.tm b/src/vendormodules/textutil/trim-0.7.tm new file mode 100644 index 00000000..4aab0765 --- /dev/null +++ b/src/vendormodules/textutil/trim-0.7.tm @@ -0,0 +1,112 @@ +# trim.tcl -- +# +# Various ways of trimming a string. +# +# Copyright (c) 2000 by Ajuba Solutions. +# Copyright (c) 2000 by Eric Melski +# Copyright (c) 2001-2006 by Andreas Kupries +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: trim.tcl,v 1.5 2006/04/21 04:42:28 andreas_kupries Exp $ + +# ### ### ### ######### ######### ######### +## Requirements + +package require Tcl 8.2 + +namespace eval ::textutil::trim {} + +# ### ### ### ######### ######### ######### +## API implementation + +proc ::textutil::trim::trimleft {text {trim "[ \t]+"}} { + regsub -line -all -- [MakeStr $trim left] $text {} text + return $text +} + +proc ::textutil::trim::trimright {text {trim "[ \t]+"}} { + regsub -line -all -- [MakeStr $trim right] $text {} text + return $text +} + +proc ::textutil::trim::trim {text {trim "[ \t]+"}} { + regsub -line -all -- [MakeStr $trim left] $text {} text + regsub -line -all -- [MakeStr $trim right] $text {} text + return $text +} + + + +# @c Strips from , if found at its start. +# +# @a text: The string to check for . +# @a prefix: The string to remove from . +# +# @r The , but without . +# +# @i remove, prefix + +proc ::textutil::trim::trimPrefix {text prefix} { + if {[string first $prefix $text] == 0} { + return [string range $text [string length $prefix] end] + } else { + return $text + } +} + + +# @c Removes the Heading Empty Lines of . +# +# @a text: The text block to manipulate. +# +# @r The , but without heading empty lines. +# +# @i remove, empty lines + +proc ::textutil::trim::trimEmptyHeading {text} { + regsub -- "^(\[ \t\]*\n)*" $text {} text + return $text +} + +# ### ### ### ######### ######### ######### +## Helper commands. Internal + +proc ::textutil::trim::MakeStr { string pos } { + variable StrU + variable StrR + variable StrL + + if { "$string" != "$StrU" } { + set StrU $string + set StrR "(${StrU})\$" + set StrL "^(${StrU})" + } + if { "$pos" == "left" } { + return $StrL + } + if { "$pos" == "right" } { + return $StrR + } + + return -code error "Panic, illegal position key \"$pos\"" +} + +# ### ### ### ######### ######### ######### +## Data structures + +namespace eval ::textutil::trim { + variable StrU "\[ \t\]+" + variable StrR "(${StrU})\$" + variable StrL "^(${StrU})" + + namespace export \ + trim trimright trimleft \ + trimPrefix trimEmptyHeading +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide textutil::trim 0.7 diff --git a/src/vendormodules/textutil/wcswidth-35.1.tm b/src/vendormodules/textutil/wcswidth-35.1.tm new file mode 100644 index 00000000..080a8814 --- /dev/null +++ b/src/vendormodules/textutil/wcswidth-35.1.tm @@ -0,0 +1,772 @@ +### +# This file is automatically generated by the build/build.tcl file +# based on information in the following database: +# http://www.unicode.org/Public/UCD/latest/ucd/EastAsianWidth.txt +# +# (This is the 35th edition, thus version 35 for our package) +# +# Author: Sean Woods +### +package provide textutil::wcswidth 35.1 +proc ::textutil::wcswidth_type char { + if {$char == 161} { return A } + if {$char == 164} { return A } + if {$char == 167} { return A } + if {$char == 168} { return A } + if {$char == 170} { return A } + if {$char == 173} { return A } + if {$char == 174} { return A } + if {$char == 176} { return A } + if {$char == 177} { return A } + if {$char >= 178 && $char <= 179 } { return A } + if {$char == 180} { return A } + if {$char >= 182 && $char <= 183 } { return A } + if {$char == 184} { return A } + if {$char == 185} { return A } + if {$char == 186} { return A } + if {$char >= 188 && $char <= 190 } { return A } + if {$char == 191} { return A } + if {$char == 198} { return A } + if {$char == 208} { return A } + if {$char == 215} { return A } + if {$char == 216} { return A } + if {$char >= 222 && $char <= 225 } { return A } + if {$char == 230} { return A } + if {$char >= 232 && $char <= 234 } { return A } + if {$char >= 236 && $char <= 237 } { return A } + if {$char == 240} { return A } + if {$char >= 242 && $char <= 243 } { return A } + if {$char == 247} { return A } + if {$char >= 248 && $char <= 250 } { return A } + if {$char == 252} { return A } + if {$char == 254} { return A } + if {$char == 257} { return A } + if {$char == 273} { return A } + if {$char == 275} { return A } + if {$char == 283} { return A } + if {$char >= 294 && $char <= 295 } { return A } + if {$char == 299} { return A } + if {$char >= 305 && $char <= 307 } { return A } + if {$char == 312} { return A } + if {$char >= 319 && $char <= 322 } { return A } + if {$char == 324} { return A } + if {$char >= 328 && $char <= 331 } { return A } + if {$char == 333} { return A } + if {$char >= 338 && $char <= 339 } { return A } + if {$char >= 358 && $char <= 359 } { return A } + if {$char == 363} { return A } + if {$char == 462} { return A } + if {$char == 464} { return A } + if {$char == 466} { return A } + if {$char == 468} { return A } + if {$char == 470} { return A } + if {$char == 472} { return A } + if {$char == 474} { return A } + if {$char == 476} { return A } + if {$char == 593} { return A } + if {$char == 609} { return A } + if {$char == 708} { return A } + if {$char == 711} { return A } + if {$char >= 713 && $char <= 715 } { return A } + if {$char == 717} { return A } + if {$char == 720} { return A } + if {$char >= 728 && $char <= 731 } { return A } + if {$char == 733} { return A } + if {$char == 735} { return A } + if {$char >= 768 && $char <= 879 } { return A } + if {$char >= 913 && $char <= 929 } { return A } + if {$char >= 931 && $char <= 937 } { return A } + if {$char >= 945 && $char <= 961 } { return A } + if {$char >= 963 && $char <= 969 } { return A } + if {$char == 1025} { return A } + if {$char >= 1040 && $char <= 1103 } { return A } + if {$char == 1105} { return A } + if {$char >= 4352 && $char <= 4447 } { return W } + if {$char == 8208} { return A } + if {$char >= 8211 && $char <= 8213 } { return A } + if {$char == 8214} { return A } + if {$char == 8216} { return A } + if {$char == 8217} { return A } + if {$char == 8220} { return A } + if {$char == 8221} { return A } + if {$char >= 8224 && $char <= 8226 } { return A } + if {$char >= 8228 && $char <= 8231 } { return A } + if {$char == 8240} { return A } + if {$char >= 8242 && $char <= 8243 } { return A } + if {$char == 8245} { return A } + if {$char == 8251} { return A } + if {$char == 8254} { return A } + if {$char == 8308} { return A } + if {$char == 8319} { return A } + if {$char >= 8321 && $char <= 8324 } { return A } + if {$char == 8361} { return H } + if {$char == 8364} { return A } + if {$char == 8451} { return A } + if {$char == 8453} { return A } + if {$char == 8457} { return A } + if {$char == 8467} { return A } + if {$char == 8470} { return A } + if {$char >= 8481 && $char <= 8482 } { return A } + if {$char == 8486} { return A } + if {$char == 8491} { return A } + if {$char >= 8531 && $char <= 8532 } { return A } + if {$char >= 8539 && $char <= 8542 } { return A } + if {$char >= 8544 && $char <= 8555 } { return A } + if {$char >= 8560 && $char <= 8569 } { return A } + if {$char == 8585} { return A } + if {$char >= 8592 && $char <= 8596 } { return A } + if {$char >= 8597 && $char <= 8601 } { return A } + if {$char >= 8632 && $char <= 8633 } { return A } + if {$char == 8658} { return A } + if {$char == 8660} { return A } + if {$char == 8679} { return A } + if {$char == 8704} { return A } + if {$char >= 8706 && $char <= 8707 } { return A } + if {$char >= 8711 && $char <= 8712 } { return A } + if {$char == 8715} { return A } + if {$char == 8719} { return A } + if {$char == 8721} { return A } + if {$char == 8725} { return A } + if {$char == 8730} { return A } + if {$char >= 8733 && $char <= 8736 } { return A } + if {$char == 8739} { return A } + if {$char == 8741} { return A } + if {$char >= 8743 && $char <= 8748 } { return A } + if {$char == 8750} { return A } + if {$char >= 8756 && $char <= 8759 } { return A } + if {$char >= 8764 && $char <= 8765 } { return A } + if {$char == 8776} { return A } + if {$char == 8780} { return A } + if {$char == 8786} { return A } + if {$char >= 8800 && $char <= 8801 } { return A } + if {$char >= 8804 && $char <= 8807 } { return A } + if {$char >= 8810 && $char <= 8811 } { return A } + if {$char >= 8814 && $char <= 8815 } { return A } + if {$char >= 8834 && $char <= 8835 } { return A } + if {$char >= 8838 && $char <= 8839 } { return A } + if {$char == 8853} { return A } + if {$char == 8857} { return A } + if {$char == 8869} { return A } + if {$char == 8895} { return A } + if {$char == 8978} { return A } + if {$char >= 8986 && $char <= 8987 } { return W } + if {$char == 9001} { return W } + if {$char == 9002} { return W } + if {$char >= 9193 && $char <= 9196 } { return W } + if {$char == 9200} { return W } + if {$char == 9203} { return W } + if {$char >= 9312 && $char <= 9371 } { return A } + if {$char >= 9372 && $char <= 9449 } { return A } + if {$char >= 9451 && $char <= 9471 } { return A } + if {$char >= 9472 && $char <= 9547 } { return A } + if {$char >= 9552 && $char <= 9587 } { return A } + if {$char >= 9600 && $char <= 9615 } { return A } + if {$char >= 9618 && $char <= 9621 } { return A } + if {$char >= 9632 && $char <= 9633 } { return A } + if {$char >= 9635 && $char <= 9641 } { return A } + if {$char >= 9650 && $char <= 9651 } { return A } + if {$char == 9654} { return A } + if {$char == 9655} { return A } + if {$char >= 9660 && $char <= 9661 } { return A } + if {$char == 9664} { return A } + if {$char == 9665} { return A } + if {$char >= 9670 && $char <= 9672 } { return A } + if {$char == 9675} { return A } + if {$char >= 9678 && $char <= 9681 } { return A } + if {$char >= 9698 && $char <= 9701 } { return A } + if {$char == 9711} { return A } + if {$char >= 9725 && $char <= 9726 } { return W } + if {$char >= 9733 && $char <= 9734 } { return A } + if {$char == 9737} { return A } + if {$char >= 9742 && $char <= 9743 } { return A } + if {$char >= 9748 && $char <= 9749 } { return W } + if {$char == 9756} { return A } + if {$char == 9758} { return A } + if {$char == 9792} { return A } + if {$char == 9794} { return A } + if {$char >= 9800 && $char <= 9811 } { return W } + if {$char >= 9824 && $char <= 9825 } { return A } + if {$char >= 9827 && $char <= 9829 } { return A } + if {$char >= 9831 && $char <= 9834 } { return A } + if {$char >= 9836 && $char <= 9837 } { return A } + if {$char == 9839} { return A } + if {$char == 9855} { return W } + if {$char == 9875} { return W } + if {$char >= 9886 && $char <= 9887 } { return A } + if {$char == 9889} { return W } + if {$char >= 9898 && $char <= 9899 } { return W } + if {$char >= 9917 && $char <= 9918 } { return W } + if {$char == 9919} { return A } + if {$char >= 9924 && $char <= 9925 } { return W } + if {$char >= 9926 && $char <= 9933 } { return A } + if {$char == 9934} { return W } + if {$char >= 9935 && $char <= 9939 } { return A } + if {$char == 9940} { return W } + if {$char >= 9941 && $char <= 9953 } { return A } + if {$char == 9955} { return A } + if {$char >= 9960 && $char <= 9961 } { return A } + if {$char == 9962} { return W } + if {$char >= 9963 && $char <= 9969 } { return A } + if {$char >= 9970 && $char <= 9971 } { return W } + if {$char == 9972} { return A } + if {$char == 9973} { return W } + if {$char >= 9974 && $char <= 9977 } { return A } + if {$char == 9978} { return W } + if {$char >= 9979 && $char <= 9980 } { return A } + if {$char == 9981} { return W } + if {$char >= 9982 && $char <= 9983 } { return A } + if {$char == 9989} { return W } + if {$char >= 9994 && $char <= 9995 } { return W } + if {$char == 10024} { return W } + if {$char == 10045} { return A } + if {$char == 10060} { return W } + if {$char == 10062} { return W } + if {$char >= 10067 && $char <= 10069 } { return W } + if {$char == 10071} { return W } + if {$char >= 10102 && $char <= 10111 } { return A } + if {$char >= 10133 && $char <= 10135 } { return W } + if {$char == 10160} { return W } + if {$char == 10175} { return W } + if {$char >= 11035 && $char <= 11036 } { return W } + if {$char == 11088} { return W } + if {$char == 11093} { return W } + if {$char >= 11094 && $char <= 11097 } { return A } + if {$char >= 11904 && $char <= 11929 } { return W } + if {$char >= 11931 && $char <= 12019 } { return W } + if {$char >= 12032 && $char <= 12245 } { return W } + if {$char >= 12272 && $char <= 12283 } { return W } + if {$char == 12288} { return F } + if {$char >= 12289 && $char <= 12291 } { return W } + if {$char == 12292} { return W } + if {$char == 12293} { return W } + if {$char == 12294} { return W } + if {$char == 12295} { return W } + if {$char == 12296} { return W } + if {$char == 12297} { return W } + if {$char == 12298} { return W } + if {$char == 12299} { return W } + if {$char == 12300} { return W } + if {$char == 12301} { return W } + if {$char == 12302} { return W } + if {$char == 12303} { return W } + if {$char == 12304} { return W } + if {$char == 12305} { return W } + if {$char >= 12306 && $char <= 12307 } { return W } + if {$char == 12308} { return W } + if {$char == 12309} { return W } + if {$char == 12310} { return W } + if {$char == 12311} { return W } + if {$char == 12312} { return W } + if {$char == 12313} { return W } + if {$char == 12314} { return W } + if {$char == 12315} { return W } + if {$char == 12316} { return W } + if {$char == 12317} { return W } + if {$char >= 12318 && $char <= 12319 } { return W } + if {$char == 12320} { return W } + if {$char >= 12321 && $char <= 12329 } { return W } + if {$char >= 12330 && $char <= 12333 } { return W } + if {$char >= 12334 && $char <= 12335 } { return W } + if {$char == 12336} { return W } + if {$char >= 12337 && $char <= 12341 } { return W } + if {$char >= 12342 && $char <= 12343 } { return W } + if {$char >= 12344 && $char <= 12346 } { return W } + if {$char == 12347} { return W } + if {$char == 12348} { return W } + if {$char == 12349} { return W } + if {$char == 12350} { return W } + if {$char >= 12353 && $char <= 12438 } { return W } + if {$char >= 12441 && $char <= 12442 } { return W } + if {$char >= 12443 && $char <= 12444 } { return W } + if {$char >= 12445 && $char <= 12446 } { return W } + if {$char == 12447} { return W } + if {$char == 12448} { return W } + if {$char >= 12449 && $char <= 12538 } { return W } + if {$char == 12539} { return W } + if {$char >= 12540 && $char <= 12542 } { return W } + if {$char == 12543} { return W } + if {$char >= 12549 && $char <= 12591 } { return W } + if {$char >= 12593 && $char <= 12686 } { return W } + if {$char >= 12688 && $char <= 12689 } { return W } + if {$char >= 12690 && $char <= 12693 } { return W } + if {$char >= 12694 && $char <= 12703 } { return W } + if {$char >= 12704 && $char <= 12730 } { return W } + if {$char >= 12736 && $char <= 12771 } { return W } + if {$char >= 12784 && $char <= 12799 } { return W } + if {$char >= 12800 && $char <= 12830 } { return W } + if {$char >= 12832 && $char <= 12841 } { return W } + if {$char >= 12842 && $char <= 12871 } { return W } + if {$char >= 12872 && $char <= 12879 } { return A } + if {$char == 12880} { return W } + if {$char >= 12881 && $char <= 12895 } { return W } + if {$char >= 12896 && $char <= 12927 } { return W } + if {$char >= 12928 && $char <= 12937 } { return W } + if {$char >= 12938 && $char <= 12976 } { return W } + if {$char >= 12977 && $char <= 12991 } { return W } + if {$char >= 12992 && $char <= 13054 } { return W } + if {$char >= 13056 && $char <= 13311 } { return W } + if {$char >= 13312 && $char <= 19893 } { return W } + if {$char >= 19894 && $char <= 19903 } { return W } + if {$char >= 19968 && $char <= 40943 } { return W } + if {$char >= 40944 && $char <= 40959 } { return W } + if {$char >= 40960 && $char <= 40980 } { return W } + if {$char == 40981} { return W } + if {$char >= 40982 && $char <= 42124 } { return W } + if {$char >= 42128 && $char <= 42182 } { return W } + if {$char >= 43360 && $char <= 43388 } { return W } + if {$char >= 44032 && $char <= 55203 } { return W } + if {$char >= 57344 && $char <= 63743 } { return A } + if {$char >= 63744 && $char <= 64109 } { return W } + if {$char >= 64110 && $char <= 64111 } { return W } + if {$char >= 64112 && $char <= 64217 } { return W } + if {$char >= 64218 && $char <= 64255 } { return W } + if {$char >= 65024 && $char <= 65039 } { return A } + if {$char >= 65040 && $char <= 65046 } { return W } + if {$char == 65047} { return W } + if {$char == 65048} { return W } + if {$char == 65049} { return W } + if {$char == 65072} { return W } + if {$char >= 65073 && $char <= 65074 } { return W } + if {$char >= 65075 && $char <= 65076 } { return W } + if {$char == 65077} { return W } + if {$char == 65078} { return W } + if {$char == 65079} { return W } + if {$char == 65080} { return W } + if {$char == 65081} { return W } + if {$char == 65082} { return W } + if {$char == 65083} { return W } + if {$char == 65084} { return W } + if {$char == 65085} { return W } + if {$char == 65086} { return W } + if {$char == 65087} { return W } + if {$char == 65088} { return W } + if {$char == 65089} { return W } + if {$char == 65090} { return W } + if {$char == 65091} { return W } + if {$char == 65092} { return W } + if {$char >= 65093 && $char <= 65094 } { return W } + if {$char == 65095} { return W } + if {$char == 65096} { return W } + if {$char >= 65097 && $char <= 65100 } { return W } + if {$char >= 65101 && $char <= 65103 } { return W } + if {$char >= 65104 && $char <= 65106 } { return W } + if {$char >= 65108 && $char <= 65111 } { return W } + if {$char == 65112} { return W } + if {$char == 65113} { return W } + if {$char == 65114} { return W } + if {$char == 65115} { return W } + if {$char == 65116} { return W } + if {$char == 65117} { return W } + if {$char == 65118} { return W } + if {$char >= 65119 && $char <= 65121 } { return W } + if {$char == 65122} { return W } + if {$char == 65123} { return W } + if {$char >= 65124 && $char <= 65126 } { return W } + if {$char == 65128} { return W } + if {$char == 65129} { return W } + if {$char >= 65130 && $char <= 65131 } { return W } + if {$char >= 65281 && $char <= 65283 } { return F } + if {$char == 65284} { return F } + if {$char >= 65285 && $char <= 65287 } { return F } + if {$char == 65288} { return F } + if {$char == 65289} { return F } + if {$char == 65290} { return F } + if {$char == 65291} { return F } + if {$char == 65292} { return F } + if {$char == 65293} { return F } + if {$char >= 65294 && $char <= 65295 } { return F } + if {$char >= 65296 && $char <= 65305 } { return F } + if {$char >= 65306 && $char <= 65307 } { return F } + if {$char >= 65308 && $char <= 65310 } { return F } + if {$char >= 65311 && $char <= 65312 } { return F } + if {$char >= 65313 && $char <= 65338 } { return F } + if {$char == 65339} { return F } + if {$char == 65340} { return F } + if {$char == 65341} { return F } + if {$char == 65342} { return F } + if {$char == 65343} { return F } + if {$char == 65344} { return F } + if {$char >= 65345 && $char <= 65370 } { return F } + if {$char == 65371} { return F } + if {$char == 65372} { return F } + if {$char == 65373} { return F } + if {$char == 65374} { return F } + if {$char == 65375} { return F } + if {$char == 65376} { return F } + if {$char == 65377} { return H } + if {$char == 65378} { return H } + if {$char == 65379} { return H } + if {$char >= 65380 && $char <= 65381 } { return H } + if {$char >= 65382 && $char <= 65391 } { return H } + if {$char == 65392} { return H } + if {$char >= 65393 && $char <= 65437 } { return H } + if {$char >= 65438 && $char <= 65439 } { return H } + if {$char >= 65440 && $char <= 65470 } { return H } + if {$char >= 65474 && $char <= 65479 } { return H } + if {$char >= 65482 && $char <= 65487 } { return H } + if {$char >= 65490 && $char <= 65495 } { return H } + if {$char >= 65498 && $char <= 65500 } { return H } + if {$char >= 65504 && $char <= 65505 } { return F } + if {$char == 65506} { return F } + if {$char == 65507} { return F } + if {$char == 65508} { return F } + if {$char >= 65509 && $char <= 65510 } { return F } + if {$char == 65512} { return H } + if {$char >= 65513 && $char <= 65516 } { return H } + if {$char >= 65517 && $char <= 65518 } { return H } + if {$char == 65533} { return A } + if {$char >= 94176 && $char <= 94177 } { return W } + if {$char >= 94208 && $char <= 100337 } { return W } + if {$char >= 100352 && $char <= 101106 } { return W } + if {$char >= 110592 && $char <= 110847 } { return W } + if {$char >= 110848 && $char <= 110878 } { return W } + if {$char >= 110960 && $char <= 111355 } { return W } + if {$char == 126980} { return W } + if {$char == 127183} { return W } + if {$char >= 127232 && $char <= 127242 } { return A } + if {$char >= 127248 && $char <= 127277 } { return A } + if {$char >= 127280 && $char <= 127337 } { return A } + if {$char >= 127344 && $char <= 127373 } { return A } + if {$char == 127374} { return W } + if {$char >= 127375 && $char <= 127376 } { return A } + if {$char >= 127377 && $char <= 127386 } { return W } + if {$char >= 127387 && $char <= 127404 } { return A } + if {$char >= 127488 && $char <= 127490 } { return W } + if {$char >= 127504 && $char <= 127547 } { return W } + if {$char >= 127552 && $char <= 127560 } { return W } + if {$char >= 127568 && $char <= 127569 } { return W } + if {$char >= 127584 && $char <= 127589 } { return W } + if {$char >= 127744 && $char <= 127776 } { return W } + if {$char >= 127789 && $char <= 127797 } { return W } + if {$char >= 127799 && $char <= 127868 } { return W } + if {$char >= 127870 && $char <= 127891 } { return W } + if {$char >= 127904 && $char <= 127946 } { return W } + if {$char >= 127951 && $char <= 127955 } { return W } + if {$char >= 127968 && $char <= 127984 } { return W } + if {$char == 127988} { return W } + if {$char >= 127992 && $char <= 127994 } { return W } + if {$char >= 127995 && $char <= 127999 } { return W } + if {$char >= 128000 && $char <= 128062 } { return W } + if {$char == 128064} { return W } + if {$char >= 128066 && $char <= 128252 } { return W } + if {$char >= 128255 && $char <= 128317 } { return W } + if {$char >= 128331 && $char <= 128334 } { return W } + if {$char >= 128336 && $char <= 128359 } { return W } + if {$char == 128378} { return W } + if {$char >= 128405 && $char <= 128406 } { return W } + if {$char == 128420} { return W } + if {$char >= 128507 && $char <= 128511 } { return W } + if {$char >= 128512 && $char <= 128591 } { return W } + if {$char >= 128640 && $char <= 128709 } { return W } + if {$char == 128716} { return W } + if {$char >= 128720 && $char <= 128722 } { return W } + if {$char >= 128747 && $char <= 128748 } { return W } + if {$char >= 128756 && $char <= 128761 } { return W } + if {$char >= 129296 && $char <= 129342 } { return W } + if {$char >= 129344 && $char <= 129392 } { return W } + if {$char >= 129395 && $char <= 129398 } { return W } + if {$char == 129402} { return W } + if {$char >= 129404 && $char <= 129442 } { return W } + if {$char >= 129456 && $char <= 129465 } { return W } + if {$char >= 129472 && $char <= 129474 } { return W } + if {$char >= 129488 && $char <= 129535 } { return W } + if {$char >= 131072 && $char <= 173782 } { return W } + if {$char >= 173783 && $char <= 173823 } { return W } + if {$char >= 173824 && $char <= 177972 } { return W } + if {$char >= 177973 && $char <= 177983 } { return W } + if {$char >= 177984 && $char <= 178205 } { return W } + if {$char >= 178206 && $char <= 178207 } { return W } + if {$char >= 178208 && $char <= 183969 } { return W } + if {$char >= 183970 && $char <= 183983 } { return W } + if {$char >= 183984 && $char <= 191456 } { return W } + if {$char >= 191457 && $char <= 194559 } { return W } + if {$char >= 194560 && $char <= 195101 } { return W } + if {$char >= 195102 && $char <= 195103 } { return W } + if {$char >= 195104 && $char <= 196605 } { return W } + if {$char >= 196608 && $char <= 262141 } { return W } + if {$char >= 917760 && $char <= 917999 } { return A } + if {$char >= 983040 && $char <= 1048573 } { return A } + if {$char >= 1048576 && $char <= 1114109 } { return A } + return N +} +proc ::textutil::wcswidth_char char { + if {$char >= 4352 && $char <= 4447 } { return 2 } + if {$char >= 8986 && $char <= 8987 } { return 2 } + if {$char == 9001} { return 2 } + if {$char == 9002} { return 2 } + if {$char >= 9193 && $char <= 9196 } { return 2 } + if {$char == 9200} { return 2 } + if {$char == 9203} { return 2 } + if {$char >= 9725 && $char <= 9726 } { return 2 } + if {$char >= 9748 && $char <= 9749 } { return 2 } + if {$char >= 9800 && $char <= 9811 } { return 2 } + if {$char == 9855} { return 2 } + if {$char == 9875} { return 2 } + if {$char == 9889} { return 2 } + if {$char >= 9898 && $char <= 9899 } { return 2 } + if {$char >= 9917 && $char <= 9918 } { return 2 } + if {$char >= 9924 && $char <= 9925 } { return 2 } + if {$char == 9934} { return 2 } + if {$char == 9940} { return 2 } + if {$char == 9962} { return 2 } + if {$char >= 9970 && $char <= 9971 } { return 2 } + if {$char == 9973} { return 2 } + if {$char == 9978} { return 2 } + if {$char == 9981} { return 2 } + if {$char == 9989} { return 2 } + if {$char >= 9994 && $char <= 9995 } { return 2 } + if {$char == 10024} { return 2 } + if {$char == 10060} { return 2 } + if {$char == 10062} { return 2 } + if {$char >= 10067 && $char <= 10069 } { return 2 } + if {$char == 10071} { return 2 } + if {$char >= 10133 && $char <= 10135 } { return 2 } + if {$char == 10160} { return 2 } + if {$char == 10175} { return 2 } + if {$char >= 11035 && $char <= 11036 } { return 2 } + if {$char == 11088} { return 2 } + if {$char == 11093} { return 2 } + if {$char >= 11904 && $char <= 11929 } { return 2 } + if {$char >= 11931 && $char <= 12019 } { return 2 } + if {$char >= 12032 && $char <= 12245 } { return 2 } + if {$char >= 12272 && $char <= 12283 } { return 2 } + if {$char == 12288} { return 2 } + if {$char >= 12289 && $char <= 12291 } { return 2 } + if {$char == 12292} { return 2 } + if {$char == 12293} { return 2 } + if {$char == 12294} { return 2 } + if {$char == 12295} { return 2 } + if {$char == 12296} { return 2 } + if {$char == 12297} { return 2 } + if {$char == 12298} { return 2 } + if {$char == 12299} { return 2 } + if {$char == 12300} { return 2 } + if {$char == 12301} { return 2 } + if {$char == 12302} { return 2 } + if {$char == 12303} { return 2 } + if {$char == 12304} { return 2 } + if {$char == 12305} { return 2 } + if {$char >= 12306 && $char <= 12307 } { return 2 } + if {$char == 12308} { return 2 } + if {$char == 12309} { return 2 } + if {$char == 12310} { return 2 } + if {$char == 12311} { return 2 } + if {$char == 12312} { return 2 } + if {$char == 12313} { return 2 } + if {$char == 12314} { return 2 } + if {$char == 12315} { return 2 } + if {$char == 12316} { return 2 } + if {$char == 12317} { return 2 } + if {$char >= 12318 && $char <= 12319 } { return 2 } + if {$char == 12320} { return 2 } + if {$char >= 12321 && $char <= 12329 } { return 2 } + if {$char >= 12330 && $char <= 12333 } { return 2 } + if {$char >= 12334 && $char <= 12335 } { return 2 } + if {$char == 12336} { return 2 } + if {$char >= 12337 && $char <= 12341 } { return 2 } + if {$char >= 12342 && $char <= 12343 } { return 2 } + if {$char >= 12344 && $char <= 12346 } { return 2 } + if {$char == 12347} { return 2 } + if {$char == 12348} { return 2 } + if {$char == 12349} { return 2 } + if {$char == 12350} { return 2 } + if {$char >= 12353 && $char <= 12438 } { return 2 } + if {$char >= 12441 && $char <= 12442 } { return 2 } + if {$char >= 12443 && $char <= 12444 } { return 2 } + if {$char >= 12445 && $char <= 12446 } { return 2 } + if {$char == 12447} { return 2 } + if {$char == 12448} { return 2 } + if {$char >= 12449 && $char <= 12538 } { return 2 } + if {$char == 12539} { return 2 } + if {$char >= 12540 && $char <= 12542 } { return 2 } + if {$char == 12543} { return 2 } + if {$char >= 12549 && $char <= 12591 } { return 2 } + if {$char >= 12593 && $char <= 12686 } { return 2 } + if {$char >= 12688 && $char <= 12689 } { return 2 } + if {$char >= 12690 && $char <= 12693 } { return 2 } + if {$char >= 12694 && $char <= 12703 } { return 2 } + if {$char >= 12704 && $char <= 12730 } { return 2 } + if {$char >= 12736 && $char <= 12771 } { return 2 } + if {$char >= 12784 && $char <= 12799 } { return 2 } + if {$char >= 12800 && $char <= 12830 } { return 2 } + if {$char >= 12832 && $char <= 12841 } { return 2 } + if {$char >= 12842 && $char <= 12871 } { return 2 } + if {$char == 12880} { return 2 } + if {$char >= 12881 && $char <= 12895 } { return 2 } + if {$char >= 12896 && $char <= 12927 } { return 2 } + if {$char >= 12928 && $char <= 12937 } { return 2 } + if {$char >= 12938 && $char <= 12976 } { return 2 } + if {$char >= 12977 && $char <= 12991 } { return 2 } + if {$char >= 12992 && $char <= 13054 } { return 2 } + if {$char >= 13056 && $char <= 13311 } { return 2 } + if {$char >= 13312 && $char <= 19893 } { return 2 } + if {$char >= 19894 && $char <= 19903 } { return 2 } + if {$char >= 19968 && $char <= 40943 } { return 2 } + if {$char >= 40944 && $char <= 40959 } { return 2 } + if {$char >= 40960 && $char <= 40980 } { return 2 } + if {$char == 40981} { return 2 } + if {$char >= 40982 && $char <= 42124 } { return 2 } + if {$char >= 42128 && $char <= 42182 } { return 2 } + if {$char >= 43360 && $char <= 43388 } { return 2 } + if {$char >= 44032 && $char <= 55203 } { return 2 } + if {$char >= 63744 && $char <= 64109 } { return 2 } + if {$char >= 64110 && $char <= 64111 } { return 2 } + if {$char >= 64112 && $char <= 64217 } { return 2 } + if {$char >= 64218 && $char <= 64255 } { return 2 } + if {$char >= 65040 && $char <= 65046 } { return 2 } + if {$char == 65047} { return 2 } + if {$char == 65048} { return 2 } + if {$char == 65049} { return 2 } + if {$char == 65072} { return 2 } + if {$char >= 65073 && $char <= 65074 } { return 2 } + if {$char >= 65075 && $char <= 65076 } { return 2 } + if {$char == 65077} { return 2 } + if {$char == 65078} { return 2 } + if {$char == 65079} { return 2 } + if {$char == 65080} { return 2 } + if {$char == 65081} { return 2 } + if {$char == 65082} { return 2 } + if {$char == 65083} { return 2 } + if {$char == 65084} { return 2 } + if {$char == 65085} { return 2 } + if {$char == 65086} { return 2 } + if {$char == 65087} { return 2 } + if {$char == 65088} { return 2 } + if {$char == 65089} { return 2 } + if {$char == 65090} { return 2 } + if {$char == 65091} { return 2 } + if {$char == 65092} { return 2 } + if {$char >= 65093 && $char <= 65094 } { return 2 } + if {$char == 65095} { return 2 } + if {$char == 65096} { return 2 } + if {$char >= 65097 && $char <= 65100 } { return 2 } + if {$char >= 65101 && $char <= 65103 } { return 2 } + if {$char >= 65104 && $char <= 65106 } { return 2 } + if {$char >= 65108 && $char <= 65111 } { return 2 } + if {$char == 65112} { return 2 } + if {$char == 65113} { return 2 } + if {$char == 65114} { return 2 } + if {$char == 65115} { return 2 } + if {$char == 65116} { return 2 } + if {$char == 65117} { return 2 } + if {$char == 65118} { return 2 } + if {$char >= 65119 && $char <= 65121 } { return 2 } + if {$char == 65122} { return 2 } + if {$char == 65123} { return 2 } + if {$char >= 65124 && $char <= 65126 } { return 2 } + if {$char == 65128} { return 2 } + if {$char == 65129} { return 2 } + if {$char >= 65130 && $char <= 65131 } { return 2 } + if {$char >= 65281 && $char <= 65283 } { return 2 } + if {$char == 65284} { return 2 } + if {$char >= 65285 && $char <= 65287 } { return 2 } + if {$char == 65288} { return 2 } + if {$char == 65289} { return 2 } + if {$char == 65290} { return 2 } + if {$char == 65291} { return 2 } + if {$char == 65292} { return 2 } + if {$char == 65293} { return 2 } + if {$char >= 65294 && $char <= 65295 } { return 2 } + if {$char >= 65296 && $char <= 65305 } { return 2 } + if {$char >= 65306 && $char <= 65307 } { return 2 } + if {$char >= 65308 && $char <= 65310 } { return 2 } + if {$char >= 65311 && $char <= 65312 } { return 2 } + if {$char >= 65313 && $char <= 65338 } { return 2 } + if {$char == 65339} { return 2 } + if {$char == 65340} { return 2 } + if {$char == 65341} { return 2 } + if {$char == 65342} { return 2 } + if {$char == 65343} { return 2 } + if {$char == 65344} { return 2 } + if {$char >= 65345 && $char <= 65370 } { return 2 } + if {$char == 65371} { return 2 } + if {$char == 65372} { return 2 } + if {$char == 65373} { return 2 } + if {$char == 65374} { return 2 } + if {$char == 65375} { return 2 } + if {$char == 65376} { return 2 } + if {$char >= 65504 && $char <= 65505 } { return 2 } + if {$char == 65506} { return 2 } + if {$char == 65507} { return 2 } + if {$char == 65508} { return 2 } + if {$char >= 65509 && $char <= 65510 } { return 2 } + if {$char >= 94176 && $char <= 94177 } { return 2 } + if {$char >= 94208 && $char <= 100337 } { return 2 } + if {$char >= 100352 && $char <= 101106 } { return 2 } + if {$char >= 110592 && $char <= 110847 } { return 2 } + if {$char >= 110848 && $char <= 110878 } { return 2 } + if {$char >= 110960 && $char <= 111355 } { return 2 } + if {$char == 126980} { return 2 } + if {$char == 127183} { return 2 } + if {$char == 127374} { return 2 } + if {$char >= 127377 && $char <= 127386 } { return 2 } + if {$char >= 127488 && $char <= 127490 } { return 2 } + if {$char >= 127504 && $char <= 127547 } { return 2 } + if {$char >= 127552 && $char <= 127560 } { return 2 } + if {$char >= 127568 && $char <= 127569 } { return 2 } + if {$char >= 127584 && $char <= 127589 } { return 2 } + if {$char >= 127744 && $char <= 127776 } { return 2 } + if {$char >= 127789 && $char <= 127797 } { return 2 } + if {$char >= 127799 && $char <= 127868 } { return 2 } + if {$char >= 127870 && $char <= 127891 } { return 2 } + if {$char >= 127904 && $char <= 127946 } { return 2 } + if {$char >= 127951 && $char <= 127955 } { return 2 } + if {$char >= 127968 && $char <= 127984 } { return 2 } + if {$char == 127988} { return 2 } + if {$char >= 127992 && $char <= 127994 } { return 2 } + if {$char >= 127995 && $char <= 127999 } { return 2 } + if {$char >= 128000 && $char <= 128062 } { return 2 } + if {$char == 128064} { return 2 } + if {$char >= 128066 && $char <= 128252 } { return 2 } + if {$char >= 128255 && $char <= 128317 } { return 2 } + if {$char >= 128331 && $char <= 128334 } { return 2 } + if {$char >= 128336 && $char <= 128359 } { return 2 } + if {$char == 128378} { return 2 } + if {$char >= 128405 && $char <= 128406 } { return 2 } + if {$char == 128420} { return 2 } + if {$char >= 128507 && $char <= 128511 } { return 2 } + if {$char >= 128512 && $char <= 128591 } { return 2 } + if {$char >= 128640 && $char <= 128709 } { return 2 } + if {$char == 128716} { return 2 } + if {$char >= 128720 && $char <= 128722 } { return 2 } + if {$char >= 128747 && $char <= 128748 } { return 2 } + if {$char >= 128756 && $char <= 128761 } { return 2 } + if {$char >= 129296 && $char <= 129342 } { return 2 } + if {$char >= 129344 && $char <= 129392 } { return 2 } + if {$char >= 129395 && $char <= 129398 } { return 2 } + if {$char == 129402} { return 2 } + if {$char >= 129404 && $char <= 129442 } { return 2 } + if {$char >= 129456 && $char <= 129465 } { return 2 } + if {$char >= 129472 && $char <= 129474 } { return 2 } + if {$char >= 129488 && $char <= 129535 } { return 2 } + if {$char >= 131072 && $char <= 173782 } { return 2 } + if {$char >= 173783 && $char <= 173823 } { return 2 } + if {$char >= 173824 && $char <= 177972 } { return 2 } + if {$char >= 177973 && $char <= 177983 } { return 2 } + if {$char >= 177984 && $char <= 178205 } { return 2 } + if {$char >= 178206 && $char <= 178207 } { return 2 } + if {$char >= 178208 && $char <= 183969 } { return 2 } + if {$char >= 183970 && $char <= 183983 } { return 2 } + if {$char >= 183984 && $char <= 191456 } { return 2 } + if {$char >= 191457 && $char <= 194559 } { return 2 } + if {$char >= 194560 && $char <= 195101 } { return 2 } + if {$char >= 195102 && $char <= 195103 } { return 2 } + if {$char >= 195104 && $char <= 196605 } { return 2 } + if {$char >= 196608 && $char <= 262141 } { return 2 } + return 1 +} + +proc ::textutil::wcswidth {string} { + set width 0 + set len [string length $string] + foreach c [split $string {}] { + scan $c %c char + set n [::textutil::wcswidth_char $char] + if {$n < 0} { + return -1 + } + incr width $n + } + return $width +} +