diff --git a/src/bootsupport/modules/oolib-0.1.2.tm b/src/bootsupport/modules/oolib-0.1.2.tm new file mode 100644 index 00000000..af5da523 --- /dev/null +++ b/src/bootsupport/modules/oolib-0.1.2.tm @@ -0,0 +1,201 @@ +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1.2 +}] + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + #variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + set idx $globOrIdx + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key >= 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex $o_data $key] + #return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? + #method alias {newAlias existingKeyOrAlias} { + # if {[string is integer -strict $newAlias]} { + # error "[self object] collection key alias cannot be integer" + # } + # if {[string length $existingKeyOrAlias]} { + # set o_alias($newAlias) $existingKeyOrAlias + # } else { + # unset o_alias($newAlias) + # } + #} + #method aliases {{key ""}} { + # if {[string length $key]} { + # set result [list] + # foreach {n v} [array get o_alias] { + # if {$v eq $key} { + # lappend result $n $v + # } + # } + # return $result + # } else { + # return [array get o_alias] + # } + #} + ##if the supplied index is an alias, return the underlying key; else return the index supplied. + #method realKey {idx} { + # if {[catch {set o_alias($idx)} key]} { + # return $idx + # } else { + # return $key + # } + #} + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse_the_collection {} { + #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs + #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. + #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } + +} + diff --git a/src/bootsupport/modules/overtype-1.6.3.tm b/src/bootsupport/modules/overtype-1.6.3.tm new file mode 100644 index 00000000..ef12e956 --- /dev/null +++ b/src/bootsupport/modules/overtype-1.6.3.tm @@ -0,0 +1,3655 @@ +# -*- 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.6.3 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin overtype_module_overtype 0 1.6.3] +#[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 +package require punk::assertion +#*** !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 import ::punk::assertion::assert + punk::assertion::active true + + namespace path ::punk::lib + + 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] +} + +#todo - consider a way to merge overtype::left/centre/right +#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock +#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. +#(i.e not even necessariy having it's top left within the underlay) +namespace eval overtype::priv { +} + +#could return larger than colwidth +proc _get_row_append_column {row} { + upvar outputlines outputlines + set idx [expr {$row -1}] + if {$row <= 1 || $row > [llength $outputlines]} { + return 1 + } else { + upvar opt_overflow opt_overflow + upvar colwidth colwidth + set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] + set endpos [expr {$existinglen +1}] + if {$opt_overflow} { + return $endpos + } else { + if {$endpos > $colwidth} { + return $colwidth + 1 + } else { + return $endpos + } + } + } +} + +namespace eval overtype { + #*** !doctools + #[subsection {Namespace overtype}] + #[para] Core API functions for overtype + #[list_begin definitions] + + + + #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 + #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. + #The underlay and overlay can be multiline blocks of text of varying line lengths. + #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. + #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. + # a cursor start position other than top-left is a possible addition to consider. + #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline + proc renderspace {args} { + #*** !doctools + #[call [fun overtype::renderspace] [arg args] ] + #[para] usage: ?-transparent [lb]0|1[rb]? ?-overflow [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext + + # @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\ + -width \uFFEF\ + -height \uFFEF\ + -wrap 0\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -looplimit \uFFEF\ + ] + #-ellipsis args not used if -wrap is true + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + switch -- $k { + -looplimit - -width - -height - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental {} + default { + set known_opts [dict keys $defaults] + error "overtype::renderspace unknown option '$k'. Known options: $known_opts" + } + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_overflow [dict get $opts -overflow] + ##### + # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. + set opt_wrap [dict get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) + ##### + #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. + set opt_width [dict get $opts -width] + set opt_height [dict get $opts -height] + set opt_appendlines [dict get $opts -appendlines] + 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 + # -- --- --- --- --- --- + + # ---------------------------- + # -experimental dev flag to set flags etc + # ---------------------------- + set data_mode 0 + set test_mode 1 + set info_mode 0 + set edit_mode 0 + set opt_experimental [dict get $opts -experimental] + foreach o $opt_experimental { + switch -- $o { + test_mode { + set test_mode 1 + set info_mode 1 + } + old_mode { + set test_mode 0 + set info_mode 1 + } + data_mode { + set data_mode 1 + } + info_mode { + set info_mode 1 + } + edit_mode { + set edit_mode 1 + } + } + } + set test_mode 1 ;#try to eliminate + # ---------------------------- + + #modes + set insert_mode 0 ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l + set autowrap_mode $opt_wrap + set reverse_mode 0 + + + set norm [list \r\n \n] + set underblock [string map $norm $underblock] + set overblock [string map $norm $overblock] + + + #set underlines [split $underblock \n] + + #underblock is a 'rendered' block - so width height make sense + #colwidth & colheight were originally named with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. + #The naming is now confusing. It should be something like renderwidth renderheight ?? review + + if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { + lassign [blocksize $underblock] _w colwidth _h colheight + if {$opt_width ne "\uFFEF"} { + set colwidth $opt_width + } + if {$opt_height ne "\uFFEF"} { + set colheight $opt_height + } + } else { + set colwidth $opt_width + set colheight $opt_height + } + + # -- --- --- --- + #REVIEW - do we need ansi resets in the underblock? + if {$underblock eq ""} { + set underlines [lrepeat $colheight ""] + } else { + set underlines [split $underblock \n] + } + #if {$underblock eq ""} { + # set blank "\x1b\[0m\x1b\[0m" + # #set underlines [list "\x1b\[0m\x1b\[0m"] + # set underlines [lrepeat $colheight $blank] + #} else { + # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW + # set underlines [lines_as_list -ansiresets 1 $underblock] + #} + # -- --- --- --- + + #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. + #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output colwidth + #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. + #(in cases where there are interline moves or cursor jumps anyway) + #This works - but doesn't seem efficient. + #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first + + #a hack until we work out how to avoid infinite loops... + # + set looplimit [dict get $opts -looplimit] + if {$looplimit eq "\uFFEF"} { + #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? + #do we need any margin above the length? (telnet mapscii.me test) + set looplimit [expr {[string length $overblock] + 10}] + } + + if {!$test_mode} { + set inputchunks [split $overblock \n] + } else { + set scheme 3 + switch -- $scheme { + 0 { + #one big chunk + set inputchunks [list $overblock] + } + 1 { + set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 2 { + + #split into lines if possible first - then into plaintext/ansi-sequence chunks ? + set inputchunks [list ""] ;#put an empty plaintext split in for starters + set i 1 + set lines [split $overblock \n] + foreach ln $lines { + if {$i < [llength $lines]} { + append ln \n + } + set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? + set lastpt [lindex $inputchunks end] + lset inputchunks end [string cat $lastpt [lindex $sequence_split 0]] + lappend inputchunks {*}[lrange $sequence_split 1 end] + incr i + } + } + 3 { + #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice + set lflines [list] + set inputchunks [split $overblock \n] + foreach ln $inputchunks { + append ln \n + lappend lflines $ln + } + if {[llength $lflines]} { + lset lflines end [string range [lindex $lflines end] 0 end-1] + } + set inputchunks $lflines[unset lflines] + + } + } + } + + + #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height + #lassign [blocksize $overblock] _w overblock_width _h overblock_height + + + set replay_codes_underlay [dict create 1 ""] + #lappend replay_codes_overlay "" + set replay_codes_overlay "" + set unapplied "" + set cursor_saved_position [dict create] + set cursor_saved_attributes "" + + + set outputlines $underlines + set overidx 0 + + #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext + set row 1 + if {$data_mode} { + set col [_get_row_append_column $row] + } else { + set col 1 + } + + set instruction_stats [dict create] + + set loop 0 + #while {$overidx < [llength $inputchunks]} { } + + while {[llength $inputchunks]} { + #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" + set overtext [lpop inputchunks 0] + if {![string length $overtext]} { + incr loop + continue + } + #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" + set undertext [lindex $outputlines [expr {$row -1}]] + set renderedrow $row + + #renderline pads each underaly line to width with spaces and should track where end of data is + + + #set overtext [string cat [lindex $replay_codes_overlay $overidx] $overtext] + set overtext [string cat $replay_codes_overlay $overtext] + if {[dict exists $replay_codes_underlay $row]} { + set undertext [string cat [dict get $replay_codes_underlay $row] $undertext] + } + #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - + #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l + set LASTCALL [list -info 1 -insert_mode $insert_mode -autowrap_mode $autowrap_mode -transparent $opt_transparent -width $colwidth -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] + set rinfo [renderline -experimental $opt_experimental\ + -info 1\ + -insert_mode $insert_mode\ + -cursor_restore_attributes $cursor_saved_attributes\ + -autowrap_mode $autowrap_mode\ + -transparent $opt_transparent\ + -width $colwidth\ + -exposed1 $opt_exposed1\ + -exposed2 $opt_exposed2\ + -overflow $opt_overflow\ + -cursor_column $col\ + -cursor_row $row\ + $undertext\ + $overtext\ + ] + set instruction [dict get $rinfo instruction] + set insert_mode [dict get $rinfo insert_mode] + set autowrap_mode [dict get $rinfo autowrap_mode] ;# + #set reverse_mode [dict get $rinfo reverse_mode];#how to support in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? + set rendered [dict get $rinfo result] + set overflow_right [dict get $rinfo overflow_right] + set overflow_right_column [dict get $rinfo overflow_right_column] + set unapplied [dict get $rinfo unapplied] + set unapplied_list [dict get $rinfo unapplied_list] + set post_render_col [dict get $rinfo cursor_column] + set post_render_row [dict get $rinfo cursor_row] + set c_saved_pos [dict get $rinfo cursor_saved_position] + set c_saved_attributes [dict get $rinfo cursor_saved_attributes] + set visualwidth [dict get $rinfo visualwidth] + set insert_lines_above [dict get $rinfo insert_lines_above] + set insert_lines_below [dict get $rinfo insert_lines_below] + dict set replay_codes_underlay [expr {$renderedrow+1}] [dict get $rinfo replay_codes_underlay] + #lset replay_codes_overlay [expr $overidx+1] [dict get $rinfo replay_codes_overlay] + set replay_codes_overlay [dict get $rinfo replay_codes_overlay] + + + + #-- todo - detect looping properly + if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { + puts stderr "overtype::renderspace loop?" + puts [ansistring VIEW $rinfo] + break + } + #-- + + if {[dict size $c_saved_pos] >= 1} { + set cursor_saved_position $c_saved_pos + set cursor_saved_attributes $c_saved_attributes + } + + + set overflow_handled 0 + + + + set nextprefix "" + + + #todo - handle potential insertion mode as above for cursor restore? + #keeping separate branches for debugging - review and merge as appropriate when stable + dict incr instruction_stats $instruction + switch -- $instruction { + {} { + if {$test_mode == 0} { + incr row + if {$data_mode} { + set col [_get_row_append_column $row] + if {$col > $colwidth} { + + } + } else { + set col 1 + } + } else { + #lf included in data + set row $post_render_row + set col $post_render_col + + #set col 1 + #if {$post_render_row != $renderedrow} { + # set col 1 + #} else { + # set col $post_render_col + #} + } + } + up { + + #renderline knows it's own line number, and knows not to go above row l + #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. + #row returned should be correct. + #column may be the overflow column - as it likes to report that to the caller. + + #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. + #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review + #puts stderr "up $post_render_row" + #puts stderr "$rinfo" + + #puts stdout "1 row:$row col $col" + set row $post_render_row + #data_mode (naming?) determines if we move to end of existing data or not. + #data_mode 0 means ignore existing line length and go to exact column + #set by -experimental flag + if {$data_mode == 0} { + set col $post_render_col + } else { + #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data + #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $colwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $colwidth + } + } + + #puts stdout "2 row:$row col $col" + #puts stdout "-----------------------" + #puts stdout $rinfo + #flush stdout + } + down { + if {$data_mode == 0} { + #renderline doesn't know how far down we can go.. + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + set row $post_render_row + set col $post_render_col + } else { + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $colwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $colwidth + } + + } + } + restore_cursor { + #testfile belinda.ans uses this + + #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" + if {[dict exists $cursor_saved_position row]} { + set row [dict get $cursor_saved_position row] + set col [dict get $cursor_saved_position column] + #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" + #set nextprefix $cursor_saved_attributes + #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes + set replay_codes_overlay [dict get $rinfo replay_codes_overlay]$cursor_saved_attributes + #set replay_codes_overlay $cursor_saved_attributes + set cursor_saved_position [dict create] + set cursor_saved_attributes "" + } else { + #TODO + #?restore without save? + #should move to home position and reset ansi SGR? + #puts stderr "overtype::renderspace cursor_restore without save data available" + } + #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it + #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. + if {!$overflow_handled && $overflow_right ne ""} { + #wrap before restore? - possible effect on saved cursor position + #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc + #we can just insert another call to renderline to solve this.. ? + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks + + puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" + + set sub_info [overtype::renderline -info 1 -width $colwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [dict get $opts -overflow] "" $overflow_right] + set foldline [dict get $sub_info result] + set insert_mode [dict get $sub_info insert_mode] ;#probably not needed.. + set autowrap_mode [dict get $sub_info autowrap_mode] ;#nor this.. + linsert outputlines $renderedrow $foldline + #review - row & col set by restore - but not if there was no save.. + } + set overflow_handled 1 + + } + move { + ######## + if {$post_render_row > [llength $outputlines]} { + #Ansi moves need to create new lines ? + #if {$opt_appendlines} { + # set diff [expr {$post_render_row - [llength $outputlines]}] + # if {$diff > 0} { + # lappend outputlines {*}[lrepeat $diff ""] + # } + # set row $post_render_row + #} else { + set row [llength $outputlines] + #} + } else { + set row $post_render_row + } + ####### + set col $post_render_col + #overflow + unapplied? + } + lf_start { + #raw newlines - must be test_mode + # ---------------------- + #test with fruit.ans + #test - treating as newline below... + #append rendered $overflow_right + #set overflow_right "" + set row $renderedrow + incr row + if {$row > [llength $outputlines]} { + lappend outputlines "" + } + set col 1 + # ---------------------- + } + lf_mid { + + if 0 { + #set rhswidth [punk::ansi::printing_length $overflow_right] + #only show debug when we have overflow? + set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] + set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] + + set rhs "" + if {$overflow_right ne ""} { + set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $overflow_right]] + set rhs [textblock::frame -title overflow_right $rhs] + } + puts [textblock::join $lhs " $post_render_col " $rhs] + } + + if {!$test_mode} { + #rendered + append rendered $overflow_right + #set replay_codes_overlay "" + set overflow_right "" + + + set row $renderedrow + + set col 1 + incr row + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + set edit_mode 0 + if {$edit_mode} { + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + set overflow_right "" + set unapplied "" + set row $post_render_row + #set col $post_render_col + set col 1 + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + append rendered $overflow_right + set overflow_right "" + set row $post_render_row + set col 1 + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } + } + } + lf_overflow { + #linefeed after colwidth e.g at column 81 for an 80 col width + #we may also have other control sequences that came after col 80 e.g cursor save + + if 0 { + set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] + set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] + set rhs "" + + #assertion - there should be no overflow.. + puts $lhs + } + assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right + + set row $post_render_row + #set row $renderedrow + #incr row + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + set col 1 + + } + newlines_above { + #we get a newlines_above instruction when received at column 1 + #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) + #in other cases - we want to treat at column 1 the same as any other + + puts "--->newlines_above" + puts "rinfo: $rinfo" + #renderline doesn't advance the row for us - the caller has the choice to implement or not + set row $post_render_row + set col $post_render_col + if {$insert_lines_above > 0} { + set row $renderedrow + set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] + incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above + #? set row $post_render_row #can renderline tell us? + } + } + newlines_below { + #obsolete? - use for ANSI insert lines sequence + if {$data_mode == 0} { + puts --->nl_below + set row $post_render_row + set col $post_render_col + if {$insert_lines_below == 1} { + if {$test_mode == 0} { + set row $renderedrow + set outputlines [linsert $outputlines [expr {$renderedrow }] {*}[lrepeat $insert_lines_below ""]] ;#note - linsert can add to end too + incr row $insert_lines_below + set col 1 + } else { + #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] + #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] + #set rhs "" + #if {$overflow_right ne ""} { + # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] + # set rhs [textblock::frame -title overflow_right $rhs] + #} + #puts [textblock::join $lhs $rhs] + + #rendered + append rendered $overflow_right + # + + + set overflow_right "" + set row $renderedrow + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat $insert_lines_below ""] + } + incr row $insert_lines_below + set col 1 + + + + } + } + } else { + set row $post_render_row + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } else { + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $colwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $colwidth + } + } + } + } + wrapmoveforward { + #doesn't seem to be used by fruit.ans testfile + #used by dzds.ans + #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO + set c $colwidth + set r $post_render_row + if {$post_render_col > $colwidth} { + set i $c + while {$i <= $post_render_col} { + if {$c == $colwidth+1} { + incr r + if {$opt_appendlines} { + if {$r < [llength $outputlines]} { + lappend outputlines "" + } + } + set c 1 + } else { + incr c + } + incr i + } + set col $c + } else { + #why are we getting this instruction then? + puts stderr "wrapmoveforward - test" + set r [expr {$post_render_row +1}] + set c $post_render_col + } + set row $r + set col $c + } + wrapmovebackward { + set c $colwidth + set r $post_render_row + if {$post_render_col < 1} { + set c 1 + set i $c + while {$i >= $post_render_col} { + if {$c == 0} { + if {$r > 1} { + incr r -1 + set c $colwidth + } else { + #leave r at 1 set c 1 + #testfile besthpav.ans first line top left border alignment + set c 1 + break + } + } else { + incr c -1 + } + incr i -1 + } + set col $c + } else { + puts stderr "Wrapmovebackward - but postrendercol >= 1???" + } + set row $r + set col $c + } + overflow { + #normal single-width grapheme overflow + #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + set row $post_render_row ;#renderline will not advance row when reporting overflow char + if {$autowrap_mode} { + incr row + set col 1 ;#whether wrap or not - next data is at column 1 ?? + } else { + #this works for test_mode (which should become the default) - but could give a bad result otherwise - review - add tests fix. + set col $post_render_col + #set unapplied "" ;#this seems wrong? + #set unapplied [string range $unapplied 1 end] + #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs + #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate + #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' + set idx 0 + set next_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set next_grapheme_index $idx + break + } + incr idx + } + assert {$next_grapheme_index >= 0} + #drop the overflow grapheme - keeping all codes in place. + set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] + #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines + + set overflow_handled 1 + #handled by dropping overflow if any + } + } + overflow_splitchar { + set row $post_render_row ;#renderline will not advance row when reporting overflow char + + #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts + #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc + if {$autowrap_mode} { + if {$colwidth < 2} { + #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } else { + set col 1 + incr row + } + } else { + set overflow_handled 1 + #handled by dropping entire overflow if any + if {$colwidth < 2} { + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } + } + + } + vt { + + #can vt add a line like a linefeed can? + set row $post_render_row + set col $post_render_col + } + default { + puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" + } + + } + + + if {!$opt_overflow && !$autowrap_mode} { + #not allowed to overflow column or wrap therefore we get overflow data to truncate + if {[dict get $opts -ellipsis]} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[string trim $lostdata] eq ""} { + set show_ellipsis 0 + } + #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] + if {[string trim [punk::ansi::stripansi $lostdata]] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + set overflow_handled 1 + } else { + #no wrap - no ellipsis - silently truncate + set overflow_handled 1 + } + } + + + + if {$renderedrow <= [llength $outputlines]} { + lset outputlines [expr {$renderedrow-1}] $rendered + } else { + if {$opt_appendlines} { + lappend outputlines $rendered + } else { + #? + lset outputlines [expr {$renderedrow-1}] $rendered + } + } + + if {!$overflow_handled} { + append nextprefix $overflow_right + } + + append nextprefix $unapplied + + if 0 { + if {$nextprefix ne ""} { + set nextoveridx [expr {$overidx+1}] + if {$nextoveridx >= [llength $inputchunks]} { + lappend inputchunks $nextprefix + } else { + #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] + set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] + } + } + } + + if {$nextprefix ne ""} { + set inputchunks [linsert $inputchunks 0 $nextprefix] + } + + + incr overidx + incr loop + if {$loop >= $looplimit} { + puts stderr "overtype::renderspace looplimit reached ($looplimit)" + lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" + set Y [a+ yellow bold] + set RST [a] + set sep_header ----DEBUG----- + set debugmsg "" + append debugmsg "${Y}${sep_header}${RST}" \n + append debugmsg "looplimit $looplimit reached\n" + append debugmsg "test_mode:$test_mode\n" + append debugmsg "data_mode:$data_mode\n" + append debugmsg "opt_appendlines:$opt_appendlines\n" + append debugmsg "prev_row :[dict get $LASTCALL -cursor_row]\n" + append debugmsg "prev_col :[dict get $LASTCALL -cursor_column]\n" + dict for {k v} $rinfo { + append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n + } + append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n + + puts stdout $debugmsg + #todo - config regarding error dumps rather than just dumping in working dir + set fd [open [pwd]/error_overtype.txt w] + puts $fd $debugmsg + close $fd + error $debugmsg + break + } + } + + set result [join $outputlines \n] + if {$info_mode} { + #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? + #append result \n$instruction_stats\n + } + return $result + } + + #todo - left-right ellipsis ? + proc 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 argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 {} + default { + set known_opts [dict keys $defaults] + 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 "[punk::ansi::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] + set overflow_right [dict get $rinfo overflow_right] + set unapplied [dict get $rinfo unapplied] + #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 + #don't use string range on ANSI data + #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + 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] + } + + #overtype::right is for a rendered ragged underblock and a rendered ragged overblock + #ie we can determine the block width for bost by examining the lines and picking the longest. + # + proc 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 argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align {} + default { + set known_opts [dict keys $defaults] + 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 "[punk::ansi::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}] + switch -- $opt_align { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + 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 left {args} { + overtype::block -blockalign left {*}$args + } + #overtype a (possibly ragged) underblock with a (possibly ragged) overblock + proc block {args} { + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + foreach {underblock overblock} [lrange $args end-1 end] break + + set defaults [dict create\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -textalign "left"\ + -textvertical "top"\ + -blockalign "left"\ + -blockalignbias left\ + -blockvertical "top"\ + ] + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + switch -- $k { + -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical {} + default { + set known_opts [dict keys $defaults] + error "overtype::block 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_textalign [dict get $opts -textalign] + set opt_blockalign [dict get $opts -blockalign] + if {$opt_blockalign eq "center"} { + set opt_blockalign "centre" + } + # -- --- --- --- --- --- + + 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)}] + + switch -- $opt_blockalign { + left { + set left_exposed 0 + } + right { + set left_exposed $under_exposed_max + } + centre { + 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 -blockalignbias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + } + default { + set left_exposed 0 + } + } + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::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}] + switch -- $opt_textalign { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + 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] + set overflow_right [dict get $rinfo overflow_right] + set unapplied [dict get $rinfo unapplied] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use string range on ANSI data + #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[string trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] + } + } + + #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] + set overflow_right [dict get $rinfo overflow_right] + set unapplied [dict get $rinfo unapplied] + 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] + } + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. + # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # + # + #-returnextra enables 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 + #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char) + #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 renderline {args} { + #*** !doctools + #[call [fun overtype::renderline] [arg args] ] + #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell + #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts + #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal + #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. + #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. + #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. + #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay + #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. + #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. + #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + # + #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. + #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. + #[para] The main 3 are the result, overflow_right, and unapplied. + #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. + + 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\ + -etabs 0\ + -width \uFFEF\ + -overflow 0\ + -transparent 0\ + -startcolumn 1\ + -cursor_column 1\ + -cursor_row ""\ + -insert_mode 1\ + -autowrap_mode 1\ + -reverse_mode 0\ + -info 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -cursor_restore_attributes ""\ + -cp437 0\ + -experimental {}\ + ] + #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller + + #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 argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + switch -- $k { + -experimental - -cp437 - -width - -overflow - -transparent - -startcolumn - -cursor_column - -cursor_row - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes {} + default { + set known_opts [dict keys $defaults] + error "overtype::renderline unknown option '$k'. Known options: $known_opts" + } + } + } + set opts [dict merge $defaults $argsflags] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_width [dict get $opts -width] + set opt_etabs [dict get $opts -etabs] + 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'" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) + 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_autowrap_mode [dict get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line + set opt_reverse_mode [dict get $opts -reverse_mode] ;#DECSNM + # -- --- --- --- --- --- --- --- --- --- --- --- + set temp_cursor_saved [dict get $opts -cursor_restore_attributes] + + set test_mode 0 + set cp437_glyphs [dict get $opts -cp437] + foreach e [dict get $opts -experimental] { + switch -- $e { + test_mode { + set test_mode 1 + set cp437_glyphs 1 + } + } + } + set test_mode 1 ;#try to elminate + set cp437_map [dict create] + if {$cp437_glyphs} { + set cp437_map [set ::punk::ansi::cp437_map] + #for cp437 images we need to map these *after* splitting ansi + #some old files might use newline for its glyph.. but we can't easily support that. + #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? + dict unset cp437_map \n + } + + 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 1 + } else { + set cursor_row $opt_row_context + } + + + #----- + # + if {[info exists punk::console::tabwidth]} { + #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted + #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + + set overdata $over + if {!$cp437_glyphs} { + #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text + if {!$opt_etabs} { + if {[string first \t $under] >= 0} { + #set under [textutil::tabify::untabify2 $under] + set under [textutil::tabify::untabifyLine $under $tw] + } + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over $tw] + } + } + } + #------- + + #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. + + # -- --- --- --- --- --- --- --- + if {$under ne ""} { + set undermap [punk::ansi::ta::split_codes_single $under] + } else { + set undermap [list] + } + set understacks [list] + set understacks_gx [list] + + 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 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 + if {$cp437_glyphs} { + set pt [string map $cp437_map $pt] + } + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + 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 width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character + set width 1 + } else { + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] + set grapheme $gvis + set width 1 + } + } + } + } + } + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #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? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $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 + if {$code ne ""} { + set c1c2 [string range $code 0 1] + set leadernorm [string range [string map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + + switch -- $leadernorm { + 7CSI - 8CSI { + #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse + #REVIEW - what else could end in m but be mistaken as a normal SGR code here? + set maybemouse "" + if {[string index $c1c2 0] eq "\x1b"} { + set maybemouse [string index $code 2] + } + + if {$maybemouse ne "<" && [string index $code end] eq "m"} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set u_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set u_codestack [list $code] + } else { + #basic simplification first.. straight dups + set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars + set u_codestack [lremove $u_codestack {*}$dup_posns] + lappend u_codestack $code + } + } + } + 7GFX { + switch -- [string index $code 2] { + "0" { + set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess + } + B { + set u_gx_stack [list] + } + } + } + default { + + } + + } + + #if {[punk::ansi::codetype::is_sgr_reset $code]} { + # #set u_codestack [list] + #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + #} elseif {[punk::ansi::codetype::is_sgr $code]} { + #} else { + # #leave SGR stack as is + # if {[punk::ansi::codetype::is_gx_open $code]} { + # } elseif {[punk::ansi::codetype::is_gx_close $code]} { + # } + #} + } + #consider also if there are other codes that should be stacked..? + } + + if {!$test_mode} { + #fill columns to width with spaces, and carry over stacks - we will have to keep track of where the underlying data ends manually - TODO + #Specifying a width is suitable for terminal-like applications and text-blocks + if {$opt_width ne "\uFFEF"} { + if {[llength $understacks]} { + set cs $u_codestack + set gs $u_gx_stack + } else { + set cs [list] + set gs [list] + } + if {[llength $undercols]< $opt_width} { + set diff [expr {$opt_width- [llength $undercols]}] + if {$diff > 0} { + lappend undercols {*}[lrepeat $diff " "] + lappend understacks {*}[lrepeat $diff $cs] + lappend understacks_gx {*}[lrepeat $diff $gs] + } + } + } + } else { + #NULL empty cell indicator + if {$opt_width ne "\uFFEF"} { + if {[llength $understacks]} { + set cs $u_codestack + set gs $u_gx_stack + } else { + set cs [list] + set gs [list] + } + if {[llength $undercols]< $opt_width} { + set diff [expr {$opt_width- [llength $undercols]}] + if {$diff > 0} { + lappend undercols {*}[lrepeat $diff "\u0000"] + lappend understacks {*}[lrepeat $diff $cs] + lappend understacks_gx {*}[lrepeat $diff $gs] + } + } + } + + } + if {$opt_width ne "\uFFEF"} { + set colwidth $opt_width + } else { + set colwidth [llength $undercols] + } + + + if 0 { + # ----------------- + # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose + # Review. + # ----------------- + #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 $understacks]} { + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + } else { + #in case overlay onto emptystring as underlay + lappend understacks [list] + lappend understacks_gx [list] + } + # ----------------- + } + + #trailing codes in effect for underlay + if {[llength $u_codestack]} { + #set replay_codes_underlay [join $u_codestack ""] + set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] + } else { + set replay_codes_underlay "" + } + + + # -- --- --- --- --- --- --- --- + #### + #if opt_colstart - we need to build a space (or any singlewidth char ?) 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 + #TODO - make a little virtual column object + #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn + #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. + + + #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 [list] + set overstacks_gx [list] + + 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 + #experiment + set overlay_grapheme_control_stacks [list] + foreach {pt code} $overmap { + + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [string map $cp437_map $pt] + } + append pt_overchars $pt + #will get empty pt between adjacent codes + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + + #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 ""} { + lappend overlay_grapheme_control_stacks $o_codestack + #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 "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues + 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]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b7|\x1b\[s} $code]} { + #experiment + #cursor_save - for the replays review. + #jmn + #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + lappend overlay_grapheme_control_list [list other $code] + } elseif {[regexp {\x1b8|\x1b\[u} $code]} { + #experiment + #cursor_restore - for the replays + set o_codestack [list $temp_cursor_saved] + lappend overlay_grapheme_control_list [list other $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}] + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + + #set replay_codes_overlay [join $o_codestack ""] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$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 perform a loop break and force in_excess to 1 + if {$opt_overflow} { + #somewhat counterintuitively - overflow true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. + set overflow_idx -1 + } else { + #overflow zero - we can't grow beyond our column width - so we get ellipsis or truncation + if {$opt_width ne "\uFFEF"} { + set overflow_idx [expr {$opt_width}] + } else { + #review - this is also the cursor position when adding a char at end of line? + 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 unapplied_list [list] + + set insert_lines_above 0 ;#return key + set insert_lines_below 0 + set instruction "" + + # -- --- --- + #cursor_save_dec, cursor_restore_dec etc + set cursor_restore_required 0 + set cursor_saved_attributes "" + set cursor_saved_position "" + # -- --- --- + + #set idx 0 ;# line index (cursor - 1) + #set idx [expr {$opt_colstart + $opt_colcursor} -1] + + #idx is the per column output index + 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 + #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. + #(for now we are incrementing/decrementing both in sync - which is a bit silly) + set cursor_column $opt_colcursor + + #idx_over is the per grapheme overlay index + 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 autowrap_mode $opt_autowrap_mode ;#default 1 + + + #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 {} + switch -- $type { + g { + set ch $item + incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. + if {($idx < ($opt_colstart -1))} { + incr idx [grapheme_width_cached $ch] + continue + } + #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width + set within_undercols [expr {$idx <= $colwidth-1}] + + #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters + #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, + #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. + #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable + #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE + + set chtest [string map [list \n \x85 \b \r \v \x7f ] $ch] + #puts --->chtest:$chtest + #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached + switch -- $chtest { + "" { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + if {$idx == 0} { + #puts "---a at col 1" + #linefeed at column 1 + #leave the overflow_idx ;#? review + set instruction lf_start ;#specific instruction for newline at column 1 + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { + #linefeed after final column + #puts "---c at overflow_idx=$overflow_idx" + incr cursor_row + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 + set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + #linefeed occurred in middle or at end of text + #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" + incr cursor_row + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 + set instruction lf_mid + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } + + } + "" { + #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) + #So far we are assuming the caller has translated to and handle above.. REVIEW. + + #consider also the old space-carriagereturn softwrap convention used in some terminals. + #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. + set idx [expr {$opt_colstart -1}] + set cursor_column $opt_colstart ;#? + } + "" { + #literal backspace char - not necessarily from keyboard + #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype + #(important for -transparent option - hence replacement chars for half-exposed etc) + #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 + incr cursor_column -1 + } else { + set flag 0 + if $flag { + #review - conflicting requirements? Need a different sequence for destructive interactive backspace? + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction backspace_at_start + break + } + } + } + "" { + #literal del character - some terminals send just this for what is generally expected to be a destructive backspace + #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. + priv::render_delchar $idx + } + "" { + #end processing this overline. rest of line is remainder. cursor for column as is. + #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) + #e.g it could be configured to jump down 6 rows. + #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. + #todo? + incr cursor_row + set overflow_idx $idx + #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction vt + break + } + default { + if {$overflow_idx != -1} { + #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? + #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? + #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc + if {$idx == $overflow_idx-1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 2} { + #review split 2w overflow? + #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line + #better to consider the overlay char as unable to be applied to the line + #render empty string to column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied + #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #change the overflow_idx + set overflow_idx $idx + incr idx + incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used + priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci + #throw back to caller's loop - add instruction to caller as this is not the usual case + #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line + set instruction overflow_splitchar + break + } elseif {$owidth > 2} { + #? tab? + #TODO! + puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" + #tab of some length dependent on tabstops/elastic tabstop settings? + } + } elseif {$idx >= $overflow_idx} { + #jmn? + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #don't incr idx beyond the overflow_idx + #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied + incr idx_over -1 + #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } + } else { + #review. + #This corresponds to opt_overflow being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) + } + + if {($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? + lset understacks $idx [list] + incr idx + incr cursor_column + } 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 + incr cursor_column + } elseif {$uwidth == 0} { + #e.g control char ? combining diacritic ? + incr idx + incr cursor_column + } elseif {$uwidth == 1} { + set owidth [grapheme_width_cached $ch] + incr idx + incr cursor_column + if {$owidth > 1} { + incr idx + incr cursor_column + } + } elseif {$uwidth > 1} { + if {[grapheme_width_cached $ch] == 1} { + if {!$insert_mode} { + #normal singlewide transparent overlay onto double-wide underlay + 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 + incr cursor_column + } else { + if {[regexp $opt_transparent $next_pt_overchar]} { + incr idx + incr cursor_column + } 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 + priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } + } else { + #? todo - decide what transparency even means for insert mode + incr idx + incr cursor_column + } + } else { + #2wide transparency over 2wide in underlay - review + incr idx + incr cursor_column + } + } + } + } else { + + set idxchar [lindex $outcols $idx] + #non-transparent char in overlay or empty cell + if {$idxchar eq "\u0000"} { + #empty/erased cell indicator + set uwidth 1 + } else { + set uwidth [grapheme_width_cached $idxchar] + } + if {$within_undercols} { + if {$idxchar eq ""} { + #2nd col of 2wide char in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 + #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 (REVIEW - when would it not be??) + #reset previous to an exposed 1st-half - but leave understacks code as is + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 + } + incr idx + } else { + set prevcolinfo [lindex $outcols $idx-1] + #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right + #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) + #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char + #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises + #It is perhaps best avoided at another level and try to make renderline do exactly as it's told + #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index + if {$prevcolinfo ne ""} { + #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx + priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert + } ;# else?? + incr idx + } + if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { + incr cursor_column + } + } elseif {$uwidth == 0} { + #what if this is some other c0/c1 control we haven't handled specifically? + + #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it + #e.g combining diacritic - increment before over char REVIEW + #arguably the previous overchar should have done this - ie lookahead for combiners? + #if we can get a proper grapheme_split function - this should be easier to tidy up. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column 2 + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } elseif {$uwidth == 1} { + #includes null empty cells + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $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] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { + priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode + } + incr idx + } + if {($cursor_column < [llength $outcols]) || $overflow_idx == -1 || $test_mode} { + incr cursor_column + } + } elseif {$uwidth > 1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 1} { + #1wide over 2wide in underlay + if {!$insert_mode} { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $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 { + #insert mode just pushes all to right - no exposition char here + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + } + } else { + #2wide over 2wide + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx 2 + incr cursor_column 2 + } + + if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { + set cursor_column [llength $outcols] + } + } + } else { + priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + incr idx + incr cursor_column + if {$overflow_idx !=-1 && !$test_mode} { + #overflow + if {$cursor_column > [llength $outcols]} { + set cursor_column [llength $outcols] + } + } + } + } + } + } ;# end switch + + + } + other { + set code $item + #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' + + set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM + 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$} ;# or "f" ? + set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} + set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! + set re_cursor_restore {\x1b\[u$} + set re_cursor_save_dec {\x1b7$} + set re_cursor_restore_dec {\x1b8$} + set re_other_single {\x1b(D|M|E)$} + set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins + set matchinfo [list] + + #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI + #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping + #review - cost/benefit of function calls within these switch-arms instead of inline code? + + #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. + #we should probably therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore + set code [string map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $code] + + + set c1 [string index $code 0] + set c1c2c3 [string range $code 0 2] + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + set leadernorm [string range [string map [list\ + \x1b\[< 1006\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\] 7OSC\ + \x9d 8OSC\ + \x1b 7ESC\ + ] $c1c2c3] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + + #we leave the tail of the code unmapped for now + switch -- $leadernorm { + 1006 { + #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html + #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release + set codenorm [string cat $leadernorm [string range $code 3 end]] + } + 7CSI - 7OSC { + set codenorm [string cat $leadernorm [string range $code 2 end]] + } + 7ESC { + set codenorm [string cat $leadernorm [string range $code 1 end]] + } + 8CSI - 8OSC { + set codenorm [string cat $leadernorm [string range $code 1 end]] + } + default { + #we haven't made a mapping for this + set codenorm $code + } + } + + #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. + switch -- $leadernorm { + 1006 { + #TODO + # + switch -- [string index $codenorm end] { + M { + puts stderr "mousedown $codenorm" + } + m { + puts stderr "mouseup $codenorm" + } + } + + } + {7CSI} - {8CSI} { + set param [string range $codenorm 4 end-1] + #puts stdout "--> CSI [string index $leadernorm 0] bit param:$param" + switch -- [string index $codenorm end] { + D { + #Col move + #puts stdout "<-back" + #cursor back + #left-arrow/move-back when ltr mode + set num $param + if {$num eq ""} {set num 1} + + set version 2 + if {$version eq "2"} { + #todo - startcolumn offset! + if {$cursor_column - $num >= 1} { + incr idx -$num + incr cursor_column -$num + } else { + if {!$autowrap_mode} { + set cursor_column 1 + set idx 0 + } else { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr cursor_column -$num + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmovebackward + break + } + } + } else { + incr idx -$num + incr cursor_column -$num + if {$idx < $opt_colstart-1} { + #wrap to previous line and position cursor at end of data + set idx [expr {$opt_colstart-1}] + set cursor_column $opt_colstart + } + } + } + C { + #Col move + #puts stdout "->forward" + #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. + #cursor forward + #right-arrow/move forward + set num $param + if {$num eq ""} {set num 1} + + #todo - retrict to moving 1 position past datalen? restrict to column width? + #should ideally wrap to next line when interactive and not on last row + #(some ansi art seems to expect this behaviour) + #This presumably depends on the terminal's wrap mode + #e.g DECAWM autowrap mode + # CSI ? 7 h - set: autowrap (also tput smam) + # CSI ? 7 l - reset: no autowrap (also tput rmam) + set version 2 + if {$version eq "2"} { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$test_mode && $cursor_column == $max+1} { + #move_forward while in overflow + incr cursor_column -1 + } + + if {($cursor_column + $num) <= $max} { + incr idx $num + incr cursor_column $num + } else { + if {$autowrap_mode} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #jmn + if {$idx == $overflow_idx} { + incr num + } + + #horizontal movement beyond line extent needs to wrap - throw back to caller + #we may have both overflow_rightand unapplied data + #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) + #leave row as is - caller will need to determine how many rows the column-movement has consumed + incr cursor_column $num ;#give our caller the necessary info as columns from start of row + #incr idx_over + #should be gci following last one applied + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmoveforward + break + } else { + set cursor_column $max + set idx [expr {$cursor_column -1}] + } + } + } else { + if {!$opt_overflow || ($cursor_column + $num) <= [llength $outcols+1]} { + incr idx $num + incr cursor_column $num + } else { + if {!$insert_mode} { + #block editing style with arrow keys + #overtype mode + set idxstart $idx + set idxend [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 + incr cursor_column $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 {$idx < [llength $understacks]} { + set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + } else { + set stackinfo [list] + } + if {$idx < [llength $understacks_gx]} { + #set gxstackinfo [dict get $understacks_gx $idx] + set gxstackinfo [lindex $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 + incr cursor_column + priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode + } + } else { + #normal - insert + incr idx $num + incr cursor_column $num + if {$idx > [llength $outcols]} { + set idx [llength $outcols];#allow one beyond - for adding character at end of line + set cursor_column [expr {[llength $outcols]+1}] + } + } + } + } + } + G { + #Col move + #move absolute column + #adjust to colstart - as column 1 is within overlay + #??? + set idx [expr {$param + $opt_colstart -1}] + set cursor_column $param + error "renderline absolute col move ESC G unimplemented" + } + A { + #Row move - up + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + set num $param + if {$num eq ""} {set num 1} + incr cursor_row -$num + + if {$cursor_row < 1} { + set cursor_row 1 + } + + #ensure rest of *overlay* is emitted to remainder + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up + #retain cursor_column + break + } + B { + #Row move - down + set num $param + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move down + if {$num eq ""} {set num 1} + incr cursor_row $num + + + incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + H - f { + #$re_both_move + lassign [split $param {;}] row col + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #lassign $matchinfo _match row col + + if {$col eq ""} {set col 1} + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$col > $max} { + set cursor_column $max + } else { + set cursor_column $col + } + set idx [expr {$cursor_column -1}] + + if {$row eq ""} {set row 1} + set cursor_row $row + if {$cursor_row < 1} { + set cursor_row 1 + } + + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + X { + puts stderr "X - $param" + #ECH - erase character + if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase + priv::render_erasechar $idx $param + #cursor position doesn't change. + } + r { + #$re_decstbm + #https://www.vt100.net/docs/vt510-rm/DECSTBM.html + #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins + lassign [split $param {;}] margin_top margin_bottom + + #todo - return these for the caller to process.. + puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" + #Also moves the cursor to col 1 line 1 of the page + set cursor_column 1 + set cursor_row 1 + + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move ;#own instruction? decstbm? + break + } + s { + # - todo - make ansi.sys CSI s cursor save only apply for certain cases? - may need to support DECSLRM instead which uses same code + + #$re_cursor_save + #cursor save could come after last column + if {$overflow_idx != -1 && $idx == $overflow_idx} { + #bartman2.ans test file - fixes misalignment at bottom of dialog bubble + #incr cursor_row + #set cursor_column 1 + #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) + set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] + } else { + set cursor_saved_position [list row $cursor_row column $cursor_column] + } + #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. + #we need the SGR and gx overlay codes prior to the cursor_save + + #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. + #set sgr_stack [lindex $understacks $idx] + #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) + + set sgr_stack [list] + set gx_stack [list] + + #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. + #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. + + foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { + lassign $gc type code + #types g other sgr gx0 + switch -- $type { + gx0 { + #code is actually a stand-in for the graphics on/off code - not the raw code + #It is either gx0_on or gx0_off + set gx_stack [list $code] + } + sgr { + #code is the raw code + if {[punk::ansi::codetype::is_sgr_reset $code]} { + #jmn + set sgr_stack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set sgr_stack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #often we don't get resets - and codes just pile up. + #as a first step to simplifying - at least remove earlier straight up dupes + set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) + set sgr_stack [lremove $sgr_stack {*}$dup_posns] + lappend sgr_stack $code + } + } + } + } + set cursor_saved_attributes "" + switch -- [lindex $gx_stack 0] { + gx0_on { + append cursor_saved_attributes "\x1b(0" + } + gx0_off { + append cursor_saved_attributes "\x1b(B" + } + } + #append cursor_saved_attributes [join $sgr_stack ""] + append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] + + #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. + + #don't incr index - or the save will cause cursor to move to the right + #carry on + + } + u { + #$re_cursor_restore + #we are going to jump somewhere.. for now we will assume another line, and process accordingly. + #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) + #don't set overflow at this point. The existing underlay to the right must be preserved. + #we only want to jump and render the unapplied at the new location. + + #lset overstacks $idx_over [list] + #set replay_codes_overlay "" + + #if {$cursor_saved_attributes ne ""} { + # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk + #} else { + #jj + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + set replay_codes_overlay "" + #} + + #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + incr idx_over + + set unapplied "" + set unapplied_list [list] + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + #incr idx_over + } + set unapplied [join $unapplied_list ""] + #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. + set instruction restore_cursor + break + } + ~ { + #$re_vt_sequence + #lassign $matchinfo _match key mod + lassign [split $param {;}] 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 - presumably this shifts other chars in the line, with empty cells coming in from the end + switch -- $mod { + "" { + priv::render_delchar $idx + } + "5" { + #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) + } + } + } elseif {$key eq "4"} { + #End + } elseif {$key eq "5"} { + #pgup + } elseif {$key eq "6"} { + #pgDn + } elseif {$key eq "7"} { + #Home + #?? + set idx [expr {$opt_colstart -1}] + set cursor_column 1 + } 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 + } + + } + h - l { + #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? + + #$re_mode if first after CSI is "?" + #some docs mention ESC=h|l - not seen on windows terminals.. review + #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html + if {[string index $codenorm 4] eq "?"} { + set num [string range $codenorm 5 end-1] ;#param between ? and h|l + #lassign $matchinfo _match num type + switch -- $num { + 5 { + #DECSNM - reverse video + #How we simulate this to render within a block of text is an open question. + #track all SGR stacks and constantly flip based on the current SGR reverse state? + #It is the job of the calling loop to do this - so at this stage we'll just set the states + #DECAWM autowrap + if {$type eq "h"} { + #set (enable) + set reverse_mode 1 + } else { + #reset (disable) + set reverse_mode 0 + } + + } + 7 { + #DECAWM autowrap + if {$type eq "h"} { + #set (enable) + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? presume not - but sanity check for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline error - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + set overflow_idx -1 + } + } + 25 { + if {$type eq "h"} { + #visible cursor + + } else { + #invisible cursor + + } + } + } + + } else { + puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + default { + puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + 7ESC { + #$re_other_single + switch -- [string index $codenorm end] { + D { + #\x84 + #index (IND) + #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" + puts stderr "ESC D not fully implemented" + incr cursor_row + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + M { + #\x8D + #Reverse Index (RI) + #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" + puts stderr "ESC M not fully implemented" + + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move up + incr cursor_row -1 + if {$cursor_row < 1} { + set cursor_row 1 + } + #ensure rest of *overlay* is emitted to remainder + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up ;#need instruction for scroll-down? + #retain cursor_column + break + } + E { + #\x85 + #review - is behaviour different to lf? + #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL + #leave implementation until logic for is set in stone... still under review + #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. + # + #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" + puts stderr "ESC E unimplemented" + + } + default { + puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + + } + } + + #switch -regexp -matchvar matchinfo -- $code\ + #$re_mode { + #}\ + #default { + # puts stderr "overtype::renderline code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + #} + + } + default { + #don't need to handle sgr or gx0 types + #we have our sgr gx0 codes already in stacks for each overlay grapheme + } + } + } + + #-------- + 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 "" ;#output prior to overflow + set overflow_right "" ;#remainder after overflow point reached + set i 0 + set cstack [list] + set prevstack [list] + set prev_g0 [list] + #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 + if {$overflow_idx == 0} { + #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW + set in_overflow 1 + } + foreach ch $outcols { + #puts "---- [ansistring VIEW $ch]" + + set gxleader "" + if {$i < [llength $understacks_gx]} { + #set g0 [dict get $understacks_gx $i] + set g0 [lindex $understacks_gx $i] + if {$g0 ne $prev_g0} { + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } else { + set gxleader "\x1b(B" + } + } + set prev_g0 $g0 + } else { + set prev_g0 [list] + } + + set sgrleader "" + if {$i < [llength $understacks]} { + #set cstack [dict get $understacks $i] + set cstack [lindex $understacks $i] + if {$cstack ne $prevstack} { + if {[llength $prevstack] && ![llength $cstack]} { + #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? + append sgrleader \033\[m + } else { + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + } + } + set prevstack $cstack + } else { + set prevstack [list] + } + + + + if {$in_overflow} { + if {$i == $overflow_idx} { + set 0 [lindex $understacks_gx $i] + set gxleader "" + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } elseif {$g0 eq [list "gx0_off"]} { + set gxleader "\x1b(B" + } + append overflow_right $gxleader + set cstack [lindex $understacks $i] + set sgrleader "" + #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right + #if {[llength $prevstack] && ![llength $cstack]} { + # append sgrleader \033\[m + #} + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + append overflow_right $sgrleader + append overflow_right $ch + } else { + append overflow_right $gxleader + append overflow_right $sgrleader + append overflow_right $ch + } + } else { + if {$overflow_idx != -1 && $i+1 == $overflow_idx} { + #one before overflow + #will be in overflow in next iteration + set in_overflow 1 + if {[grapheme_width_cached $ch]> 1} { + #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) + set ch $opt_exposed1 + } + } + append outstring $gxleader + append outstring $sgrleader + if {$idx+1 < $cursor_column} { + append outstring [string map [list "\u0000" " "] $ch] + } else { + append outstring $ch + } + } + incr i + } + #flower.ans good test for null handling - reverse line building + if {![ansistring length $overflow_right]} { + set outstring [string trimright $outstring "\u0000"] + } + set outstring [string map [list "\u0000" " "] $outstring] + set overflow_right [string trimright $overflow_right "\u0000"] + set overflow_right [string map [list "\u0000" " "] $overflow_right] + + set replay_codes "" + if {[llength $understacks] > 0} { + if {$overflow_idx == -1} { + #set tail_idx [dict size $understacks] + set tail_idx [llength $understacks] + } else { + set tail_idx [llength $undercols] + } + if {$tail_idx-1 < [llength $understacks]} { + #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes + set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes + } + if {$tail_idx-1 < [llength $understacks_gx]} { + set gx0 [lindex $understacks_gx $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 [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column + + #close off any open gx? + #probably should - and overflow_right reopen? + } + + 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 + + #review + #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 + + #overflow_idx may change during ansi & character processing + if {$overflow_idx == -1} { + set overflow_right_column "" + } else { + set overflow_right_column [expr {$overflow_idx+1}] + } + set result [dict create\ + result $outstring\ + visualwidth [punk::ansi::printing_length $outstring]\ + instruction $instruction\ + stringlen [string length $outstring]\ + overflow_right_column $overflow_right_column\ + overflow_right $overflow_right\ + unapplied $unapplied\ + unapplied_list $unapplied_list\ + insert_mode $insert_mode\ + autowrap_mode $autowrap_mode\ + insert_lines_above $insert_lines_above\ + insert_lines_below $insert_lines_below\ + cursor_saved_position $cursor_saved_position\ + cursor_saved_attributes $cursor_saved_attributes\ + cursor_column $cursor_column\ + cursor_row $cursor_row\ + opt_overflow $opt_overflow\ + replay_codes $replay_codes\ + replay_codes_underlay $replay_codes_underlay\ + replay_codes_overlay $replay_codes_overlay\ + ] + if {$opt_returnextra == 1} { + return $result + } else { + #human/debug - map special chars to visual glyphs + set viewop VIEW + switch -- $opt_returnextra { + 2 { + #codes and character data + set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others + } + 3 { + set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. + } + } + dict set result result [ansistring $viewop -lf 1 -vt 1 [dict get $result result]] + dict set result overflow_right [ansistring VIEW -lf 1 -vt 1 [dict get $result overflow_right]] + dict set result unapplied [ansistring VIEW -lf 1 -vt 1 [dict get $result unapplied]] + dict set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [dict get $result unapplied_list]] + dict set result replay_codes [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes]] + dict set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes_underlay]] + dict set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes_overlay]] + dict set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [dict get $result cursor_saved_attributes]] + return $result + } + } else { + return $outstring + } + #return [join $out ""] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace overtype ---}] +} + +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 + } +} + + +# -- --- --- --- --- --- --- --- --- --- --- +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 +} + + + +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 + } + if {[string first \t $textblock] >= 0} { + if {[info exists punk::console::tabwidth]} { + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + set textblock [textutil::tabify::untabify2 $textblock $tw] + } + #stripansi on entire block in one go rather than line by line - result should be the same - review - make tests + if {[punk::ansi::ta::detect $textblock]} { + set textblock [punk::ansi::stripansi $textblock] + } + if {[string first \n $textblock] >= 0} { + set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list + set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] + } else { + set num_le 0 + set width [punk::char::ansifreestring_width $textblock] + } + #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 + } + proc render_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + #append unapplied [join [lindex $overstacks $idx_over] ""] + #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + + #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack + proc render_this_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + proc render_delchar {i} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + set nxt [llength $o] + if {$i < $nxt} { + set o [lreplace $o $i $i] + set ustacks [lreplace $ustacks $i $i] + set gxstacks [lreplace $gxstacks $i $i] + } else { + + } + } + proc render_erasechar {i count} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + #ECH clears character attributes from erased character positions + #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater. + if {![string is integer -strict $count] || $count < 1} { + error "render_erasechar count must be integer >= 1" + } + set start $i + set end [expr {$i + $count -1}] + #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? + if {$i > [llength $o]-1} { + return + } + if {$end > [llength $o]-1} { + set end [expr {[llength $o]-1}] + } + set num [expr {$end - $start + 1}] + set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? + set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]] + set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] + return + } + proc render_setchar {i c } { + upvar outcols o + lset o $i $c + } + #is actually addgrapheme? + proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + + if 0 { + if {$c eq "c"} { + puts "i:$i c:$c sgrstack:[ansistring VIEW $sgrstack]" + puts "understacks:[ansistring VIEW $ustacks]" + upvar overstacks overstacks + puts "overstacks:[ansistring VIEW $overstacks]" + puts "info level 0:[info level 0]" + } + } + + set nxt [llength $o] + if {!$insert_mode} { + if {$i < $nxt} { + #These lists must always be in sync + lset o $i $c + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + lset ustacks $i $sgrstack + lset gxstacks $i $gx0stack + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } else { + #insert of single-width vs double-width when underlying is double-width? + if {$i < $nxt} { + set o [linsert $o $i $c] + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + set ustacks [linsert $ustacks $i $sgrstack] + set gxstacks [linsert $gxstacks $i $gx0stack] + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +namespace eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [namespace eval overtype { + variable version + set version 1.6.3 +}] +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 a2fd354a..e236511c 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -106,7 +106,7 @@ namespace eval punk::ansi::class { #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. #overflow effectively auto-expands the block(terminal?) width #overflow and wrap both being true won't make sense unless we implement a max_overflow concept - set o_rendered [overtype::left -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set o_rendered [overtype::renderspace -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] if {$cksum eq "not-done"} { #if dimensions changed - the checksum won't have been done set o_rendered_what [$o_ansistringobj checksum] @@ -129,7 +129,7 @@ namespace eval punk::ansi::class { set o_dimensions $dimensions - set rendered [overtype::left -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] + set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } method render_to_input_line {args} { @@ -175,7 +175,7 @@ namespace eval punk::ansi::class { if {$opt_minus ne "0"} { set chunk [string range $chunk 0 end-$opt_minus] } - set rendered [overtype::left -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] + set rendered [overtype::renderspace -experimental {test_mode} -overflow 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] set marker "" for {set i 1} {$i <= $w} {incr i} { if {$i % 10 == 0} { @@ -190,13 +190,13 @@ namespace eval punk::ansi::class { set xline [lindex $rlines $x]\n set xlinev [ansistring VIEWSTYLE $xline] set xlinev [string map $maplf $xlinev] - set xlinedisplay [overtype::left -wrap 1 -width $w -height 1 "" $xlinev] + set xlinedisplay [overtype::renderspace -wrap 1 -width $w -height 1 "" $xlinev] ::append rendered \n $xlinedisplay set chunk [ansistring VIEWSTYLE $chunk] set chunk [string map $maplf $chunk] #keep chunkdisplay narrower - leave at 80 or it will get unwieldy for larger image widths - set chunkdisplay [overtype::left -wrap 1 -width 80 -height 1 "" $chunk] + set chunkdisplay [overtype::renderspace -wrap 1 -width 80 -height 1 "" $chunk] set renderheight [llength [split $rendered \n]] set chunkdisplay_lines [split $chunkdisplay \n] set chunkdisplay_tail [lrange $chunkdisplay_lines end-$renderheight end] @@ -215,14 +215,87 @@ namespace eval punk::ansi::class { method viewlines {} { return [ansistring VIEW [$o_ansistringobj get]] } - method viewcodes {} { - return [ansistring VIEWCODES [$o_ansistringobj get]] + method viewcodes {args} { + set defaults [list\ + -lf 0\ + -vt 0\ + -width "auto"\ + ] + foreach {k v} $args { + switch -- $k { + -lf - -vt - -width {} + default { + error "viewcodes unrecognised option '$k'. Known options [dict keys $defaults]" + } + } + } + set opts [dict merge $defaults $args] + set opts_lf [dict get $opts -lf] + set opts_vt [dict get $opts -vt] + set opts_width [dict get $opts -width] + if {$opts_width eq ""} { + return [ansistring VIEWCODES -lf $opts_lf -vt $opts_vt [$o_ansistringobj get]] + } elseif {$opts_width eq "auto"} { + lassign [punk::console::get_size] _cols columns _rows rows + set displaycols [expr {$columns -4}] ;#review + return [overtype::renderspace -width $displaycols -wrap 1 "" [ansistring VIEWCODES -lf $opts_lf -vt $opts_vt [$o_ansistringobj get]]] + } elseif {[string is integer -strict $opts_width] && $opts_width > 0} { + return [overtype::renderspace -width $opts_width -wrap 1 "" [ansistring VIEWCODES -lf $opts_lf -vt $opts_vt [$o_ansistringobj get]]] + } else { + error "viewcodes unrecognised value for -width. Try auto or a positive integer" + } } - method viewchars {} { - return [punk::ansi::stripansiraw [$o_ansistringobj get]] + method viewchars {args} { + set defaults [list\ + -width "auto"\ + ] + foreach {k v} $args { + switch -- $k { + -width {} + default { + error "viewchars unrecognised option '$k'. Known options [dict keys $defaults]" + } + } + } + set opts [dict merge $defaults $args] + set opts_width [dict get $opts -width] + if {$opts_width eq ""} { + return [punk::ansi::stripansiraw [$o_ansistringobj get]] + } elseif {$opts_width eq "auto"} { + lassign [punk::console::get_size] _cols columns _rows rows + set displaycols [expr {$columns -4}] ;#review + return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]] + } elseif {[string is integer -strict $opts_width] && $opts_width > 0} { + return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]] + } else { + error "viewchars unrecognised value for -width. Try auto or a positive integer" + } } - method viewstyle {} { - return [ansistring VIEWSTYLE [$o_ansistringobj get]] + method viewstyle {args} { + set defaults [list\ + -width "auto"\ + ] + foreach {k v} $args { + switch -- $k { + -width {} + default { + error "viewstyle unrecognised option '$k'. Known options [dict keys $defaults]" + } + } + } + set opts [dict merge $defaults $args] + set opts_width [dict get $opts -width] + if {$opts_width eq ""} { + return [ansistring VIEWSTYLE [$o_ansistringobj get]] + } elseif {$opts_width eq "auto"} { + lassign [punk::console::get_size] _cols columns _rows rows + set displaycols [expr {$columns -4}] ;#review + return [overtype::renderspace -width $displaycols -wrap 1 "" [ansistring VIEWSTYLE [$o_ansistringobj get]]] + } elseif {[string is integer -strict $opts_width] && $opts_width > 0} { + return [overtype::renderspace -width $opts_width -wrap 1 "" [ansistring VIEWSTYLE [$o_ansistringobj get]]] + } else { + error "viewstyle unrecognised value for -width. Try auto or a positive integer" + } } method append_noreturn {ansistring} { $o_ansistringobj append $ansistring @@ -456,7 +529,7 @@ namespace eval punk::ansi { set ansidata [fcat -encoding $encoding $fname] set obj [punk::ansi::class::class_ansi new $ansidata] - if {$test_mode} { + if {$encoding eq "cp437"} { set result [$obj rendertest $dimensions] } else { set result [$obj render $dimensions] @@ -600,7 +673,6 @@ namespace eval punk::ansi { #[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} { @@ -761,19 +833,21 @@ namespace eval punk::ansi { #CSI m = SGR (Select Graphic Rendition) +#leave map unindented - used both as a dict and for direct display variable SGR_setting_map { - reset 0 bold 1 dim 2 italic 3 noitalic 23 - underline 4 doubleunderline 21 nounderline 24 blink 5 fastblink 6 noblink 25 - reverse 7 noreverse 27 hide 8 nohide 28 strike 9 nostrike 29 - normal 22 defaultfg 39 defaultbg 49 overline 53 nooverline 55 - frame 51 framecircle 52 noframe 54 underlinedefault 59 +reset 0 bold 1 dim 2 italic 3 noitalic 23 +underline 4 doubleunderline 21 nounderline 24 blink 5 fastblink 6 noblink 25 +reverse 7 noreverse 27 hide 8 nohide 28 strike 9 nostrike 29 +normal 22 defaultfg 39 defaultbg 49 overline 53 nooverline 55 +frame 51 framecircle 52 noframe 54 underlinedefault 59 } #unprefixed colours are (close to) the ansi-specified colour names (lower-cased and whitespace collapsed, with capitalisation of 1st letter given fg/bg meaning here) +#leave map unindented - used both as a dict and for direct display variable SGR_colour_map { - black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37 - Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 - brightblack 90 brightred 91 brightgreen 92 brightyellow 93 brightblue 94 brightpurple 95 brightcyan 96 brightwhite 97 - Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblue 104 Brightpurple 105 Brightcyan 106 Brightwhite 107 +black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37 +Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 +brightblack 90 brightred 91 brightgreen 92 brightyellow 93 brightblue 94 brightpurple 95 brightcyan 96 brightwhite 97 +Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblue 104 Brightpurple 105 Brightcyan 106 Brightwhite 107 } variable SGR_map ;#public - part of interface - review set SGR_map [dict merge $SGR_colour_map $SGR_setting_map] @@ -792,193 +866,222 @@ namespace eval punk::ansi { # -- --- --- #css 1-2.0 HTML 3.2-4 Basic colours eg web-silver for fg Web-silver for bg # - dict set WEB_colour_map white 255-255-255 ;# #FFFFFF - dict set WEB_colour_map silver 192-192-192 ;# #C0C0C0 - dict set WEB_colour_map gray 128-128-128 ;# #808080 - dict set WEB_colour_map black 0-0-0 ;# #000000 - dict set WEB_colour_map red 255-0-0 ;# #FF0000 - dict set WEB_colour_map maroon 128-0-0 ;# #800000 - dict set WEB_colour_map yellow 255-255-0 ;# #FFFF00 - dict set WEB_colour_map olive 128-128-0 ;# #808000 - dict set WEB_colour_map lime 0-255-0 ;# #00FF00 - dict set WEB_colour_map green 0-128-0 ;# #008000 - dict set WEB_colour_map aqua 0-255-255 ;# #00FFFF - dict set WEB_colour_map teal 0-128-128 ;# #008080 - dict set WEB_colour_map blue 0-0-255 ;# #0000FF - dict set WEB_colour_map navy 0-0-128 ;# #000080 - dict set WEB_colour_map fuchsia 255-0-255 ;# #FF00FF - dict set WEB_colour_map purple 128-0-128 ;# #800080 + variable WEB_colour_map_basic + dict set WEB_colour_map_basic white 255-255-255 ;# #FFFFFF + dict set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 + dict set WEB_colour_map_basic gray 128-128-128 ;# #808080 + dict set WEB_colour_map_basic black 0-0-0 ;# #000000 + dict set WEB_colour_map_basic red 255-0-0 ;# #FF0000 + dict set WEB_colour_map_basic maroon 128-0-0 ;# #800000 + dict set WEB_colour_map_basic yellow 255-255-0 ;# #FFFF00 + dict set WEB_colour_map_basic olive 128-128-0 ;# #808000 + dict set WEB_colour_map_basic lime 0-255-0 ;# #00FF00 + dict set WEB_colour_map_basic green 0-128-0 ;# #008000 + dict set WEB_colour_map_basic aqua 0-255-255 ;# #00FFFF + dict set WEB_colour_map_basic teal 0-128-128 ;# #008080 + dict set WEB_colour_map_basic blue 0-0-255 ;# #0000FF + dict set WEB_colour_map_basic navy 0-0-128 ;# #000080 + dict set WEB_colour_map_basic fuchsia 255-0-255 ;# #FF00FF + dict set WEB_colour_map_basic purple 128-0-128 ;# #800080 # -- --- --- #Pink colours - dict set WEB_colour_map mediumvioletred 199-21-133 ;# #C71585 - dict set WEB_colour_map deeppink 255-20-147 ;# #FF1493 - dict set WEB_colour_map palevioletred 219-112-147 ;# #DB7093 - dict set WEB_colour_map hotpink 255-105-180 ;# #FF69B4 - dict set WEB_colour_map lightpink 255-182-193 ;# #FFB6C1 - dict set WEB_colour_map pink 255-192-203 ;# #FFCOCB + variable WEB_colour_map_pink + dict set WEB_colour_map_pink mediumvioletred 199-21-133 ;# #C71585 + dict set WEB_colour_map_pink deeppink 255-20-147 ;# #FF1493 + dict set WEB_colour_map_pink palevioletred 219-112-147 ;# #DB7093 + dict set WEB_colour_map_pink hotpink 255-105-180 ;# #FF69B4 + dict set WEB_colour_map_pink lightpink 255-182-193 ;# #FFB6C1 + dict set WEB_colour_map_pink pink 255-192-203 ;# #FFCOCB # -- --- --- #Red colours - dict set WEB_colour_map darkred 139-0-0 ;# #8B0000 - #red - as above - dict set WEB_colour_map firebrick 178-34-34 ;# #B22222 - dict set WEB_colour_map crimson 220-20-60 ;# #DC143C - dict set WEB_colour_map indianred 205-92-92 ;# #CD5C5C - dict set WEB_colour_map lightcoral 240-128-128 ;# #F08080 - dict set WEB_colour_map salmon 250-128-114 ;# #FA8072 - dict set WEB_colour_map darksalmon 233-150-122 ;# #E9967A - dict set WEB_colour_map lightsalmon 255-160-122 ;# #FFA07A + variable WEB_colour_map_red + dict set WEB_colour_map_red darkred 139-0-0 ;# #8B0000 + dict set WEB_colour_map_red red 255-0-0 ;# #FF0000 + dict set WEB_colour_map_red firebrick 178-34-34 ;# #B22222 + dict set WEB_colour_map_red crimson 220-20-60 ;# #DC143C + dict set WEB_colour_map_red indianred 205-92-92 ;# #CD5C5C + dict set WEB_colour_map_red lightcoral 240-128-128 ;# #F08080 + dict set WEB_colour_map_red salmon 250-128-114 ;# #FA8072 + dict set WEB_colour_map_red darksalmon 233-150-122 ;# #E9967A + dict set WEB_colour_map_red lightsalmon 255-160-122 ;# #FFA07A # -- --- --- #Orange colours - dict set WEB_colour_map orangered 255-69-0 ;# #FF4500 - dict set WEB_colour_map tomato 255-99-71 ;# #FF6347 - dict set WEB_colour_map darkorange 255-140-0 ;# #FF8C00 - dict set WEB_colour_map coral 255-127-80 ;# #FF7F50 - dict set WEB_colour_map orange 255-165-0 ;# #FFA500 + variable WEB_colour_map_orange + dict set WEB_colour_map_orange orangered 255-69-0 ;# #FF4500 + dict set WEB_colour_map_orange tomato 255-99-71 ;# #FF6347 + dict set WEB_colour_map_orange darkorange 255-140-0 ;# #FF8C00 + dict set WEB_colour_map_orange coral 255-127-80 ;# #FF7F50 + dict set WEB_colour_map_orange orange 255-165-0 ;# #FFA500 # -- --- --- #Yellow colours - dict set WEB_colour_map darkkhaki 189-183-107 ;# #BDB76B - dict set WEB_colour_map gold 255-215-0 ;# #FFD700 - dict set WEB_colour_map khaki 240-230-140 ;# #F0E68C - dict set WEB_colour_map peachpuff 255-218-185 ;# #FFDAB9 - #yellow - as above - dict set WEB_colour_map palegoldenrod 238-232-170 ;# #EEE8AA - dict set WEB_colour_map moccasin 255-228-181 ;# #FFE4B5 - dict set WEB_colour_map papayawhip 255-239-213 ;# #FFEFD5 - dict set WEB_colour_map lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 - dict set WEB_colour_map lemonchiffon 255-250-205 ;# #FFFACD - dict set WEB_colour_map lightyellow 255-255-224 ;# #FFFFE0 + variable WEB_colour_map_yellow + dict set WEB_colour_map_yellow darkkhaki 189-183-107 ;# #BDB76B + dict set WEB_colour_map_yellow gold 255-215-0 ;# #FFD700 + dict set WEB_colour_map_yellow khaki 240-230-140 ;# #F0E68C + dict set WEB_colour_map_yellow peachpuff 255-218-185 ;# #FFDAB9 + dict set WEB_colour_map_yellow yellow 255-255-0 ;# #FFFF00 + dict set WEB_colour_map_yellow palegoldenrod 238-232-170 ;# #EEE8AA + dict set WEB_colour_map_yellow moccasin 255-228-181 ;# #FFE4B5 + dict set WEB_colour_map_yellow papayawhip 255-239-213 ;# #FFEFD5 + dict set WEB_colour_map_yellow lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 + dict set WEB_colour_map_yellow lemonchiffon 255-250-205 ;# #FFFACD + dict set WEB_colour_map_yellow lightyellow 255-255-224 ;# #FFFFE0 # -- --- --- #Brown colours #maroon as above - dict set WEB_colour_map brown 165-42-42 ;# #A52A2A - dict set WEB_colour_map saddlebrown 139-69-19 ;# #8B4513 - dict set WEB_colour_map sienna 160-82-45 ;# #A0522D - dict set WEB_colour_map chocolate 210-105-30 ;# #D2691E - dict set WEB_colour_map darkgoldenrod 184-134-11 ;# #B8860B - dict set WEB_colour_map peru 205-133-63 ;# #CD853F - dict set WEB_colour_map rosybrown 188-143-143 ;# #BC8F8F - dict set WEB_colour_map goldenrod 218-165-32 ;# #DAA520 - dict set WEB_colour_map sandybrown 244-164-96 ;# #F4A460 - dict set WEB_colour_map tan 210-180-140 ;# #D2B48C - dict set WEB_colour_map burlywood 222-184-135 ;# #DEB887 - dict set WEB_colour_map wheat 245-222-179 ;# #F5DEB3 - dict set WEB_colour_map navajowhite 255-222-173 ;# #FFDEAD - dict set WEB_colour_map bisque 255-228-196 ;# #FFEfC4 - dict set WEB_colour_map blanchedalmond 255-228-196 ;# #FFEfC4 - dict set WEB_colour_map cornsilk 255-248-220 ;# #FFF8DC + variable WEB_colour_map_brown + dict set WEB_colour_map_brown brown 165-42-42 ;# #A52A2A + dict set WEB_colour_map_brown saddlebrown 139-69-19 ;# #8B4513 + dict set WEB_colour_map_brown sienna 160-82-45 ;# #A0522D + dict set WEB_colour_map_brown chocolate 210-105-30 ;# #D2691E + dict set WEB_colour_map_brown darkgoldenrod 184-134-11 ;# #B8860B + dict set WEB_colour_map_brown peru 205-133-63 ;# #CD853F + dict set WEB_colour_map_brown rosybrown 188-143-143 ;# #BC8F8F + dict set WEB_colour_map_brown goldenrod 218-165-32 ;# #DAA520 + dict set WEB_colour_map_brown sandybrown 244-164-96 ;# #F4A460 + dict set WEB_colour_map_brown tan 210-180-140 ;# #D2B48C + dict set WEB_colour_map_brown burlywood 222-184-135 ;# #DEB887 + dict set WEB_colour_map_brown wheat 245-222-179 ;# #F5DEB3 + dict set WEB_colour_map_brown navajowhite 255-222-173 ;# #FFDEAD + dict set WEB_colour_map_brown bisque 255-228-196 ;# #FFEfC4 + dict set WEB_colour_map_brown blanchedalmond 255-228-196 ;# #FFEfC4 + dict set WEB_colour_map_brown cornsilk 255-248-220 ;# #FFF8DC # -- --- --- #Purple, violet, and magenta colours - dict set WEB_colour_map indigo 75-0-130 ;# #4B0082 - #purple as above - dict set WEB_colour_map darkmagenta 139-0-139 ;# #8B008B - dict set WEB_colour_map darkviolet 148-0-211 ;# #9400D3 - dict set WEB_colour_map darkslateblue 72-61-139 ;# #9400D3 - dict set WEB_colour_map blueviolet 138-43-226 ;# #8A2BE2 - dict set WEB_colour_map darkorchid 153-50-204 ;# #9932CC - #fuchsia as above - dict set WEB_colour_map magenta 255-0-255 ;# #FF00FF - same as fuchsia - dict set WEB_colour_map slateblue 106-90-205 ;# #6A5ACD - dict set WEB_colour_map mediumslateblue 123-104-238 ;# #7B68EE - dict set WEB_colour_map mediumorchid 186-85-211 ;# #BA5503 - dict set WEB_colour_map mediumpurple 147-112-219 ;# #9370DB - dict set WEB_colour_map orchid 218-112-214 ;# #DA70D6 - dict set WEB_colour_map violet 238-130-238 ;# #EE82EE - dict set WEB_colour_map plum 221-160-221 ;# #DDA0DD - dict set WEB_colour_map thistle 216-191-216 ;# #D88FD8 - dict set WEB_colour_map lavender 230-230-150 ;# #E6E6FA + variable WEB_colour_map_purple + dict set WEB_colour_map_purple indigo 75-0-130 ;# #4B0082 + dict set WEB_colour_map_purple purple 128-0-128 ;# #800080 + dict set WEB_colour_map_purple darkmagenta 139-0-139 ;# #8B008B + dict set WEB_colour_map_purple darkviolet 148-0-211 ;# #9400D3 + dict set WEB_colour_map_purple darkslateblue 72-61-139 ;# #9400D3 + dict set WEB_colour_map_purple blueviolet 138-43-226 ;# #8A2BE2 + dict set WEB_colour_map_purple darkorchid 153-50-204 ;# #9932CC + dict set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF + dict set WEB_colour_map_purple magenta 255-0-255 ;# #FF00FF - same as fuchsia + dict set WEB_colour_map_purple slateblue 106-90-205 ;# #6A5ACD + dict set WEB_colour_map_purple mediumslateblue 123-104-238 ;# #7B68EE + dict set WEB_colour_map_purple mediumorchid 186-85-211 ;# #BA5503 + dict set WEB_colour_map_purple mediumpurple 147-112-219 ;# #9370DB + dict set WEB_colour_map_purple orchid 218-112-214 ;# #DA70D6 + dict set WEB_colour_map_purple violet 238-130-238 ;# #EE82EE + dict set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD + dict set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8 + dict set WEB_colour_map_purple lavender 230-230-250 ;# #E6E6FA # -- --- --- #Blue colours - dict set WEB_colour_map midnightblue 25-25-112 ;# #191970 - #navy as above - dict set WEB_colour_map darkblue 0-0-139 ;# #00008B - dict set WEB_colour_map mediumblue 0-0-205 ;# #0000CD - #blue as above - dict set WEB_colour_map royalblue 65-105-225 ;# #4169E1 - dict set WEB_colour_map steelblue 70-130-180 ;# #4682B4 - dict set WEB_colour_map dodgerblue 30-144-255 ;# #1E90FF - dict set WEB_colour_map deepskyblue 0-191-255 ;# #00BFFF - dict set WEB_colour_map cornflowerblue 100-149-237 ;# #6495ED - dict set WEB_colour_map skyblue 135-206-235 ;# #87CEEB - dict set WEB_colour_map lightskyblue 135-206-250 ;# #87CEFA - dict set WEB_colour_map lightsteelblue 176-196-222 ;# #B0C4DE - dict set WEB_colour_map lightblue 173-216-230 ;# #ADD8E6 - dict set WEB_colour_map powderblue 176-224-230 ;# #B0E0E6 + variable WEB_colour_map_blue + dict set WEB_colour_map_blue midnightblue 25-25-112 ;# #191970 + dict set WEB_colour_map_blue navy 0-0-128 ;# #000080 + dict set WEB_colour_map_blue darkblue 0-0-139 ;# #00008B + dict set WEB_colour_map_blue mediumblue 0-0-205 ;# #0000CD + dict set WEB_colour_map_blue blue 0-0-255 ;# #0000FF + dict set WEB_colour_map_blue royalblue 65-105-225 ;# #4169E1 + dict set WEB_colour_map_blue steelblue 70-130-180 ;# #4682B4 + dict set WEB_colour_map_blue dodgerblue 30-144-255 ;# #1E90FF + dict set WEB_colour_map_blue deepskyblue 0-191-255 ;# #00BFFF + dict set WEB_colour_map_blue cornflowerblue 100-149-237 ;# #6495ED + dict set WEB_colour_map_blue skyblue 135-206-235 ;# #87CEEB + dict set WEB_colour_map_blue lightskyblue 135-206-250 ;# #87CEFA + dict set WEB_colour_map_blue lightsteelblue 176-196-222 ;# #B0C4DE + dict set WEB_colour_map_blue lightblue 173-216-230 ;# #ADD8E6 + dict set WEB_colour_map_blue powderblue 176-224-230 ;# #B0E0E6 # -- --- --- #Cyan colours #teal as above - dict set WEB_colour_map darkcyan 0-139-139 ;# #008B8B - dict set WEB_colour_map lightseagreen 32-178-170 ;# #20B2AA - dict set WEB_colour_map cadetblue 95-158-160 ;# #5F9EA0 - dict set WEB_colour_map darkturquoise 0-206-209 ;# #00CED1 - dict set WEB_colour_map mediumturquoise 72-209-204 ;# #48D1CC - dict set WEB_colour_map turquoise 64-224-208 ;# #40E0D0 - #aqua as above - dict set WEB_colour_map cyan 0-255-255 ;# #00FFFF - same as aqua - dict set WEB_colour_map aquamarine 127-255-212 ;# #7FFFD4 - dict set WEB_colour_map paleturquoise 175-238-238 ;# #AFEEEE - dict set WEB_colour_map lightcyan 224-255-255 ;# #E0FFFF + variable WEB_colour_map_cyan + dict set WEB_colour_map_cyan darkcyan 0-139-139 ;# #008B8B + dict set WEB_colour_map_cyan lightseagreen 32-178-170 ;# #20B2AA + dict set WEB_colour_map_cyan cadetblue 95-158-160 ;# #5F9EA0 + dict set WEB_colour_map_cyan darkturquoise 0-206-209 ;# #00CED1 + dict set WEB_colour_map_cyan mediumturquoise 72-209-204 ;# #48D1CC + dict set WEB_colour_map_cyan turquoise 64-224-208 ;# #40E0D0 + dict set WEB_colour_map_cyan aqua 0-255-255 ;# #00FFFF + dict set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua + dict set WEB_colour_map_cyan aquamarine 127-255-212 ;# #7FFFD4 + dict set WEB_colour_map_cyan paleturquoise 175-238-238 ;# #AFEEEE + dict set WEB_colour_map_cyan lightcyan 224-255-255 ;# #E0FFFF # -- --- --- #Green colours - dict set WEB_colour_map darkgreen 0-100-0 ;# #006400 - #green as above - dict set WEB_colour_map darkolivegreen 85-107-47 ;# #55682F - dict set WEB_colour_map forestgreen 34-139-34 ;# #228B22 - dict set WEB_colour_map seagrean 46-139-87 ;# #2E8B57 - #olive as above - dict set WEB_colour_map olivedrab 107-142-35 ;# #6B8E23 - dict set WEB_colour_map mediumseagreen 60-179-113 ;# #3CB371 - dict set WEB_colour_map limegreen 50-205-50 ;# #32CD32 - #lime as above - dict set WEB_colour_map springgreen 0-255-127 ;# #00FF7F - dict set WEB_colour_map mediumspringgreen 0-250-154 ;# #00FA9A - dict set WEB_colour_map darkseagreen 143-188-143 ;# #8FBC8F - dict set WEB_colour_map mediumaquamarine 102-205-170 ;# #66CDAA - dict set WEB_colour_map yellowgreen 154-205-50 ;# #9ACD32 - dict set WEB_colour_map lawngreen 124-252-0 ;# #7CFC00 - dict set WEB_colour_map chartreuse 127-255-0 ;# #7FFF00 - dict set WEB_colour_map lightgreen 144-238-144 ;# #90EE90 - dict set WEB_colour_map greenyellow 173-255-47 ;# #ADFF2F - dict set WEB_colour_map palegreen 152-251-152 ;# #98FB98 + variable WEB_colour_map_green + dict set WEB_colour_map_green darkgreen 0-100-0 ;# #006400 + dict set WEB_colour_map_green green 0-128-0 ;# #008000 + dict set WEB_colour_map_green darkolivegreen 85-107-47 ;# #55682F + dict set WEB_colour_map_green forestgreen 34-139-34 ;# #228B22 + dict set WEB_colour_map_green seagreen 46-139-87 ;# #2E8B57 + dict set WEB_colour_map_green olive 128-128-0 ;# #808000 + dict set WEB_colour_map_green olivedrab 107-142-35 ;# #6B8E23 + dict set WEB_colour_map_green mediumseagreen 60-179-113 ;# #3CB371 + dict set WEB_colour_map_green limegreen 50-205-50 ;# #32CD32 + dict set WEB_colour_map_green lime 0-255-0 ;# #00FF00 + dict set WEB_colour_map_green springgreen 0-255-127 ;# #00FF7F + dict set WEB_colour_map_green mediumspringgreen 0-250-154 ;# #00FA9A + dict set WEB_colour_map_green darkseagreen 143-188-143 ;# #8FBC8F + dict set WEB_colour_map_green mediumaquamarine 102-205-170 ;# #66CDAA + dict set WEB_colour_map_green yellowgreen 154-205-50 ;# #9ACD32 + dict set WEB_colour_map_green lawngreen 124-252-0 ;# #7CFC00 + dict set WEB_colour_map_green chartreuse 127-255-0 ;# #7FFF00 + dict set WEB_colour_map_green lightgreen 144-238-144 ;# #90EE90 + dict set WEB_colour_map_green greenyellow 173-255-47 ;# #ADFF2F + dict set WEB_colour_map_green palegreen 152-251-152 ;# #98FB98 # -- --- --- #White colours - dict set WEB_colour_map mistyrose 255-228-225 ;# #FFE4E1 - dict set WEB_colour_map antiquewhite 250-235-215 ;# #FAEBD7 - dict set WEB_colour_map linen 250-240-230 ;# #FAF0E6 - dict set WEB_colour_map beige 245-245-220 ;# #F5F5DC - dict set WEB_colour_map whitesmoke 245-245-245 ;# #F5F5F5 - dict set WEB_colour_map lavenderblush 255-240-245 ;# #FFF0F5 - dict set WEB_colour_map oldlace 253-245-230 ;# #FDF5E6 - dict set WEB_colour_map aliceblue 240-248-255 ;# #F0F8FF - dict set WEB_colour_map seashell 255-245-238 ;# #FFF5EE - dict set WEB_colour_map ghostwhite 248-248-255 ;# #F8F8FF - dict set WEB_colour_map honeydew 240-255-240 ;# #F0FFF0 - dict set WEB_colour_map floralwhite 255-250-240 ;# #FFFAF0 - dict set WEB_colour_map azure 240-255-255 ;# #F0FFFF - dict set WEB_colour_map mintcream 245-255-250 ;# #F5FFFA - dict set WEB_colour_map snow 255-250-250 ;# #FFFAFA - dict set WEB_colour_map ivory 255-255-240 ;# #FFFFF0 - #white as above + variable WEB_colour_map_white + dict set WEB_colour_map_white mistyrose 255-228-225 ;# #FFE4E1 + dict set WEB_colour_map_white antiquewhite 250-235-215 ;# #FAEBD7 + dict set WEB_colour_map_white linen 250-240-230 ;# #FAF0E6 + dict set WEB_colour_map_white beige 245-245-220 ;# #F5F5DC + dict set WEB_colour_map_white whitesmoke 245-245-245 ;# #F5F5F5 + dict set WEB_colour_map_white lavenderblush 255-240-245 ;# #FFF0F5 + dict set WEB_colour_map_white oldlace 253-245-230 ;# #FDF5E6 + dict set WEB_colour_map_white aliceblue 240-248-255 ;# #F0F8FF + dict set WEB_colour_map_white seashell 255-245-238 ;# #FFF5EE + dict set WEB_colour_map_white ghostwhite 248-248-255 ;# #F8F8FF + dict set WEB_colour_map_white honeydew 240-255-240 ;# #F0FFF0 + dict set WEB_colour_map_white floralwhite 255-250-240 ;# #FFFAF0 + dict set WEB_colour_map_white azure 240-255-255 ;# #F0FFFF + dict set WEB_colour_map_white mintcream 245-255-250 ;# #F5FFFA + dict set WEB_colour_map_white snow 255-250-250 ;# #FFFAFA + dict set WEB_colour_map_white ivory 255-255-240 ;# #FFFFF0 + dict set WEB_colour_map_white white 255-255-255 ;# #FFFFFF # -- --- --- #Gray and black colours - #black as above - dict set WEB_colour_map darkslategray 47-79-79 ;# #2F4F4F - dict set WEB_colour_map dimgray 105-105-105 ;# #696969 - dict set WEB_colour_map slategray 112-128-144 ;# #708090 - #gray as above - dict set WEB_colour_map lightslategray 119-136-153 ;# #778899 - dict set WEB_colour_map darkgray 169-169-169 ;# #A9A9A9 - dict set WEB_colour_map silver 192-192-192 ;# #C0C0C0 - dict set WEB_colour_map lightgray 211-211-211 ;# #D3D3D3 - dict set WEB_colour_map gainsboro 220-220-220 ;# #DCDCDC - + variable WEB_colour_map_gray + dict set WEB_colour_map_gray black 0-0-0 ;# #000000 + dict set WEB_colour_map_gray darkslategray 47-79-79 ;# #2F4F4F + dict set WEB_colour_map_gray dimgray 105-105-105 ;# #696969 + dict set WEB_colour_map_gray slategray 112-128-144 ;# #708090 + dict set WEB_colour_map_gray gray 128-128-128 ;# #808080 + dict set WEB_colour_map_gray lightslategray 119-136-153 ;# #778899 + dict set WEB_colour_map_gray darkgray 169-169-169 ;# #A9A9A9 + dict set WEB_colour_map_gray silver 192-192-192 ;# #C0C0C0 + dict set WEB_colour_map_gray lightgray 211-211-211 ;# #D3D3D3 + dict set WEB_colour_map_gray gainsboro 220-220-220 ;# #DCDCDC + + set WEB_colour_map [dict merge\ + $WEB_colour_map_basic\ + $WEB_colour_map_pink\ + $WEB_colour_map_red\ + $WEB_colour_map_orange\ + $WEB_colour_map_yellow\ + $WEB_colour_map_brown\ + $WEB_colour_map_purple\ + $WEB_colour_map_blue\ + $WEB_colour_map_cyan\ + $WEB_colour_map_green\ + $WEB_colour_map_white\ + $WEB_colour_map_gray\ + ] #we should be able to use WEB_colour_map as a base and override only the conflicts for X11 colours ? Review - check if this is true + variable X11_colour_map_diff ;#maintain the difference as a separate dict so we can display in a? x11 + dict set X11_colour_map_diff gray 190-190-190 ;# #BEBEBE + dict set X11_colour_map_diff green 0-255-0 ;# #00FF00 + dict set X11_colour_map_diff maroon 176-48-96 ;# #B03060 + dict set X11_colour_map_diff purple 160-32-240 ;# #A020F0 + variable X11_colour_map - set X11_colour_map $WEB_colour_map - dict set X11_colour_map gray 190-190-190 ;# #BEBEBE - dict set X11_colour_map green 0-255-0 ;# #00FF00 - dict set X11_colour_map maroon 176-48-96 ;# #B03060 - dict set X11_colour_map purple 160-32-240 ;# #A020F0 + set X11_colour_map [dict merge $WEB_colour_map $X11_colour_map_diff] + #Xterm colour names (256 colours) #lists on web have duplicate names @@ -1030,7 +1133,7 @@ namespace eval punk::ansi { dodgerblue2\ green4\ springgreen4\ - turquise4\ + turquoise4\ deepskyblue3\ deepskyblue3\ dodgerblue1\ @@ -1161,7 +1264,7 @@ namespace eval punk::ansi { darkseagreen1\ paleturquoise1\ red3\ - deppink3\ + deeppink3\ deeppink3\ magenta3\ magenta3\ @@ -1260,16 +1363,20 @@ namespace eval punk::ansi { ] variable TERM_colour_map set TERM_colour_map [dict create] + variable TERM_colour_map_reverse + set TERM_colour_map_reverse [dict create] set cidx 0 foreach cname $xterm_names { if {![dict exists $TERM_colour_map $cname]} { dict set TERM_colour_map $cname $cidx + dict set TERM_colour_map_reverse $cidx $cname } else { set did_rename 0 #start suffixes at '-b'. The base name could be considered the '-a' version - but we don't create it. foreach {suffix} {b c} { if {![dict exists $TERM_colour_map $cname-$suffix]} { dict set TERM_colour_map $cname-$suffix $cidx + dict set TERM_colour_map_reverse $cidx $cname-$suffix set did_rename 1 break } @@ -1284,7 +1391,7 @@ namespace eval punk::ansi { - #colour_hex2dec + #colour_hex2ansidec #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) #we want to support arbitrary rgb values specified in hex - so a table of 16M+ is probably not a great idea #hex zero-padded - canonically upper case but mixed or lower accepted @@ -1293,40 +1400,91 @@ namespace eval punk::ansi { # set webhex [::join [format %02X%02X%02X {*}$dectriple] ;# e.g 808080, FFFFFF, 000000 # dict set HEX_colour_map $webhex [join $dectriple {;}] #} - proc colour_hex2dec {hex6} { + proc colour_hex2ansidec {hex6} { return [join [::scan $hex6 %2X%2X%2X] {;}] } + #convert between hex and decimal as used in the a+ function + # eg dec-dec-dec <-> #HHHHHH + #allow hex to be specified with or without leading # + proc colour_hex2dec {hex6} { + set hex6 [string map [list # ""] $hex6] + return [join [::scan $hex6 %2X%2X%2X] {-}] + } + proc colour_dec2hex {decimalcolourstring} { + set dec [string map [list {;} - , -] $decimalcolourstring] + set declist [split $dec -] + set hex #[format %02X%02X%02X {*}$declist] + } + proc get_sgr_map {} { variable SGR_map return $SGR_map } - proc colourmap1 {{bgname White}} { - package require textblock + proc colourmap1 {args} { + set defaults {-bg Web-white -forcecolour 0} + dict for {k v} $args { + switch -- $k { + -bg - -forcecolour {} + default { + error "colourmap1 unrecognised option $k. Known-options: [dict keys $defaults] + } + } + } + set opts [dict merge $defaults $args] + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } else { + set fc "" + } + set bgname [dict get $opts -bg] - set bg [textblock::block 33 3 "[a+ $bgname] [a]"] + package require textblock + set bg [textblock::block 33 3 "[a+ {*}$fc $bgname] [a]"] set colourmap "" + set RST [a] for {set i 0} {$i <= 7} {incr i} { - append colourmap "_[a+ white bold 48\;5\;$i] $i [a]" + #append colourmap "_[a+ white bold 48\;5\;$i] $i [a]" + append colourmap "_[a+ {*}$fc white bold Term-$i] $i $RST" } set map1 [overtype::left -transparent _ $bg "\n$colourmap"] return $map1 } - proc colourmap2 {{bgname White}} { + proc colourmap2 {args} { + set defaults {-forcecolour 0 -bg Web-white} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set bgname [dict get $opts -bg] + package require textblock - set bg [textblock::block 39 3 "[a+ $bgname] [a]"] + set bg [textblock::block 39 3 "[a+ {*}$fc $bgname] [a]"] set colourmap "" + set RST [a] for {set i 8} {$i <= 15} {incr i} { - append colourmap "_[a+ black normal 48\;5\;$i] $i [a]" ;#black normal is blacker than black bold - which often displays as a grey + if {$i == 8} { + set fg "bold white" + } else { + set fg "black normal" ;#black normal is often blacker than black bold - which can display as a grey + } + append colourmap "_[a+ {*}$fc {*}$fg 48\;5\;$i] $i $RST" } set map2 [overtype::left -transparent _ $bg "\n$colourmap"] return $map2 } - proc colourtable_216 {} { + proc colourtable_216 {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } package require textblock set clist [list] - set fg black + set fg "black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "black"} { @@ -1335,7 +1493,7 @@ namespace eval punk::ansi { set fg "black" } } - lappend clist "[a+ {*}$fg Term$i][format %3s $i]" + lappend clist "[a+ {*}$fc {*}$fg Term$i][format %3s $i]" } set t [textblock::list_as_table 36 $clist -return object] @@ -1344,48 +1502,562 @@ namespace eval punk::ansi { return $t } - proc colourblock_216 {} { + #1st 16 colours of 256 - match SGR colours + proc colourblock_16 {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set out "" + set fg "bold white" + for {set i 0} {$i <= 15} {incr i} { + #8 is black - so start black fg at 9 + if {$i > 8} { + set fg "web-black" + } + append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] " + } + return $out[a] + } + proc colourtable_16_names {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + variable TERM_colour_map_reverse + set rows [list] + set row [list] + set fg "web-white" + set t [textblock::class::table new] + $t configure -show_seps 0 -show_edge 0 + for {set i 0} {$i <=15} {incr i} { + set cname [dict get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? + if {[llength $row]== 8} { + lappend rows $row + set row [list] + } + if {$i == 8} { + set fg "web-white" + } elseif {$i > 6} { + set fg "web-black" + } + #lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname " + lappend row "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] $cname " + } + lappend rows $row + foreach r $rows { + $t add_row $r + } + append out [$t print] + $t destroy + append out [a] + return [string trimleft $out \n] + + } + #216 colours of 256 + proc colourblock_216 {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } set out "" - set fg black + set fg "web-black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { - if {$fg eq "black"} { - set fg "bold white" + if {$fg eq "web-black"} { + set fg "web-white" } else { - set fg "black" + set fg "web-black" } set br "\n" } else { set br "" } - append out "$br[a+ {*}$fg Term$i][format %3s $i] " + append out "$br[a+ {*}$fc {*}$fg Term$i][format %3s $i] " + } + append out [a] + return [string trimleft $out \n] + } + + #x6 is reasonable from a width (124 screen cols) and colour viewing perspective + proc colourtable_216_names {args} { + set defaults {-forcecolour 0 -columns 6} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set cols [dict get $opts -columns] + + set out "" + #use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names + variable TERM_colour_map_reverse + set rows [list] + set row [list] + set fg "web-black" + set t [textblock::class::table new] + $t configure -show_seps 0 -show_edge 0 + for {set i 16} {$i <=231} {incr i} { + set cname [dict get $TERM_colour_map_reverse $i] ;#use term-cname etc instead of term$i - may as well let a+ cache the call by name as the preferred? option + if {[llength $row]== $cols} { + lappend rows $row + set row [list] + } + if {$i % 18 == 16} { + if {$fg eq "web-black"} { + set fg "web-white" + } else { + set fg "web-black" + } + } + lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname " + } + lappend rows $row + foreach r $rows { + $t add_row $r + } + append out [$t print] + $t destroy + append out [a] + return [string trimleft $out \n] + } + proc colourtable_term_pastel {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set out "" + set rows [list] + #see https://www.hackitu.de/termcolor256/ + lappend rows {59 95 131 167 174 181 188} + lappend rows {59 95 131 173 180 187 188} + lappend rows {59 95 137 179 186 187 188} + lappend rows {59 101 143 185 186 187 188} + lappend rows {59 65 107 149 186 187 188} + lappend rows {59 65 71 113 150 187 188} + lappend rows {59 65 71 77 114 151 188} + lappend rows {59 65 71 78 115 152 188} + lappend rows {59 65 72 79 116 152 188} + lappend rows {59 66 73 80 116 152 188} + lappend rows {59 60 67 74 116 152 188} + lappend rows {59 60 61 68 110 152 188} + lappend rows {59 60 61 62 104 146 188} + lappend rows {59 60 61 98 140 182 188} + lappend rows {59 60 97 134 176 182 188} + lappend rows {59 96 133 170 176 182 188} + lappend rows {59 95 132 169 176 182 188} + lappend rows {59 95 131 168 175 182 188} + + set t [textblock::class::table new] + $t configure -show_seps 0 -show_edge 0 + set fg "web-black" + foreach r $rows { + set rowcells [list] + foreach cnum $r { + lappend rowcells "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " + } + $t add_row $rowcells + } + append out [$t print] + $t destroy + set pastel8 [list 102 138 144 108 109 103 139 145] + set p8 "" + foreach cnum $pastel8 { + append p8 "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " } + append p8 [a]\n + append out \n $p8 + return $out } + proc colourtable_term_rainbow {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set out "" + set rows [list] + set fgwhite [list 16 52 88 124 160 22 17 18 19 20 21 57 56 93 55 92 54 91 53 90 89 126 88 125 124 160] + #see https://www.hackitu.de/termcolor256/ + lappend rows {16 52 88 124 160 196 203 210 217 224 231} + lappend rows {16 52 88 124 160 202 209 216 223 230 231} + lappend rows {16 52 88 124 166 208 215 222 229 230 231} + lappend rows {16 52 88 130 172 214 221 228 229 230 231} + lappend rows {16 52 94 136 178 220 227 227 228 230 231} + + lappend rows {16 58 100 142 184 226 227 228 228 230 231} + + lappend rows {16 22 64 106 148 190 227 228 229 230 231} + lappend rows {16 22 28 70 112 154 191 228 229 230 231} + lappend rows {16 22 28 34 76 118 155 192 229 230 231} + lappend rows {16 22 28 34 40 82 119 156 193 230 231} + lappend rows {16 22 28 34 40 46 83 120 157 194 231} + lappend rows {16 22 28 34 40 47 84 121 158 195 231} + lappend rows {16 22 28 34 41 48 85 122 158 195 231} + lappend rows {16 22 28 35 42 49 86 123 159 195 231} + lappend rows {16 22 29 36 43 50 87 123 159 195 231} + + lappend rows {16 23 30 37 44 51 87 123 159 195 231} + + lappend rows {16 17 24 31 38 45 87 123 159 195 231} + lappend rows {16 17 18 25 32 39 81 123 159 195 231} + lappend rows {16 17 18 19 26 33 75 117 159 195 231} + lappend rows {16 17 18 19 20 27 69 111 153 195 231} + lappend rows {16 17 18 19 20 21 63 105 147 189 231} + lappend rows {16 17 18 19 20 57 99 141 183 225 231} + lappend rows {16 17 18 19 56 93 135 177 219 225 231} + lappend rows {16 17 18 55 92 129 171 213 219 225 231} + lappend rows {16 17 54 91 128 165 207 213 219 225 231} + + lappend rows {16 53 90 127 164 201 207 213 219 225 231} + + lappend rows {16 52 89 126 163 200 207 213 219 225 231} + lappend rows {16 52 88 125 162 199 206 213 219 225 231} + lappend rows {16 52 88 124 161 198 205 212 219 225 231} + lappend rows {16 52 88 124 160 197 204 211 218 225 231} + + + set t [textblock::class::table new] + $t configure -show_seps 0 -show_edge 0 + foreach r $rows { + set rowcells [list] + foreach cnum $r { + if {$cnum in $fgwhite} { + set fg "web-white" + } else { + set fg "web-black" + } + lappend rowcells "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " + } + $t add_row $rowcells + } + append out [$t print] + $t destroy + return $out + } + #24 greys of 256 + proc colourblock_24 {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + + set out "" + set fg "bold white" + for {set i 232} {$i <= 255} {incr i} { + if {$i > 243} { + set fg "web-black" + } + append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] " + } + return $out[a] + + } + proc colourtable_24_names {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + + variable TERM_colour_map_reverse + set rows [list] + set row [list] + set fg "web-white" + set t [textblock::class::table new] + $t configure -show_hseps 0 -show_edge 0 + for {set i 232} {$i <=255} {incr i} { + set cname [dict get $TERM_colour_map_reverse $i] ;#use term-cname etc instead of term$i - may as well let a+ cache the call by name as the preferred? option + if {[llength $row]== 8} { + lappend rows $row + set row [list] + } + if {$i > 243} { + set fg "web-black" + } + lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname " + } + lappend rows $row + foreach r $rows { + $t add_row $r + } + append out [$t print] + $t destroy + append out [a] + return [string trimleft $out \n] + + } + #set WEB_colour_map [dict merge\ + # $WEB_colour_map_basic\ + # $WEB_colour_map_pink\ + # $WEB_colour_map_red\ + # $WEB_colour_map_orange\ + # $WEB_colour_map_yellow\ + # $WEB_colour_map_brown\ + # $WEB_colour_map_purple\ + # $WEB_colour_map_blue\ + # $WEB_colour_map_cyan\ + # $WEB_colour_map_green\ + # $WEB_colour_map_white\ + # $WEB_colour_map_gray\ + #] + proc colourtable_web {args} { + set defaults {-forcecolour 0 -groups *} + foreach {k v} $args { + switch -- $k { + -groups - -forcecolour {} + default { + error "colourtable_web unrecognised option '$k'. Known-options: [dict keys $defaults]" + } + } + } + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set groups [dict get $opts -groups] + + #set all_groupnames [list basic pink red orange yellow brown purple blue cyan green white gray] + set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray] + switch -- $groups { + "" - * { + set show_groups $all_groupnames + } + ? { + return "Web group names: $all_groupnames" + } + default { + foreach g $groups { + if {$g ni $all_groupnames} { + error "colourtable_web group name '$g' not known. Known colour groups: $all_groupnames" + } + } + set show_groups $groups + } + } + set grouptables [list] + set white_fg_list [list\ + mediumvioletred deeppink\ + darkred red firebrick crimson indianred\ + orangered\ + maroon brown saddlebrown sienna\ + indigo purple darkmagenta darkviolet darkslateblue blueviolet darkorchid fuchsia magenta slateblue mediumslateblue\ + midnightblue navy darkblue mediumblue blue royalblue steelblue dodgerblue\ + teal darkcyan\ + darkgreen green darkolivegreen forestgreen seagreen olive olivedrab\ + black darkslategray dimgray slategray\ + ] + foreach g $show_groups { + #upvar WEB_colour_map_$g map_$g + variable WEB_colour_map_$g + set t [textblock::class::table new] + $t configure -show_edge 0 -show_seps 0 -show_header 1 + dict for {cname cdec} [set WEB_colour_map_$g] { + $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] + if {$cname in $white_fg_list} { + set fg "web-white" + } else { + set fg "web-black" + } + #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] + $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] + } + $t configure -frametype {} + $t configure_column 0 -headers [list "[string totitle $g] colours"] + $t configure_column 0 -header_colspans [list all] + $t configure -ansibase_header [a+ {*}$fc web-black Web-white] + lappend grouptables [$t print] + $t destroy + } + #set displaytable [textblock::class::table new] + set displaytable [textblock::list_as_table 3 $grouptables -return object] + $displaytable configure -show_header 0 -show_vseps 0 + #return $displaytable + set result [$displaytable print] + $displaytable destroy + return $result + } + proc colourtable_x11diff {args} { + variable X11_colour_map_diff + variable WEB_colour_map + set defaults [dict create\ + -forcecolour 0\ + -return "string"\ + ] + dict for {k v} $args { + switch -- $k { + -return - -forcecolour {} + default { + error "colourtable_x11diff unrecognised option '$k'. Known options [dict keys $defaults]" + } + } + } + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + + set comparetables [list] ;# 2 side by side x11 and web + + # -- --- --- + set t [textblock::class::table new] + $t configure -show_edge 0 -show_seps 0 -show_header 1 + dict for {cname cdec} [set X11_colour_map_diff] { + $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] + set fg "web-white" + $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg X11-$cname] + } + $t configure -frametype block + $t configure_column 0 -headers [list "X11"] + $t configure_column 0 -header_colspans [list all] + $t configure -ansibase_header [a+ {*}$fc web-black Web-white] + lappend comparetables [$t print] + $t destroy + # -- --- --- + + set WEB_map_subset [dict create] + dict for {k v} $X11_colour_map_diff { + dict set WEB_map_subset $k [dict get $WEB_colour_map $k] + } + + # -- --- --- + set t [textblock::class::table new] + $t configure -show_edge 0 -show_seps 0 -show_header 1 + dict for {cname cdec} [set WEB_map_subset] { + $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] + set fg "web-white" + $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] + } + $t configure -frametype block + $t configure_column 0 -headers [list "Web"] + $t configure_column 0 -header_colspans [list all] + $t configure -ansibase_header [a+ {*}$fc web-black Web-white] + lappend comparetables [$t print] + $t destroy + # -- --- --- + + set displaytable [textblock::list_as_table 2 $comparetables -return object] + $displaytable configure -show_header 0 -show_vseps 0 + + if {[dict get $opts -return] eq "string"} { + set result [$displaytable print] + $displaytable destroy + return $result + } + + return $displaytable + } proc a? {args} { #*** !doctools #[call [fun a?] [opt {ansicode...}]] #[para]Return an ansi string representing a table of codes and a panel showing the colours variable SGR_setting_map variable SGR_colour_map + set fcposn [lsearch $args "forcecol*"] + set fc "" + set opt_forcecolour 0 + if {$fcposn >= 0} { + set fc "forcecolour" + set opt_forcecolour 1 + set args [lremove $args $fcposn] + } if {![llength $args]} { set out "" - append out $SGR_setting_map \n - append out $SGR_colour_map \n - + set indent " " + set RST [a] + append out "[a+ {*}$fc web-white]Extended underlines$RST" \n + set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST" + set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST" + set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST" + set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" + append out "${indent}$undercurly $underdotted" \n + append out "${indent}$underdashed" \n + append out "${indent}$underline_c" \n + append out "${indent}Extended underlines/colours can suppress other SGR codes on terminals that don't support them if codes are merged." \n + append out "${indent}punk::ansi tries to keep them in separate escape sequences (standard SGR followed by extended) even during merge operations to avoid this." \n + append out "${indent}If a fallback to standard underline is required, underline should be added along with extended codes such as underlinedotted, underlinedouble etc" \n + append out "${indent}e.g cyan with curly yellow underline or fallback all cyan underlined \[a+ cyan undercurly underline undt-yellow\]text\[a] -> [a+ {*}$fc cyan undercurly underline undt-yellow]text$RST" \n + append out "[a+ {*}$fc web-white]Standard SGR colours and attributes $RST" \n + set settings_applied $SGR_setting_map + set strmap [list] + dict for {k v} $SGR_setting_map { + switch -- $k { + bold - dim - italic - doubleunderline - blink - fastblink - strike - overline - framecircle { + lappend strmap " $k " " [a+ $k]$k$RST " + } + noreverse - nounderline { + #prefixed version will match before unprefixed - will not be subject to further replacement scanning + lappend strmap "$k" "[a+ $k]$k$RST" ;#could replace with self - but may as well put in punk::ansi::sgr_cache (can make cache a little neater to display) + } + underline - reverse - frame { + #1st coloumn - no leading space + lappend strmap "$k " "[a+ $k]$k$RST " + } + } + } + set settings_applied [string trim $SGR_setting_map \n] try { package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try - set bgname "White" - set map1 [colourmap1 $bgname] - set map1 [overtype::centre -transparent 1 $map1 "[a black $bgname]Standard colours[a]"] - set map2 [colourmap2 $bgname] - set map2 [overtype::centre -transparent 1 $map2 "[a black $bgname]High-intensity colours[a]"] - append out [textblock::join $map1 " " $map2] \n - #append out $map1[a] \n - #append out $map2[a] \n - append out [colourblock_216] + package require textblock + append out [textblock::join $indent [string map $strmap $settings_applied]] \n + append out [textblock::join $indent [string trim $SGR_colour_map \n]] \n + append out [textblock::join $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n + set bgname "Web-white" + set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour] + set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"] + set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour] + set map2 [overtype::centre -transparent 1 $map2 "[a {*}$fc black $bgname]High-intensity colours[a]"] + append out [textblock::join $indent [textblock::join $map1 $map2]] \n + append out "[a+ {*}$fc web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n + append out [textblock::join $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n + append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n + append out [textblock::join $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n + append out \n + append out [textblock::join $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n + append out [textblock::join $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n + append out [textblock::join $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n + append out \n + append out "[a+ {*}$fc web-white]16 Million colours[a]" \n + #dict set WEB_colour_map mediumvioletred 199-21-133 ;# #C71585 + append out [textblock::join $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n + append out [textblock::join $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n + append out [textblock::join $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n + append out \n + append out "[a+ {*}$fc web-white]Web colours[a]" \n + append out [textblock::join $indent "To see all names use: a? web"] \n + append out [textblock::join $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n + append out [textblock::join $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n + append out \n + append out [textblock::join $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n + append out \n + append out "[a+ {*}$fc web-white]X11 colours[a] - mostly match Web colours" \n + append out [textblock::join $indent "To see differences: a? x11"] \n + + if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { + append out \n + if {$fc ne ""} { + append out "[a+ {*}$fc web-white]Colour is currently disabled - returning with colour anyway because 'forcecolour' argument was supplied[a]" \n + } else { + append out "Colour is currently disabled - to return with colour anyway - add the 'forcecolour' argument" \n + } + } } on error {result options} { puts stderr "Failed to draw colourmap" @@ -1394,23 +2066,242 @@ namespace eval punk::ansi { return $out } } else { - set result [list] - set map [dict merge $SGR_setting_map $SGR_colour_map] - set rmap [lreverse $map] + switch -- [lindex $args 0] { + term { + set termargs [lrange $args 1 end] + foreach ta $termargs { + switch -- $ta { + pastel - rainbow {} + default {error "unrecognised term option '$ta'. Known values: pastel rainbow"} + } + } + set out "16 basic colours\n" + append out [colourtable_16_names -forcecolour $opt_forcecolour] \n + append out "216 colours\n" + append out [colourtable_216_names -forcecolour $opt_forcecolour] \n + append out "24 greyscale colours\n" + append out [colourtable_24_names -forcecolour $opt_forcecolour] + foreach ta $termargs { + switch -- $ta { + pastel { + append out \n + append out "Pastel Colour Space (punk::ansi::colourtable_term_pastel)\n" + append out [colourtable_term_pastel -forcecolour $opt_forcecolour] + } + rainbow { + append out \n + append out "Rainbow Colours (punk::ansi::colourtable_term_rainbow)\n" + append out [colourtable_term_rainbow -forcecolour $opt_forcecolour] + } + } + } + append out "\nNote: The 256 term colours especially 0-15 may be altered by terminal pallette settings or ansi OSC 4 codes, so specific RGB values are unavailable" + return $out + } + web { + return [colourtable_web -forcecolour $opt_forcecolour -groups [lrange $args 1 end]] + } + x11 { + set out "" + append out " Mostly same as web - known differences displayed" \n + append out [colourtable_x11diff -forcecolour $opt_forcecolour] + return $out + } + } + + variable WEB_colour_map + variable X11_colour_map + variable TERM_colour_map + variable TERM_colour_map_reverse + variable SGR_map + + set t [textblock::class::table new] + $t configure -show_edge 0 -show_seps 1 -show_header 0 + + set resultlist [list] foreach i $args { - if {[string is integer -strict $i]} { - if {[dict exists $rmap $i]} { - lappend result $i [dict get $rmap $i] + set f4 [string range $i 0 3] + set s [a+ {*}$fc $i]sample + switch -- $f4 { + web- - Web- - WEB- { + set tail [string tolower [string trim [string range $i 4 end] -]] + if {[dict exists $WEB_colour_map $tail]} { + set dec [dict get $WEB_colour_map $tail] + set hex [colour_dec2hex $dec] + set descr "$hex $dec" + } else { + set descr "UNKNOWN colour for web" + } + $t add_row [list $i $descr $s [ansistring VIEW $s]] } - } else { - if {[dict exists $map $i]} { - lappend result $i [dict get $map $i] + term - Term - undt { + set tail [string trim [string range $i 4 end] -] + if {[string is integer -strict $tail]} { + if {$tail < 256} { + set descr "[dict get $TERM_colour_map_reverse $tail]" + } else { + set descr "Invalid (> 255)" + } + } else { + set tail [string tolower $tail] + if {[dict exists $TERM_colour_map $tail]} { + set descr [dict get $TERM_colour_map $tail] + } else { + set descr "UNKNOWN colour for term" + } + } + $t add_row [list $i $descr $s [ansistring VIEW $s]] + } + x11- - X11- { + set tail [string tolower [string trim [string range $i 4 end] -]] + if {[dict exists $X11_colour_map $tail]} { + set dec [dict get $X11_colour_map $tail] + set hex [colour_dec2hex $dec] + set descr "$hex $dec" + } else { + set descr "UNKNOWN colour for x11" + } + $t add_row [list $i $descr $s [ansistring VIEW $s]] + } + rgb- - Rgb- - RGB- - + rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - + Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - + RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - + rgb# - Rgb# - RGB# - + und# - und- { + if {[string index $i 3] eq "#"} { + set tail [string range $i 4 end] + set hex $tail + set dec [colour_hex2dec $hex] + set info $dec ;#show opposite type as first line of info col + } else { + set tail [string trim [string range $i 3 end] -] + set dec $tail + set hex [colour_dec2hex $dec] + set info $hex + } + + set webcolours_i [lsearch -all $WEB_colour_map $dec] + set webcolours [list] + foreach ci $webcolours_i { + lappend webcolours [lindex $WEB_colour_map $ci-1] + } + set x11colours [list] + set x11colours_i [lsearch -all $X11_colour_map $dec] + foreach ci $x11colours_i { + set c [lindex $X11_colour_map $ci-1] + if {$c ni $webcolours} { + lappend x11colours $c + } + } + foreach c $webcolours { + append info \n web-$c + } + foreach c $x11colours { + append info \n x11-$c + } + $t add_row [list $i "$info" $s [ansistring VIEW $s]] + } + unde { + switch -- $i { + undercurly - underdotted - underdashed - undersingle - underdouble { + $t add_row [list $i extended $s [ansistring VIEW $s]] + } + underline { + $t add_row [list $i "SGR 4" $s [ansistring VIEW $s]] + } + default { + $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] + } + } + } + default { + if {[string is integer -strict $i]} { + set rmap [lreverse $SGR_map] + $t add_row [list $i "SGR [dict get $rmap $i]" $s [ansistring VIEW $s]] + } else { + if {[dict exists $SGR_map $i]} { + $t add_row [list $i "SGR [dict get $SGR_map $i]" $s [ansistring VIEW $s]] + } else { + $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] + } + } } } } + set ansi [a+ {*}$fc {*}$args] + set s ${ansi}sample + #set merged [punk::ansi::codetype::sgr_merge_singles [list $ansi]] + set merged [punk::ansi::codetype::sgr_merge [list $ansi]] + set s2 ${merged}sample + #lappend resultlist "RESULT: [a+ {*}$args]sample[a]" + $t add_row [list RESULT "" $s [ansistring VIEW $s]] + if {$ansi ne $merged} { + if {[string length $merged] < [string length $ansi]} { + #only refer to redundancies if shorter - merge may reorder - REVIEW + set warning "[a+ web-red Web-yellow]REDUNDANCIES FOUND" + } else { + set warning "" + } + $t add_row [list MERGED $warning $s2 [ansistring VIEW $s2]] + } + set result [$t print] + $t destroy return $result } } + + #REVIEW! note that OSC 4 can change the 256 color pallette + #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ + # (or with colour name instead of rgb #HHHHHH on for example wezterm) + + #Q: If we can't detect OSC 4 - how do we know when to invalidate/clear at least the 256 color portion of the cache? + #A: The cache values should still be valid - and the terminal should display the newly assigned colour. + # If in line mode - perhaps readline or something else is somehow storing the rgb values and replaying invalid colours? + # On wezterm - we can get cells changing colour as we scroll after a pallette change - so something appears to be caching colours + + variable sgr_cache + set sgr_cache [dict create] + + #sgr_cache clear called by punk::console::ansi when set to off + proc sgr_cache {{action ""}} { + variable sgr_cache + if {$action ni {"" clear}} { + error "sgr_cache action '$action' not understood. Valid actions: clear" + } + if {$action eq "clear"} { + set sgr_cache [dict create] + return "sgr_cache cleared" + } + if {[catch { + set termwidth [dict get [punk::console::get_size] columns] + } errM]} { + set termwidth 80 + } + set termwidth [expr [$termwidth -3]] + set out "" + set linelen 0 + set RST [a] + set lines [list] + set line "" + #todo - terminal width? table? + dict for {key ansi} $sgr_cache { + set thislen [expr {[string length $key]+1}] + if {$linelen + $thislen >= $termwidth-1} { + lappend lines $line + set line "$ansi$key$RST " + set linelen $thislen + } else { + append line "$ansi$key$RST " + incr linelen $thislen + } + } + if {[string length $line]} { + lappend lines $line + } + return [join $lines \n] + } + proc a+ {args} { #*** !doctools #[call [fun a+] [opt {ansicode...}]] @@ -1421,124 +2312,350 @@ namespace eval punk::ansi { #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes + #function name part of cache-key because a and a+ return slightly different results (a has leading reset) + variable sgr_cache + set cache_key a+$args ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key + if {[dict exists $sgr_cache $cache_key]} { + return [dict get $sgr_cache $cache_key] + } + #don't disable ansi here. #we want this to be available to call even if ansi is off - variable SGR_map variable WEB_colour_map variable TERM_colour_map - variable X11_colour_map + + + set colour_disabled 0 + #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear + if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { + set colour_disabled 1 + } + #allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything. + set forcecolour 0 + set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour + if {$fcpos >= 0} { + set forcecolour 1 + set args [lremove $args $fcpos] + } set t [list] + set e [list] ;#extended codes needing to go in own escape sequence foreach i $args { - if {[string is integer -strict $i]} { - lappend t $i - } elseif {[string first ";" $i] >=0} { - #literal with params - lappend t $i - } else { - if {[dict exists $SGR_map $i]} { - #SGR case must match exactly those in the map - lappend t [dict get $SGR_map $i] - } else { - #accept examples for foreground - # 256f- or 256fg- or 256f - # rgbf--- or rgbfg--- or rgbf-- - switch -- [string range $i 0 3] { - term { - #256 colour foreground by Xterm name or by integer - #name is xterm name or colour index from 0 - 255 - set cc [string trim [string tolower [string range $i 4 end]] -] - if {[string is integer -strict $cc]} { - lappend t "38;5;$cc" - } else { - if {[dict exists $TERM_colour_map $cc]} { - set cc [dict get $TERM_colour_map $cc] - lappend t "38;5;$cc" + set f4 [string range $i 0 3] + switch -- $f4 { + web- { + #variable WEB_colour_map + #upvar ::punk::ansi::WEB_colour_map WEB_colour_map + #foreground web colour + set cname [string tolower [string range $i 4 end]] + if {[dict exists $WEB_colour_map $cname]} { + set rgbdash [dict get $WEB_colour_map $cname] + set rgb [string map { - ;} $rgbdash] + lappend t "38;2;$rgb" + } else { + puts stderr "ansi web colour unmatched: '$i' in call 'a+ $args'" + } + } + Web- - WEB- { + #variable WEB_colour_map + #upvar ::punk::ansi::WEB_colour_map WEB_colour_map + #background web colour + set cname [string tolower [string range $i 4 end]] + if {[dict exists $WEB_colour_map $cname]} { + lappend t "48;2;[string map {- ;} [dict get $WEB_colour_map $cname]]" + } else { + puts stderr "ansi Web colour unmatched: '$i' in call 'a+ $args'" + } + } + rese {lappend t 0 ;#reset} + bold {lappend t 1} + dim {lappend t 2} + blin { + #blink + lappend t 5 } - } - } - Term - TERM { - #256 colour background by Xterm name or by integer - set cc [string trim [string tolower [string range $i 4 end]] -] - if {[string is integer -strict $cc]} { - lappend t "48;5;$cc" - } else { - if {[dict exists $TERM_colour_map $cc]} { - set cc [dict get $TERM_colour_map $cc] - lappend t "48;5;$cc" + fast { + #fastblink + lappend t 6 } - } - } - rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 { - #decimal rgb foreground - set rgbspec [string trim [string range $i 3 end] -] - set rgb [string map [list - {;} , {;}] $rgbspec] - lappend t "38;2;$rgb" - } - Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { - #decimal rgb background - set rgbspec [string trim [string range $i 3 end] -] - set rgb [string map [list - {;} , {;}] $rgbspec] - lappend t "48;2;$rgb" - } - "rgb#" { - #hex rgb foreground - set hex6 [string trim [string range $i 4 end] -] - set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - lappend t "38;2;$rgb" - } - "Rgb#" - "RGB#" { - #hex rgb background - set hex6 [string trim [string range $i 4 end] -] - set rgb [join [::scan $hex6 %2X%2X%2X] {;}] - lappend t "48;2;$rgb" - } - web- { - #foreground web colour - set cname [string tolower [string range $i 4 end]] - if {[dict exists $WEB_colour_map $cname]} { - set rgbdash [dict get $WEB_colour_map $cname] - set rgb [string map [list - {;}] $rgbdash] - lappend t "38;2;$rgb" - } - } - Web- - WEB- { - #background web colour - set cname [string tolower [string range $i 4 end]] - if {[dict exists $WEB_colour_map $cname]} { - set rgbdash [dict get $WEB_colour_map $cname] - set rgb [string map [list - {;}] $rgbdash] - lappend t "48;2;$rgb" - } + nobl { + #noblink + lappend t 25 + } + hide {lappend t 8} + norm {lappend t 22 ;#normal} + unde { + #TODO - fix + # extended codes with colon suppress normal SGR attributes when in same escape sequence on terminal that don't support the extended codes. + # need to emit in + switch -- $i { + underline { + lappend t 4 ;#underline + } + underextendedoff { + #lremove any existing 4:1 etc + set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } + undersingle { + lappend e 4:1 + } + underdouble { + lappend e 4:2 + } + undercurly { + lappend e 4:3 + } + underdotted { + lappend e 4:4 + } + underdashed { + lappend e 4:5 + } + default { + puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)" + } + } + } + doub {lappend t 21 ;#doubleunderline} + noun { + lappend t 24 ;#nounderline + #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } + stri {lappend t 9 ;#strike} + nost {lappend t 29 ;#nostrike} + ital {lappend t 3 ;#italic} + noit {lappend t 23 ;#noitalic} + reve {lappend t 7 ;#reverse} + nore {lappend t 27 ;#noreverse} + defa { + switch -- $i { + defaultfg { + lappend t 39 + } + defaultbg { + lappend t 49 + } + defaultund { + lappend t 59 + } + default { + puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" + } + } + } + nohi {lappend t 28 ;#nohide} + over {lappend t 53 ;#overline} + noov {lappend t 55 ;#nooverline} + fram { + if {$i eq "frame"} { + lappend t 51 ;#frame + } else { + lappend t 52 ;#framecircle + } + } + nofr {lappend t 54 ;#noframe} + blac {lappend t 30 ;#black} + red {lappend t 31} + gree {lappend t 32 ;#green} + yell {lappend t 33 ;#yellow} + blue {lappend t 34} + purp {lappend t 35 ;#purple} + cyan {lappend t 36} + whit {lappend t 37 ;#white} + Blac {lappend t 40 ;#Black} + Red {lappend t 41} + Gree {lappend t 42 ;#Green} + Yell {lappend t 43 ;#Yellow} + Blue {lappend t 44} + Purp {lappend t 45 ;#Purple} + Cyan {lappend t 46} + Whit {lappend t 47 ;#White} + brig { + switch -- $i { + brightblack {lappend t 90} + brightred {lappend t 91} + brightgreen {lappend t 92} + brightyellow {lappend t 93} + brightblue {lappend t 94} + brightpurple {lappend t 95} + brightcyan {lappend t 96} + brightwhite {lappend t 97} + } + } + Brig { + switch -- $i { + Brightblack {lappend t 100} + Brightred {lappend t 101} + Brightgreen {lappend t 102} + Brightyellow {lappend t 103} + Brightblue {lappend t 104} + Brightpurple {lappend t 105} + Brightcyan {lappend t 106} + Brightwhite {lappend t 107} + } + } + term { + #variable TERM_colour_map + #256 colour foreground by Xterm name or by integer + #name is xterm name or colour index from 0 - 255 + set cc [string trim [string tolower [string range $i 4 end]] -] + if {[string is integer -strict $cc] & $cc < 256} { + lappend t "38;5;$cc" + } else { + if {[dict exists $TERM_colour_map $cc]} { + lappend t "38;5;[dict get $TERM_colour_map $cc]" + } else { + puts stderr "ansi term colour unmatched: '$i' in call 'a+ $args'" } - x11- { - #foreground X11 names - set cname [string tolower [string range $i 4 end]] - if {[dict exists $X11_colour_map $cname]} { - set rgbdash [dict get $X11_colour_map $cname] - set rgb [string map [list - {;}] $rgbdash] - lappend t "38;2;$rgb" - } + } + } + Term - TERM { + #variable TERM_colour_map + #256 colour background by Xterm name or by integer + set cc [string trim [string tolower [string range $i 4 end]] -] + if {[string is integer -strict $cc] && $cc < 256} { + lappend t "48;5;$cc" + } else { + if {[dict exists $TERM_colour_map $cc]} { + lappend t "48;5;[dict get $TERM_colour_map $cc]" + } else { + puts stderr "ansi Term colour unmatched: '$i' in call 'a+ $args'" } - X11- { - #background X11 names - set cname [string tolower [string range $i 4 end]] - if {[dict exists $X11_colour_map $cname]} { - set rgbdash [dict get $X11_colour_map $cname] - set rgb [string map [list - {;}] $rgbdash] - lappend t "48;2;$rgb" - } + } + } + rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 { + #decimal rgb foreground + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + set rgbspec [string trim [string range $i 3 end] -] + set rgb [string map [list - {;} , {;}] $rgbspec] + lappend t "38;2;$rgb" + } + Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { + #decimal rgb background + set rgbspec [string trim [string range $i 3 end] -] + set rgb [string map [list - {;} , {;}] $rgbspec] + lappend t "48;2;$rgb" + } + "rgb#" { + #hex rgb foreground + set hex6 [string trim [string range $i 4 end] -] + set rgb [join [::scan $hex6 %2X%2X%2X] {;}] + lappend t "38;2;$rgb" + } + "Rgb#" - "RGB#" { + #hex rgb background + set hex6 [string trim [string range $i 4 end] -] + set rgb [join [::scan $hex6 %2X%2X%2X] {;}] + lappend t "48;2;$rgb" + } + und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + set rgbspec [string trim [string range $i 3 end] -] + set rgb [string map [list - {:} , {:}] $rgbspec] + lappend e "58:2::$rgb" + } + "und#" { + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + set hex6 [string trim [string range $i 4 end] -] + set rgb [join [::scan $hex6 %2X%2X%2X] {:}] + lappend e "58:2::$rgb" + } + undt { + #variable TERM_colour_map + #256 colour underline by Xterm name or by integer + #name is xterm name or colour index from 0 - 255 + set cc [string trim [string tolower [string range $i 4 end]] -] + if {[string is integer -strict $cc] & $cc < 256} { + lappend e "58:5:$cc" + } else { + if {[dict exists $TERM_colour_map $cc]} { + lappend e "58:5:[dict get $TERM_colour_map $cc]" + } else { + puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } } + } + x11- { + variable X11_colour_map + #foreground X11 names + set cname [string tolower [string range $i 4 end]] + if {[dict exists $X11_colour_map $cname]} { + set rgbdash [dict get $X11_colour_map $cname] + set rgb [string map [list - {;}] $rgbdash] + lappend t "38;2;$rgb" + } else { + puts stderr "ansi x11 colour unmatched: '$i' in call 'a+ $args'" + } + } + X11- { + variable X11_colour_map + #background X11 names + set cname [string tolower [string range $i 4 end]] + if {[dict exists $X11_colour_map $cname]} { + set rgbdash [dict get $X11_colour_map $cname] + set rgb [string map [list - {;}] $rgbdash] + lappend t "48;2;$rgb" + } else { + puts stderr "ansi X11 colour unmatched: '$i'" + } + } + default { + if {[string is integer -strict $i] || [string first ";" $i] > 0} { + lappend t $i + } elseif {[string first : $i] > 0} { + lappend e $i + } else { + puts stderr "ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" + } + } + } + } + #the performance penalty must not be placed on the standard colour_enabled path. + #This is punk. Colour is the happy path despite the costs. + #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. + #As no_color doesn't strip all ansi - the motivation for it should not generally be + if {$colour_disabled && !$forcecolour} { + set tkeep [list] + foreach code $t { + switch -- $code { + 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { + #SGR underline and other non colour effects + lappend tkeep $code + } + } + } + set t $tkeep + set ekeep [list] + foreach code $e { + switch -- $code { + 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { + lappend ekeep $code + } } } + set e $ekeep } + # \033 - octal. equivalently \x1b in hex which is more common in documentation if {![llength $t]} { - return "" ;# a+ nonexistent should return nothing rather than a reset ( \033\[\;m is a reset even without explicit zero(s)) + if {![llength $e]} { + set result "" ;# a+ nonexistent should return nothing rather than a reset ( \033\[\;m is a reset even without explicit zero(s)) + } else { + set result "\x1b\[[join $e {;}]m" + } + } else { + if {![llength $e]} { + set result "\x1b\[[join $t {;}]m" + } else { + set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m" + } } - return "\x1b\[[join $t {;}]m" + dict set sgr_cache $cache_key $result + return $result } proc a {args} { @@ -1552,111 +2669,337 @@ namespace eval punk::ansi { #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes - #variable SGR_setting_map { - # bold 1 dim 2 blink 5 fastblink 6 noblink 25 hide 8 normal 22 - # underline 4 doubleunderline 21 nounderline 24 strike 9 nostrike 29 italic 3 noitalic 23 - # reverse 7 noreverse 27 defaultfg 39 defaultbg 49 nohide 28 - # overline 53 nooverline 55 frame 51 framecircle 52 noframe 54 - #} - #variable SGR_colour_map { - # black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37 - # Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 - # BLACK 100 RED 101 GREEN 102 YELLOW 103 BLUE 104 PURPLE 105 CYAN 106 WHITE 107 - #} + #It's important to put the functionname in the cache-key because a and a+ return slightly different results + variable sgr_cache + set cache_key a_$args + if {[dict exists $sgr_cache $cache_key]} { + return [dict get $sgr_cache $cache_key] + } #don't disable ansi here. #we want this to be available to call even if ansi is off - #variable SGR_map - set t [list] + variable WEB_colour_map + variable TERM_colour_map + + set colour_disabled 0 + #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear + if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { + set colour_disabled 1 + } + #allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything. + set forcecolour 0 + set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour + if {$fcpos >=0} { + set forcecolour 1 + set args [lremove $args $fcpos] + } + + set t [list] + set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence foreach i $args { - switch -- $i { - bold {lappend t 1} - dim {lappend t 2} - blink {lappend t 5} - fastblink {lappend t 6} - noblink {lappend t 25} - hide {lappend t 8} - normal {lappend t 22} - underline {lappend t 4} - doubleunderline {lappend t 21} - nounderline {lappend t 24} - strike {lappend t 9} - nostrike {lappend t 29} - italic {lappend t 3} - noitalic {lappend t 23} - reverse {lappend t 7} - noreverse {lappend t 27} - defaultfb {lappend t 39} - defaultbg {lappedn t 49} - nohide {lappend t 28} - overline {lappend t 53} - nooverline {lappend t 55} - frame {lappend t 51} - framecircle {lappend t 52} - noframe {lappend t 54} - black {lappend t 30} - red {lappend t 31} - green {lappend t 32} - yellow {lappend t 33} - blue {lappend t 34} - purple {lappend t 35} - cyan {lappend t 36} - white {lappend t 37} - Black {lappend t 40} - Red {lappend t 41} - Green {lappend t 42} - Yellow {lappend t 43} - Blue {lappend t 44} - Purple {lappend t 45} - Cyan {lappend t 46} - White {lappend t 47} - BLACK {lappend t 100} - RED {lappend t 101} - GREEN {lappend t 101} - YELLOW {lappend t 103} - BLUE {lappend t 104} - PURPLE {lappend t 105} - CYAN {lappend t 106} - WHITE {lappend t 107} + set f4 [string range $i 0 3] + switch -- $f4 { + web- { + #variable WEB_colour_map + #upvar ::punk::ansi::WEB_colour_map WEB_colour_map + #foreground web colour + set cname [string tolower [string range $i 4 end]] + if {[dict exists $WEB_colour_map $cname]} { + set rgbdash [dict get $WEB_colour_map $cname] + set rgb [string map { - ;} $rgbdash] + lappend t "38;2;$rgb" + } else { + puts stderr "ansi web colour unmatched: '$i' in call 'a $args'" + } + } + Web- - WEB- { + #variable WEB_colour_map + #upvar ::punk::ansi::WEB_colour_map WEB_colour_map + #background web colour + set cname [string tolower [string range $i 4 end]] + if {[dict exists $WEB_colour_map $cname]} { + lappend t "48;2;[string map {- ;} [dict get $WEB_colour_map $cname]]" + } else { + puts stderr "ansi Web colour unmatched: '$i' in call 'a $args'" + } + } + rese {lappend t 0 ;#reset} + bold {lappend t 1} + dim {lappend t 2} + blin { + #blink + lappend t 5 + } + fast { + #fastblink + lappend t 6 + } + nobl { + #noblink + lappend t 25 + } + hide {lappend t 8} + norm {lappend t 22 ;#normal} + unde { + switch -- $i { + underline { + lappend t 4 ;#underline + } + underextendedoff { + #lremove any existing 4:1 etc + set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } + undersingle { + lappend e 4:1 + } + underdouble { + lappend e 4:2 + } + undercurly { + lappend e 4:3 + } + underdotted { + lappend e 4:4 + } + underdashed { + lappend e 4:5 + } + default { + puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)" + } + } + } + doub {lappend t 21 ;#doubleunderline} + noun { + lappend t 24 ;#nounderline + #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } + stri {lappend t 9 ;#strike} + nost {lappend t 29 ;#nostrike} + ital {lappend t 3 ;#italic} + noit {lappend t 23 ;#noitalic} + reve {lappend t 7 ;#reverse} + nore {lappend t 27 ;#noreverse} + defa { + switch -- $i { + defaultfg { + lappend t 39 + } + defaultbg { + lappend t 49 + } + defaultund { + lappend t 59 + } + default { + puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" + } + } + } + nohi {lappend t 28 ;#nohide} + over {lappend t 53 ;#overline} + noov {lappend t 55 ;#nooverline} + fram { + if {$i eq "frame"} { + lappend t 51 ;#frame + } else { + lappend t 52 ;#framecircle + } + } + nofr {lappend t 54 ;#noframe} + blac {lappend t 30 ;#black} + red {lappend t 31} + gree {lappend t 32 ;#green} + yell {lappend t 33 ;#yellow} + blue {lappend t 34} + purp {lappend t 35 ;#purple} + cyan {lappend t 36} + whit {lappend t 37 ;#white} + Blac {lappend t 40 ;#Black} + Red {lappend t 41} + Gree {lappend t 42 ;#Green} + Yell {lappend t 43 ;#Yellow} + Blue {lappend t 44} + Purp {lappend t 45 ;#Purple} + Cyan {lappend t 46} + Whit {lappend t 47 ;#White} + brig { + switch -- $i { + brightblack {lappend t 90} + brightred {lappend t 91} + brightgreen {lappend t 92} + brightyellow {lappend t 93} + brightblue {lappend t 94} + brightpurple {lappend t 95} + brightcyan {lappend t 96} + brightwhite {lappend t 97} + } + } + Brig { + switch -- $i { + Brightblack {lappend t 100} + Brightred {lappend t 101} + Brightgreen {lappend t 102} + Brightyellow {lappend t 103} + Brightblue {lappend t 104} + Brightpurple {lappend t 105} + Brightcyan {lappend t 106} + Brightwhite {lappend t 107} + } + } + term { + #variable TERM_colour_map + #256 colour foreground by Xterm name or by integer + #name is xterm name or colour index from 0 - 255 + set cc [string trim [string tolower [string range $i 4 end]] -] + if {[string is integer -strict $cc] & $cc < 256} { + lappend t "38;5;$cc" + } else { + if {[dict exists $TERM_colour_map $cc]} { + lappend t "38;5;[dict get $TERM_colour_map $cc]" + } else { + puts stderr "ansi term colour unmatched: '$i' in call 'a $args'" + } + } + } + Term - TERM { + #variable TERM_colour_map + #256 colour background by Xterm name or by integer + set cc [string trim [string tolower [string range $i 4 end]] -] + if {[string is integer -strict $cc] && $cc < 256} { + lappend t "48;5;$cc" + } else { + if {[dict exists $TERM_colour_map $cc]} { + lappend t "48;5;[dict get $TERM_colour_map $cc]" + } else { + puts stderr "ansi Term colour unmatched: '$i' in call 'a $args'" + } + } + } + rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 { + #decimal rgb foreground + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + set rgbspec [string trim [string range $i 3 end] -] + set rgb [string map [list - {;} , {;}] $rgbspec] + lappend t "38;2;$rgb" + } + Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { + #decimal rgb background + set rgbspec [string trim [string range $i 3 end] -] + set rgb [string map [list - {;} , {;}] $rgbspec] + lappend t "48;2;$rgb" + } + "rgb#" { + #hex rgb foreground + set hex6 [string trim [string range $i 4 end] -] + set rgb [join [::scan $hex6 %2X%2X%2X] {;}] + lappend t "38;2;$rgb" + } + "Rgb#" - "RGB#" { + #hex rgb background + set hex6 [string trim [string range $i 4 end] -] + set rgb [join [::scan $hex6 %2X%2X%2X] {;}] + lappend t "48;2;$rgb" + } + und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + set rgbspec [string trim [string range $i 3 end] -] + set rgb [string map [list - {:} , {:}] $rgbspec] + lappend e "58:2::$rgb" + } + "und#" { + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + set hex6 [string trim [string range $i 4 end] -] + set rgb [join [::scan $hex6 %2X%2X%2X] {:}] + lappend e "58:2::$rgb" + } + undt { + #variable TERM_colour_map + #256 colour underline by Xterm name or by integer + #name is xterm name or colour index from 0 - 255 + set cc [string trim [string tolower [string range $i 4 end]] -] + if {[string is integer -strict $cc] & $cc < 256} { + lappend e "58:5:$cc" + } else { + if {[dict exists $TERM_colour_map $cc]} { + lappend e "58:5:[dict get $TERM_colour_map $cc]" + } else { + puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" + } + } + } + x11- { + variable X11_colour_map + #foreground X11 names + set cname [string tolower [string range $i 4 end]] + if {[dict exists $X11_colour_map $cname]} { + set rgbdash [dict get $X11_colour_map $cname] + set rgb [string map [list - {;}] $rgbdash] + lappend t "38;2;$rgb" + } else { + puts stderr "ansi x11 colour unmatched: '$i'" + } + } + X11- { + variable X11_colour_map + #background X11 names + set cname [string tolower [string range $i 4 end]] + if {[dict exists $X11_colour_map $cname]} { + set rgbdash [dict get $X11_colour_map $cname] + set rgb [string map [list - {;}] $rgbdash] + lappend t "48;2;$rgb" + } else { + puts stderr "ansi X11 colour unmatched: '$i'" + } + } default { - if {[string is integer -strict $i]} { - lappend t $i - } elseif {[string first ";" $i] >=0} { - #literal with params + if {[string is integer -strict $i] || [string first ";" $i] > 0} { lappend t $i + } elseif {[string first : $i] > 0} { + lappend e $i } else { - #accept examples for foreground - # 256f-# or 256fg-# or 256f# - # rgbf--- or rgbfg--- or rgbf-- - switch -nocase -glob -- $i { - "256f*" { - set cc [string trim [string range $i 4 end] -gG] - lappend t "38;5;$cc" - } - "256b*" { - set cc [string trim [string range $i 4 end] -gG] - lappend t "48;5;$cc" - } - "rgbf*" { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "38;2;$r;$g;$b" - } - "rgbb*" { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "48;2;$r;$g;$b" - } - } + puts stderr "ansi name unmatched: '$i' in call 'a $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" } } } } + + if {$colour_disabled && !$forcecolour} { + set tkeep [list] + foreach code $t { + switch -- $code { + 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { + #SGR underline and other non colour effects + lappend tkeep $code + } + } + } + set t $tkeep + set ekeep [list] + foreach code $e { + switch -- $code { + 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { + lappend ekeep $code + } + } + } + set e $ekeep + } + # \033 - octal. equivalently \x1b in hex which is more common in documentation - # empty list [a=] should do reset - same for [a= nonexistant] + # empty list [a] should do reset - same for [a nonexistant] # explicit reset at beginning of parameter list for a= (as opposed to a+) - set t [linsert $t 0 0] - return "\x1b\[[join $t {;}]m" + set t [linsert $t[unset t] 0 0] + if {![llength $e]} { + set result "\x1b\[[join $t {;}]m" + } else { + set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m" + } + dict set sgr_cache $cache_key $result + return $result } proc ansiwrap {codes text} { @@ -2289,10 +3632,15 @@ namespace eval punk::ansi { dict set codestate_empty italic "" ;#3 on 23 off dict set codestate_empty underline "" ;#4 on 24 off - #nonstandard 4:3,4:4,4:5 - dict set codestate_empty curlyunderline "" - dict set codestate_empty dottedunderline "" - dict set codestate_empty dashedunderline "" + #nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5 + #4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions + #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines + dict set codestate_empty underextended "" ;#4:0 for no extended underline 4:1 etc for underline styles + #dict set codestate_empty undersingle "" + #dict set codestate_empty underdouble "" + #dict set codestate_empty undercurly "" + #dict set codestate_empty underdottedn "" + #dict set codestate_empty underdashed "" dict set codestate_empty blink "" ;#5 or 6 for slow/fast, 25 for off dict set codestate_empty reverse "" ;#7 on 27 off @@ -2300,7 +3648,7 @@ namespace eval punk::ansi { dict set codestate_empty strike "" ;#9 on 29 off dict set codestate_empty font "" ;#10, 11-19 10 being primary dict set codestate_empty gothic "" ;#20 - dict set codestate_empty doubleunderline "" ;#21 + dict set codestate_empty doubleunderline "" ;#21 (standard SGR double as opposed to underdouble) dict set codestate_empty proportional "" ;#26 - see note below dict set codestate_empty frame_or_circle "" ;#51,52 on - 54 off (54 off) (not generally used - mintty has repurposed for emoji variation selector) @@ -2311,7 +3659,7 @@ namespace eval punk::ansi { dict set codestate_empty ideogram_doubleoverline "" dict set codestate_empty ideogram_clear "" - dict set codestate_empty overline "" ;#53 on 55 off - probably not supported - pass through. + dict set codestate_empty overline "" ;#53 on 55 off - probably not supported - pass through. Seem to be ok to merge with other SGR even if not supported. dict set codestate_empty underlinecolour "" ;#58 - same arguments as 256colour and rgb (nonstandard - in Kitty ,VTE,mintty and iTerm2) # -- mintty? @@ -2353,10 +3701,11 @@ namespace eval punk::ansi { set defaults [dict create\ -filter_fg 0\ -filter_bg 0\ + -filter_reset 0\ ] dict for {k v} $args { switch -- $k { - -filter_fg - -filter_bg {} + -filter_fg - -filter_bg - -filter_reset {} default { error "sgr_merge unknown option '$k'. Known options [dict keys $defaults]" } @@ -2415,8 +3764,10 @@ namespace eval punk::ansi { set codeint [string trimleft [lindex $paramsplit 0] 0] switch -- $codeint { "" - 0 { - set codestate $codestate_initial - set did_reset 1 + if {![dict get $opts -filter_reset]} { + set codestate $codestate_initial + set did_reset 1 + } } 1 { #bold @@ -2436,31 +3787,30 @@ namespace eval punk::ansi { dict set codestate italic 3 } 4 { + #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines if {[llength $paramsplit] == 1} { dict set codestate underline 4 } else { switch -- [lindex $paramsplit 1] { 0 { - #no underline - dict set codestate underline 24 - dict set codestate curlyunderline "" - dict set codestate dottedunderline "" - dict set codestate dashedunderline "" + #no *extended* underline + #dict set codestate underline 24 + dict set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended } 1 { - dict set codestate underline 4 ;#straight underline + dict set codestate underextended 4:1 } 2 { - dict set codestate doubleunderline 21 + dict set codestate underextended 4:2 } 3 { - dict set codestate curlyunderline "4:3" + dict set codestate underextended "4:3" } 4 { - dict set codestate dottedunderline "4:4" + dict set codestate underextended "4:4" } 5 { - dict set codestate dashedunderline "4:5" + dict set codestate underextended "4:5" } } @@ -2486,7 +3836,7 @@ namespace eval punk::ansi { } 21 { #ECMA-48 double underline - some terminals use as not-bold. For now we won't support that. - dict set doubleunderline 21 + dict set codestate doubleunderline 21 } 22 { #normal intensity @@ -2499,9 +3849,7 @@ namespace eval punk::ansi { } 24 { dict set codestate underline 24 ;#off - dict set codestate curlyunderline "" - dict set codestate dottedunderline "" - dict set codestate dashedunderline "" + dict set codestate underextended "4:0" ;#review } 25 { dict set codestate blink 25 ;#off @@ -2673,11 +4021,11 @@ namespace eval punk::ansi { } set codemerge "" + set unmergeable "" ;# can merge with each other but not main set (for terminals not supporting extended codes) if {[dict get $opts -filter_fg] || [dict get $opts -filter_bg]} { dict for {k v} $codestate { switch -- $v { "" { - } default { switch -- $k { @@ -2691,6 +4039,9 @@ namespace eval punk::ansi { append codemerge "${v}\;" } } + underlinecolour - underextended { + append unmergeable "${v}\;" + } default { append codemerge "${v}\;" } @@ -2703,20 +4054,42 @@ namespace eval punk::ansi { switch -- $v { "" {} default { - append codemerge "${v}\;" + switch -- $k { + underlinecolour - underextended { + append unmergeable "${v}\;" + } + default { + append codemerge "${v}\;" + } + } } } } } if {$did_reset} { + #review - unmergeable set codemerge "0\;$codemerge" + if {$codemerge eq ""} { + set unmergeable "0\;$unmergeable" + } } - if {[string length $codemerge]} { + #puts "+==> codelist:[ansistring VIEW $codelist] did_reset:$did_reset codemerge:[ansistring VIEW $codemerge] unmergeable:[ansistring VIEW $unmergeable]" + if {$codemerge ne ""} { set codemerge [string trimright $codemerge {;}] - return "\x1b\[${codemerge}m[join $othercodes ""]" + if {$unmergeable ne ""} { + set unmergeable [string trimright $unmergeable {;}] + return "\x1b\[${codemerge}m\x1b\[${unmergeable}m[join $othercodes ""]" + } else { + return "\x1b\[${codemerge}m[join $othercodes ""]" + } } else { - #there were no SGR codes - not even resets - return [join $othercodes ""] + if {$unmergeable eq ""} { + #there were no SGR codes - not even resets + return [join $othercodes ""] + } else { + set unmergeable [string trimright $unmergeable {;}] + return "\x1b\[${unmergeable}m[join $othercodes ""]" + } } } @@ -3825,7 +5198,7 @@ namespace eval punk::ansi::class { set displaycode [ansistring VIEW $code] if {$col eq ""} { #row only move - set map [list H "H${arrow_lr}" f "f${arrow_lr}] + set map [list H "H${arrow_lr}" f "f${arrow_lr}"] } else { #row and col move set map [list H "H${arrow_lr}${arrow_du}" f "${arrow_lr}${arrow_du}"] @@ -4266,9 +5639,12 @@ namespace eval punk::ansi::ansistring { if {$opt_cr} { dict set visuals_opt CR [list \x0d \u240d] } - if {$opt_lf} { + if {$opt_lf == 1} { dict set visuals_opt LF [list \x0a \u240a] } + if {$opt_lf == 2} { + dict set visuals_opt LF [list \x0a \u240a\n] + } if {$opt_vt} { dict set visuals_opt VT [list \x0b \u240b] } diff --git a/src/bootsupport/modules/punk/char-0.1.0.tm b/src/bootsupport/modules/punk/char-0.1.0.tm index 6e179905..43c449c6 100644 --- a/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/bootsupport/modules/punk/char-0.1.0.tm @@ -1852,15 +1852,27 @@ namespace eval punk::char { #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 grapheme_width_cached {ch} { + #review - effective memory leak on longrunning programs if never cleared + #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner + proc grapheme_width_cached {ch {key ""}} { variable grapheme_widths - if {[dict exists $grapheme_widths $ch]} { - return [dict get $grapheme_widths $ch] + #if key eq "*" - we won't be able to clear that cache individually. Perhaps that's ok + if {[dict exists $grapheme_widths $key $ch]} { + return [dict get $grapheme_widths $key $ch] } set width [punk::char::ansifreestring_width $ch] ;#review - can we provide faster version if we know it's a single grapheme rather than a string? (grapheme is still a string as it may have combiners/diacritics) - dict set grapheme_widths $ch $width + dict set grapheme_widths $key $ch $width return $width } + proc grapheme_width_cache_clear {key} { + variable grapheme_widths + if {$key eq "*} { + set grapheme_widths [dict create] + } else { + dict unset grapheme_widths $key + } + return + } #no char_width - use grapheme_width terminology to be clearer proc grapheme_width {char} { error "grapheme_width unimplemented - use ansifreestring_width" diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 538c7797..158368c9 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -775,61 +775,47 @@ namespace eval punk::console { #a and a+ functions are not very useful when emitting directly to console #e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first - #proc a {args} { - # variable colour_disabled - # variable ansi_wanted - # if {$colour_disabled || $ansi_wanted <= 0} { - # return - # } - # #stdout - # tailcall 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 a? {args} { #stdout - variable colour_disabled variable ansi_wanted - if {$colour_disabled || $ansi_wanted <= 0} { + if {$ansi_wanted <= 0} { puts -nonewline [punk::ansi::stripansi [::punk::ansi::a?]] } else { tailcall ansi::a? {*}$args } } + proc code_a+ {args} { + variable ansi_wanted + if {$ansi_wanted <= 0} { + return + } + #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here + #tailcall punk::ansi::a+ {*}$args + ::punk::ansi::a+ {*}$args + } proc code_a {args} { - variable colour_disabled variable ansi_wanted - if {$colour_disabled || $ansi_wanted <= 0} { + if {$ansi_wanted <= 0} { return } - tailcall punk::ansi::a {*}$args + #tailcall punk::ansi::a {*}$args + ::punk::ansi::a {*}$args } proc code_a? {args} { - variable colour_disabled variable ansi_wanted - if {$colour_disabled || $ansi_wanted <= 0} { + if {$ansi_wanted <= 0} { return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]] } else { tailcall ::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 - } + #REVIEW! this needs reworking. + #It needs to be clarified as to what ansi off is supposed to do. + #Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames? + #It will stop underlines/bold/reverse as well as SGR colours + #what about ansi movement codes etc? proc ansi {{onoff {}}} { variable ansi_wanted if {[string length $onoff]} { @@ -846,6 +832,7 @@ namespace eval punk::console { false - no { set ansi_wanted 0 + punk::ansi::sgr_cache clear } default { set ansi_wanted 2 @@ -855,25 +842,36 @@ namespace eval punk::console { } } } - catch {repl::reset_prompt} + catch {punk::repl::reset_prompt} return [expr {$ansi_wanted}] } - proc colour {{onoff {}}} { + + #colour + # Turning colour off will stop SGR colour codes from being generated unless 'forcecolour' is added to the argument list for the punk::ans::a functions + proc colour {{on {}}} { variable colour_disabled - if {[string length $onoff]} { - set onoff [string tolower $onoff] + if {$on ne ""} { + if {![string is boolean -strict $on]} { + error "punk::console::colour expected a boolean e.g 0|1|on|off|true|false|yes|no" + } #an experiment with complete disabling vs test of state for each call - if {$onoff in [list 1 on true yes]} { - 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 - set colour_disabled 1 + if {$on} { + if {$colour_disabled} { + #change of state + punk::ansi::sgr_cache clear + catch {punk::repl::reset_prompt} + set colour_disabled 0 + } } else { - error "punk::console::colour expected 0|1|on|off|true|false|yes|no" + #we don't disable a/a+ entirely - they must still emit underlines/bold/reverse + if {!$colour_disabled} { + #change of state + punk::ansi::sgr_cache clear + catch {punk::repl::reset_prompt} + set colour_disabled 1 + } } } - catch {repl::reset_prompt} return [expr {!$colour_disabled}] } @@ -1197,6 +1195,9 @@ namespace eval punk::console { namespace import ansi::cursor_on namespace import ansi::cursor_off + #review - the concept of using local mechanisms at all (ie apis) vs ansi is not necessarily something we want/need to support. + #For the system to be really useful if needs to operate in conditions where the terminal is remote + #This seems to be why windows console is deprecating various non-ansi api methods for interacting with the console. namespace eval local { proc titleset {windowtitle} { if {"windows" eq $::tcl_platform(platform)} { @@ -1243,17 +1244,21 @@ namespace eval punk::console { return [local::titleget] } - proc infocmp_test {} { + proc infocmp {} { set cmd1 [auto_execok infocmp] if {[string length $cmd1]} { - puts stderr "infocmp seems to be available" + puts stderr "" return [exec {*}$cmd1] } else { - puts stderr "infcmp doesn't seem to be present" + puts stderr "infocmp doesn't seem to be present" + if {$::tcl_platform(os) eq "FreeBSD"} { + puts stderr "For FreeBSD - install ncurses to get infocmp and related binaries and also install terminfo-db" + } set tcmd [auto_execok tput] if {[string length $tcmd]} { puts stderr "tput seems to be available. Try something like: tput -S - (freebsd)" } + #todo - what? can tput query all caps? OS differences? } } @@ -1280,6 +1285,7 @@ namespace eval punk::console { return [split $data ";"] } + #channel? namespace eval ansi { proc move {row col} { puts -nonewline stdout [punk::ansi::move $row $col] @@ -1320,6 +1326,12 @@ namespace eval punk::console { proc scroll_down {n} { puts -nonewline stdout [punk::ansi::scroll_down $n] } + proc enable_alt_screen {} { + puts -nonewline stdout [punk::ansi::enable_alt_screen] + } + proc disable_alt_screen {} { + puts -nonewline stdout [punk::ansi::disable_alt_screen] + } #review - worth the extra microseconds to inline? might be if used in for example prompt on every keypress. #caller should build as much as possible using the punk::ansi versions to avoid extra puts calls @@ -1373,8 +1385,10 @@ namespace eval punk::console { namespace import ansi::cursor_restore namespace import ansi::cursor_save_dec namespace import ansi::cursor_restore_dec - namespace import ansi::scroll_down namespace import ansi::scroll_up + namespace import ansi::scroll_down + namespace import ansi::enable_alt_screen + namespace import ansi::disable_alt_screen namespace import ansi::insert_spaces namespace import ansi::delete_characters namespace import ansi::erase_characters diff --git a/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/bootsupport/modules/punk/lib-0.1.1.tm index a29f3057..7a3e98a7 100644 --- a/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -179,6 +179,54 @@ namespace eval punk::lib::compat { } + #slight isolation - varnames don't leak - but calling context vars can be affected + proc lmaptcl2 {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result [apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + if {"::lmap" ne [info commands ::lmap]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lib::compat::lmaptcl + } + #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway + proc lmaptcl {varnames list script} { + set result [list] + set varlist [list] + foreach varname $varnames { + upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc + lappend varlist var_$varname + } + foreach $varlist $list { + lappend result [uplevel 1 $script] + } + return $result + } #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] @@ -196,6 +244,99 @@ namespace eval punk::lib { #[para] Core API functions for punk::lib #[list_begin definitions] + #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env + proc lmapflat_closure {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + # -- --- --- + #capture - use uplevel 1 or namespace eval depending on context + set capture [uplevel 1 { + apply { varnames { + set capturevars [dict create] + set capturearrs [dict create] + foreach fullv $varnames { + set v [namespace tail $fullv] + upvar 1 $v var + if {[info exists var]} { + if {(![array exists var])} { + dict set capturevars $v $var + } else { + dict set capturearrs capturedarray_$v [array get var] + } + } else { + #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set + } + } + return [dict create vars $capturevars arrs $capturearrs] + } } [info vars] + } ] + # -- --- --- + set cvars [dict get $capture vars] + set carrs [dict get $capture arrs] + set apply_script "" + foreach arrayalias [dict keys $carrs] { + set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { + array set %realname% [set %arrayalias%][unset %arrayalias%] + }] + } + + append apply_script [string map [list %script% $script] { + #foreach arrayalias [info vars capturedarray_*] { + # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + # array set $realname [set $arrayalias][unset arrayalias] + #} + #return [eval %script%] + %script% + }] + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + [concat $varnames [dict keys $cvars] [dict keys $carrs] ]\ + $apply_script\ + ] {*}[subst $values] {*}[dict values $cvars] {*}[dict values $carrs] ] + } + return $result + } + #link version - can write to vars in calling context - but keeps varnames themselves isolated + #performance much better than capture version - but still a big price to pay for the isolation + proc lmapflat_link {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + proc lmapflat {varnames list script} { + concat {*}[uplevel 1 [list lmap $varnames $list $script]] + } proc dict_getdef {dictValue args} { if {[llength $args] < 1} { @@ -970,11 +1111,12 @@ namespace eval punk::lib { -block {trimhead1 trimtail1}\ -line {}\ -commandprefix ""\ - -ansiresets 0\ + -ansiresets auto\ + -ansireplays 0\ ] dict for {o v} $arglist { switch -- $o { - -block - -line - -commandprefix - -ansiresets {} + -block - -line - -commandprefix - -ansiresets - -ansireplays {} default { error "linelist: Unrecognized option '$o' usage:$usage" } @@ -1033,6 +1175,17 @@ namespace eval punk::lib { # -- --- --- --- --- --- set opt_ansiresets [dict get $opts -ansiresets] # -- --- --- --- --- --- + set opt_ansireplays [dict get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- set linelist [list] set nlsplit [split $text \n] if {![llength $opt_line]} { @@ -1119,17 +1272,23 @@ namespace eval punk::lib { #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} { + if {$opt_ansireplays} { package require punk::ansi - set RST [punk::ansi::a] + if {$opt_ansiresets} { + set RST [punk::ansi::a] + } else { + set RST "" + } 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 + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed } - set linelist $transformed } else { #INLINE punk::ansi::codetype::is_sgr_reset diff --git a/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd index 047321ee..9de4c125 100644 --- a/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/bootsupport/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd @@ -54,9 +54,9 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @REM @ECHO nextshelltype is %nextshelltype[win32___________]% @REM @SET "selected_shelltype=%nextshelltype[win32___________]%" @SET "selected_shelltype=%nextshelltype[win32___________]%" -@ECHO selected_shelltype %selected_shelltype% +@REM @ECHO selected_shelltype %selected_shelltype% @CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed -@ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% +@REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% @SET "selected_shellpath=%nextshellpath[win32___________]%" @CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed @CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%" @@ -202,8 +202,8 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' IF NOT "x%keyRemoved%"=="x%validshelltypes%" ( REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx - %selected_shellpath_trimmed% "%~dp0%fname%" %arglist% - SET task_exitcode=!errorlevel! + REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode + %selected_shellpath_trimmed% "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; ) ELSE ( ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% SET task_exitcode=66 diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index 93e5f449..da9fa09b 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -1580,7 +1580,7 @@ namespace eval punk::ns { #review - upvar in apply within ns eval vs direct access of ${ns}::varname set capture [namespace eval $ns { apply { varnames { - while {"prev_args_[incr n]" in $varnames} {} + while {"prev_args[incr n]" in $varnames} {} set capturevars [dict create] set capturearrs [dict create] foreach fullv $varnames { diff --git a/src/bootsupport/modules/textblock-0.1.1.tm b/src/bootsupport/modules/textblock-0.1.1.tm index 6f267dbc..0c9ce48b 100644 --- a/src/bootsupport/modules/textblock-0.1.1.tm +++ b/src/bootsupport/modules/textblock-0.1.1.tm @@ -28,10 +28,15 @@ package require term::ansi::code::macros ;#required for frame if old ansi g0 use package require textutil namespace eval textblock { + #review - what about ansi off in punk::console? + namespace import ::punk::ansi::a ::punk::ansi::a+ + namespace eval class { variable opts_table_defaults set opts_table_defaults [dict create\ -title ""\ + -titlealign "left"\ + -titletransparent 0\ -frametype "light"\ -frametype_header ""\ -ansibase_header ""\ @@ -62,6 +67,8 @@ namespace eval textblock { -show_vseps ""\ -show_header ""\ -show_footer ""\ + -minwidth ""\ + -maxwidth ""\ ] #for 'L' shaped table building pattern (tables bigger than 4x4 will be mostly 'L' patterns) #ie only vll,blc,hlb used for cells except top row and right column @@ -226,8 +233,12 @@ namespace eval textblock { variable o_rowstates variable o_opts_table_defaults + variable o_opts_header_defaults ;# header data mostly stored in o_columndefs variable o_opts_column_defaults variable o_opts_row_defaults + variable TSUB ;#make configurable so user isn't stopped from using our default PUA-unicode char in content (nerdfonts overlap) + variable o_calculated_column_widths + variable o_column_width_algorithm constructor {args} { #*** !doctools #[call class::table [method constructor] [arg args]] @@ -250,11 +261,31 @@ namespace eval textblock { my configure {*}[dict merge $o_opts_table_defaults $args] set o_columndefs [dict create] set o_columndata [dict create] ;#we store data by column even though it is often added row by row - set o_columnstates [dict create] ;#store the maxwidthbodyseen as we add rows and maxwidthheaderseen as we add headers - it is needed often and expensive to calculate repeatedly + set o_columnstates [dict create] ;#store the maxwidthbodyseen etc as we add rows and maxwidthheaderseen etc as we add headers - it is needed often and expensive to calculate repeatedly set o_headerstates [dict create] set o_rowdefs [dict create] ;#user requested row data e.g -minheight -maxheight set o_rowstates [dict create] ;#actual row data such as -minheight and -maxheight detected from supplied row data + set TSUB \uF111 ;#should be BMP PUA code to show as either replacement char or nerdfont glyph. See FSUB for comments regarding choices. + set o_calculated_column_widths [list] + set o_column_width_algorithm "span" + set header_defaults [dict create\ + -colspans {}\ + -values {}\ + -ansibase {}\ + ] + set o_opts_header_defaults $header_defaults + } + + method width_algorithm {{alg ""}} { + if {$alg eq ""} { + return $o_column_width_algorithm + } + if {$alg ne $o_column_width_algorithm} { + #invlidate cached widths + set o_calculated_column_widths [list] + } + set o_column_width_algorithm $alg } method Get_seps {} { set requested_seps [dict get $o_opts_table -show_seps] @@ -490,6 +521,34 @@ namespace eval textblock { error "textblock::table::configure -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" } } + -show_hseps { + if {![string is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations + } + -show_edge { + if {![string is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + lappend checked_opts $k $v + #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + } + -show_vseps { + #we allow empty string - so don't use -strict boolean check + if {![string is boolean $v]} { + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + } + #affects width calculations + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } + -minwidth - -maxwidth { + set o_calculated_column_widths [list] + lappend checked_opts $k $v + } default { lappend checked_opts $k $v } @@ -591,6 +650,8 @@ namespace eval textblock { -ansireset "\uFFEF"\ -minwidth ""\ -maxwidth ""\ + -blockalign centre\ + -textalign left\ ] #initialise -ansireset with replacement char so we can keep in appropriate dict position for initial configure and then treat as read-only set o_opts_column_defaults $defaults @@ -607,7 +668,8 @@ namespace eval textblock { dict set o_columndata $colcount [list] dict set o_columndefs $colcount $defaults ;#ensure record exists - dict set o_columnstates $colcount [dict create maxwidthbodyseen 0 maxwidthheaderseen 0] + dict set o_columnstates $colcount [dict create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] + set prev_calculated_column_widths $o_calculated_column_widths if {[catch { my configure_column $colcount {*}$opts } errMsg]} { @@ -615,8 +677,12 @@ namespace eval textblock { dict unset o_columndata $colcount dict unset o_columndefs $colcount dict unset o_columnstates $colcount + #undo cache invalidation + set o_calculated_column_widths $prev_calculated_column_widths error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" } + #any add_column that succeeds should invalidate the calculated column widths + set o_calculated_column_widths [list] set numrows [my row_count] if {$numrows > 0} { #fill column with default values @@ -624,7 +690,8 @@ namespace eval textblock { set dval [dict get $opts -defaultvalue] set width [textblock::width $dval] dict set o_columndata $colcount [lrepeat $numrows $dval] - dict set o_columnstates $colcount [maxwidthbodyseen $width] + dict set o_columnstates $colcount maxwidthbodyseen $width + dict set o_columnstates $colcount minwidthbodyseen $width } return $colcount } @@ -639,6 +706,24 @@ namespace eval textblock { if {![llength $args]} { return [dict get $o_columndefs $cidx] } else { + if {[llength $args] == 1} { + if {[lindex $args 0] in [dict keys $o_opts_column_defaults]} { + #query single option + set k [lindex $args 0] + set val [dict get $o_columndefs $cidx $k] + set returndict [dict create option $k value $val ansireset "\x1b\[m"] + set infodict [dict create] + switch -- $k { + -ansibase { + dict set infodict debug [ansistring VIEW $val] + } + } + dict set returndict info $infodict + return $returndict + } else { + error "textblock::table configure_column - unrecognised option '[lindex $args 0]'. Known values [dict keys $o_opts_column_defaults]" + } + } if {[llength $args] %2 != 0} { error "textblock::table configure_column unexpected argument count. Require name value pairs. Known options: [dict keys $o_opts_column_defaults]" } @@ -653,23 +738,29 @@ namespace eval textblock { dict for {k v} $args { switch -- $k { -headers { - #todo - multiline header set i 0 + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. foreach hdr $v { set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns #set this_header_height [textblock::height $hdr] lassign [textblock::size $hdr] _w this_header_width _h this_header_height if {$this_header_height >= $currentmax} { - dict set hstates $i -maxheight $this_header_height + dict set hstates $i maxheightseen $this_header_height } else { - dict set hstates $i -maxheight $currentmax + dict set hstates $i maxheightseen $currentmax } - if {$this_header_width > [dict get $colstate maxwidthheaderseen]} { - dict set colstate maxwidthheaderseen $this_header_width + if {$this_header_width >= $maxseen} { + set maxseen $this_header_width } + #if {$this_header_width > [dict get $colstate maxwidthheaderseen]} { + # dict set colstate maxwidthheaderseen $this_header_width + #} incr i } + dict set colstate maxwidthheaderseen $maxseen + #review - we could avoid some recalcs if we check current width range compared to previous + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed lappend checked_opts $k $v } -header_colspans { @@ -742,6 +833,16 @@ namespace eval textblock { } incr h } + #todo - avoid recalc if no change + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + lappend checked_opts $k $v + } + -minwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed + lappend checked_opts $k $v + } + -maxwidth { + set o_calculated_column_widths [list] ;#invalidate cached column widths - a recalc will be forced when needed lappend checked_opts $k $v } -ansibase { @@ -766,6 +867,16 @@ namespace eval textblock { error "textblock::table::configure_column -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" } } + -blockalign - -textalign { + switch -- $v { + left - right { + lappend checked_opts $k $v + } + centre - centre { + lappend checked_opts $k centre + } + } + } default { lappend checked_opts $k $v } @@ -813,7 +924,7 @@ namespace eval textblock { } method header_height {header_index} { set idx [lindex [dict keys $o_headerstates $header_index]] - return [dict get $o_headerstates $idx -maxheight] + return [dict get $o_headerstates $idx maxheightseen] } #review - use maxwidth (considering colspans) of each column to determine height after wrapping @@ -886,11 +997,277 @@ namespace eval textblock { } return $colspans_by_header } + + #should be configure_headerrow ? + method configure_header {index_expression args} { + #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. + #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis + #e.g o_headerstates: 0 {maxheightseen 1} 1 {maxheightseen 2} + set num_headers [my header_count_calc] + set hidx [lindex [dict keys $o_headerstates] $index_expression] + if {$hidx eq ""} { + error "textblock::table::configure_header - no row defined at index '$hidx'." + } + if {$hidx > $num_headers -1} { + #assert - shouldn't happen + error "textblock::table::configure_header error headerstates data is out of sync" + } + + if {![llength $args]} { + set colspans_by_header [my header_colspans] + set result [dict create] + dict set result -colspans [dict get $colspans_by_header $hidx] + set header_row_items [list] + dict for {cidx cdef} $o_columndefs { + set colheaders [dict get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + } + dict set result -values $header_row_items + return $result + } + if {[llength $args] == 1} { + if {[lindex $args 0] in [dict keys $o_opts_header_defaults]} { + #query single option + set k [lindex $args 0] + #set val [dict get $o_rowdefs $ridx $k] + + set infodict [dict create] + switch -- $k { + -values { + set header_row_items [list] + dict for {cidx cdef} $o_columndefs { + set colheaders [dict get $cdef -headers] + set relevant_header [lindex $colheaders $hidx] + #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + + } + set val $header_row_items + set returndict [dict create option $k value $val ansireset "\x1b\[m"] + } + -colspans { + set colspans_by_header [my header_colspans] + set result [dict create] + set val [dict get $colspans_by_header $hidx] + set returndict [dict create option $k value $val ansireset "\x1b\[m"] + } + -ansibase { + set val ??? + set returndict [dict create option $k value $val ansireset "\x1b\[m"] + dict set infodict debug [ansistring VIEW $val] + } + } + dict set returndict info $infodict + return $returndict + #return [dict create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_header - unrecognised option '[lindex $args 0]'. Known values [dict keys $o_opts_header_defaults]" + } + } + if {[llength $args] %2 != 0} { + error "textblock::table configure_header incorrect number of options following index_expression. Require name value pairs. Known options: [dict keys $o_opts_header_defaults]" + } + dict for {k v} $args { + if {$k ni [dict keys $o_opts_header_defaults]} { + error "[namespace current]::table configure_row unknown option '$k'. Known options: [dict keys $o_opts_header_defaults]" + } + } + + set checked_opts [list] + dict for {k v} $args { + switch -- $k { + -ansibase { + set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" + set header_ansibase_items [list] ; + foreach {pt code} $parts { + if {$pt ne ""} { + #we don't expect plaintext in an ansibase + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + } + if {$code ne ""} { + lappend header_ansibase_items $code + } + } + set header_ansibase [punk::ansi::codetype::sgr_merge_singles $row_ansibase_items] + error "sorry - -ansibase not yet implemented for header rows" + lappend checked_opts $k $header_ansibase + } + -ansireset { + if {$v eq "\uFFEF"} { + lappend checked_opts $k "\x1b\[m" ;# [a] + } else { + error "textblock::table::configure_header -ansireset is read-only. It is present only to prevent unwanted colourised output in configure commands" + } + } + -values { + if {[llength $v] > [dict size $o_columndefs]} { + error "textblock::table::configure_header -values length ([llength $v]) is longer than number of columns ([dict size $o_columndefs])" + } + lappend checked_opts $k $v + } + -colspans { + set numcols [dict size $o_columndefs] + if {[llength $v] > $numcols} { + error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([dict size $o_columndefs])" + } + if {[llength $v] < $numcols} { + puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [dict size $o_columndefs] columns." + puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" + } + if {[llength $v]} { + set firstspan [lindex $v 0] + set first_is_ok 0 + if {$firstspan eq "all"} { + set first_is_ok 1 + } elseif {[string is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { + set first_is_ok 1 + } + if {!$first_is_ok} { + error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"all\"" + } + #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) + set remaining $firstspan + if {$remaining ne "all"} { + incr remaining -1 + } + set spanview $v + set sidx 1 + #because we allow 'all' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'all' first + foreach span [lrange $v 1 end] { + if {$remaining eq "all"} { + if {$span eq "all"} { + set remaining "all" + } elseif {$span > 0} { + #ok to reset to higher val immediately or after an all and any number of following zeros + if {$span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"all\".[a] $spanview" + } + set remaining $span + incr remaining -1 + } else { + #zero following an all - leave remaining as all + } + } else { + if {$span eq "0"} { + if {$remaining eq "0"} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"all\" value.[a] $spanview" + } else { + incr remaining -1 + } + } else { + if {$remaining eq "0"} { + #ok for new span value of all or > 0 + if {$span ne "all" && $span > ($numcols - $sidx)} { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"all\".[a] $spanview" + } + set remaining $span + if {$remaining ne "all"} { + incr remaining -1 + } + } else { + lset spanview $sidx [a+ web-red]$span[a] + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require zero value span.[a] $spanview" + } + } + } + incr sidx + } + } + #empty -colspans list should be ok + + #error "sorry - -colspans not yet implemented for header rows - set manually in vertical order via configure_column for now" + lappend checked_opts $k $v + } + default { + lappend checked_opts $k $v + } + } + } + + #configured opts all good + + dict for {k v} $checked_opts { + switch -- $k { + -values { + set c 0 + foreach hval $v { + #retrieve -headers from relevant col, insert at header index, and write back. + set colheaders [dict get $o_columndefs $c -headers] + set missing [expr {($hidx +1) - [llength $colheaders]}] + if {$missing > 0} { + lappend colheaders {*}[lrepeat $missing ""] + } + lset colheaders $hidx $hval + dict set o_columndefs $c -headers $colheaders + #invalidate column width cache + set o_calculated_column_widths [list] + # -- -- -- -- -- -- + #also update maxwidthseen & maxheightseen + set i 0 + set maxwidthseen 0 + set maxheightseen 0 + foreach hdr $colheaders { + lassign [textblock::size $hdr] _w this_header_width _h this_header_height + if {$this_header_height >= $maxheightseen} { + dict set o_headerstates $i maxheightseen $this_header_height + } else { + dict set o_headerstates $i maxheightseen $maxheightseen + } + if {$this_header_width >= $maxwidthseen} { + set maxwidthseen $this_header_width + } + incr i + } + dict set o_columnstates $c maxwidthheaderseen $maxwidthseen + # -- -- -- -- -- -- + incr c + } + } + -colspans { + #sequence has been verified above - we need to split it and store across columns + set c 0 ;#column index + foreach span $v { + set colspans [dict get $o_columndefs $c -header_colspans] + if {$hidx > [llength $colspans]-1} { + set colspans_by_header [my header_colspans] + #puts ">>>>>?$colspans_by_header" + #we are allowed to lset only one beyond the current length to append + #but there may be even less or no entries present in a column + # - the ability to underspecify and calculate the missing values makes setting the values complicated. + #use the header_colspans calculation to update only those entries necessary + set spanlist [list] + for {set h 0} {$h < $hidx} {incr h} { + set cspans [dict get $colspans_by_header $h] + set requiredval [lindex $cspans $c] + lappend spanlist $requiredval + } + dict set o_columndefs $c -header_colspans $spanlist + + set colspans [dict get $o_columndefs $c -header_colspans] + } + + lset colspans $hidx $span + dict set o_columndefs $c -header_colspans $colspans + incr c + } + } + } + } + } + method add_row {valuelist args} { #*** !doctools #[call class::table [method add_row] [arg args]] if {[dict size $o_columndefs] > 0 && ([llength $valuelist] && [llength $valuelist] != [dict size $o_columndefs])} { - error "add_row - invalid number of values in row - Must match existing column count: [dict size $o_columndefs]" + set msg "" + append msg "add_row - invalid number ([llength $valuelist]) of values in row - Must match existing column count: [dict size $o_columndefs]" \n + append msg "rowdata: $valuelist" + error $msg } if {[dict size $o_columndefs] == 0 && ![llength $valuelist]} { error "add_row - no values supplied, and no columns defined, so cannot use default column values" @@ -950,11 +1327,13 @@ namespace eval textblock { error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" } - set c 0 set max_height_seen 1 foreach v $valuelist { + set prev_maxwidth [dict get $o_columnstates $c maxwidthbodyseen] + set prev_minwidth [dict get $o_columnstates $c minwidthbodyseen] + dict lappend o_columndata $c $v set valheight [textblock::height $v] if {$valheight > $max_height_seen} { @@ -964,8 +1343,17 @@ namespace eval textblock { if {$width > [dict get $o_columnstates $c maxwidthbodyseen]} { dict set o_columnstates $c maxwidthbodyseen $width } + if {$width < [dict get $o_columnstates $c minwidthbodyseen]} { + dict set o_columnstates $c minwidthbodyseen $width + } + + if {[dict get $o_columnstates $c maxwidthbodyseen] > $prev_maxwidth || [dict get $o_columnstates $c minwidthbodyseen] < $prev_minwidth} { + #invalidate calculated column width cache if any new value was outside the previous range of widths + set o_calculated_column_widths [list] + } incr c } + set opt_maxh [dict get $o_rowdefs $rowcount -maxheight] if {$opt_maxh ne ""} { dict set o_rowstates $rowcount -maxheight [expr {min($opt_maxh,$max_height_seen)}] @@ -983,6 +1371,25 @@ namespace eval textblock { if {![llength $args]} { return [dict get $o_rowdefs $ridx] } + if {[llength $args] == 1} { + if {[lindex $args 0] in [dict keys $o_opts_row_defaults]} { + #query single option + set k [lindex $args 0] + set val [dict get $o_rowdefs $ridx $k] + set returndict [dict create option $k value $val ansireset "\x1b\[m"] + set infodict [dict create] + switch -- $k { + -ansibase { + dict set infodict debug [ansistring VIEW $val] + } + } + dict set returndict info $infodict + return $returndict + #return [dict create option $k value $val ansireset "\x1b\[m" info $infodict] + } else { + error "textblock::table configure_row - unrecognised option '[lindex $args 0]'. Known values [dict keys $o_opts_row_defaults]" + } + } if {[llength $args] %2 != 0} { error "textblock::table configure_row incorrect number of options following index_expression. Require name value pairs. Known options: [dict keys $o_opts_row_defaults]" } @@ -1051,8 +1458,11 @@ namespace eval textblock { #The data values are stored by column regardless of whether added row by row dict for {cidx records} $o_columndata { dict set o_columndata $cidx [list] - dict set o_columnstates $cidx [dict create maxwidthbodyseen 0 maxwidthheaderseen 0] + #reset only the body fields in o_columnstates + dict set o_columnstates $cidx minwidthbodyseen 0 + dict set o_columnstates $cidx maxwidthbodyseen 0 } + set o_calculated_column_widths [list] } method clear {} { my row_clear @@ -1060,9 +1470,12 @@ namespace eval textblock { set o_columndata [dict create] set o_columnstates [dict create] } - method Get_columns_by_name {namematch_list} { - } + + + #method Get_columns_by_name {namematch_list} { + #} + #specify range with x..y method Get_columns_by_indices {index_list} { foreach spec $index_list { @@ -1110,6 +1523,7 @@ namespace eval textblock { return [dict create boxlimits $boxlimits_position boxlimits_top $boxlimits_toprow joins $joins bodyjoins $header_body_joins ] } method get_column_by_index {index_expression args} { + #puts "+++> get_column_by_index $index_expression $args [namespace current]" #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. set defaults [dict create\ -position "inner"\ @@ -1263,11 +1677,18 @@ namespace eval textblock { set botseps_v [dict get $sep_elements_vertical bottom$opt_posn] set onlyseps_v [dict get $sep_elements_vertical only$opt_posn] + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway set headerseps_v [dict get $sep_elements_vertical top$opt_posn] lassign [my Get_seps] _h show_seps_h _v show_seps_v set return_headerheight 0 set return_headerwidth 0 + set cidx [lindex [dict keys $o_columndefs] $index_expression] + + set colwidth [my column_width $cidx] + + set col_blockalign [dict get $o_columndefs $cidx -blockalign] + if {$do_show_header} { #puts "boxlimitsinfo header $opt_posn: -- boxlimits $header_boxlimits -- boxmap $hdrmap" set ansibase_header [dict get $o_opts_table -ansibase_header] ;#merged to single during configure @@ -1278,13 +1699,13 @@ namespace eval textblock { } else { set ansiborder_final $ansibase_header$ansiborder_header } - set cidx [lindex [dict keys $o_columndefs] $index_expression] - set RST [a] - set colwidth [my column_width $cidx] - set hcell_line_blank [string repeat " " $colwidth] + set RST [punk::ansi::a] + + + set hcolwidth $colwidth + #set hcolwidth [my column_width_configured $cidx] + set hcell_line_blank [string repeat " " $hcolwidth] - set h 0 - set hmax [expr {[llength $header_list] -1}] set all_colspans [my header_colspans] #default span_extend_map - used as base to customise with specific joins @@ -1294,16 +1715,19 @@ namespace eval textblock { tlc [dict get $fdef_header hlt]\ blc [dict get $fdef_header hlb]\ ] - set framedef_leftbox [textblock::framedef $ftype_header left] + set framedef_leftbox [textblock::framedef $ftype_header -joins left] - set column_width_cache [dict create] + #used for colspan-zero header frames + set framesub_map [list hl $TSUB vll $TSUB vlr $TSUB tlc $TSUB blc $TSUB trc $TSUB brc $TSUB] ;# a debug test + set hrow 0 + set hmax [expr {[llength $header_list] -1}] foreach header $header_list { - set headerspans [dict get $all_colspans $h] + set headerspans [dict get $all_colspans $hrow] set this_span [lindex $headerspans $cidx] set hval $ansibase_header$header ;#no reset - set rowh [my header_height $h] + set rowh [my header_height $hrow] #set h_lines [lrepeat $rowh $hcell_line_blank] #set hcell_blank [join $h_lines \n] @@ -1312,23 +1736,23 @@ namespace eval textblock { #set hval_block [join $hval_lines \n] #set headercell [overtype::left -experimental test_mode $ansibase_header$hcell_blank$RST $hval_block] - if {$h == 0} { + if {$hrow == 0} { set hlims $header_boxlimits_toprow set rowpos "top" - if {$h == $hmax} { + if {$hrow == $hmax} { set rowpos "only" } } else { set hlims $header_boxlimits set rowpos "middle" - if {$h == $hmax} { + if {$hrow == $hmax} { set rowpos "bottom" } } if {!$show_seps_v} { set hlims [struct::set difference $hlims $headerseps_v] } - if {$h == $hmax} { + if {$hrow == $hmax} { set header_joins $header_body_joins } else { set header_joins $joins @@ -1337,17 +1761,16 @@ namespace eval textblock { set hlims [struct::set difference $hlims [dict get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] } #puts ">>> headerspans: $headerspans cidx: $cidx" - if {$this_span eq "all" || $this_span > 0} { - + if {$this_span eq "all" || $this_span > 0} { set startmap [dict get $hmap $rowpos${opt_posn}] #look at spans in header below to determine joins required at blc if {$show_seps_v} { - if {[dict exists $all_colspans [expr {$h+1}]]} { - set next_spanlist [dict get $all_colspans [expr {$h+1}]] + if {[dict exists $all_colspans [expr {$hrow+1}]]} { + set next_spanlist [dict get $all_colspans [expr {$hrow+1}]] set spanbelow [lindex $next_spanlist $cidx] if {$spanbelow == 0} { - #we don't want a down-join for blc - retrieve a framedef with only left joins + #we don't want a down-join for blc - use a framedef with only left joins dict set startmap blc [dict get $framedef_leftbox blc] } } else { @@ -1355,21 +1778,44 @@ namespace eval textblock { } } - #todo - multiline header cells + multiple header lines (will be more useful when colspans implemented) - set header_cell_startspan [textblock::frame -width [expr {$colwidth+2}] -type [dict get $ftypes header]\ + #supporting wrapping in headers might be a step too difficult for little payoff. + #we would need a flag to enable/disable - plus language-based wrapping alg (see tcllib) + #The interaction with colspans and width calculations makes it likely to have a heavy performance impact and make the code even more complex. + #May be better to require user to pre-wrap as needed + ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] + + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) + + # -width is always +2 - as the boxlimits take into account show_vseps and show_edge + #set header_cell_startspan [textblock::frame -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [dict get $ftypes header]\ + # -ansibase $ansibase_header -ansiborder $ansiborder_final\ + # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ + # ] + + if {$this_span eq "1"} { + #write the actual value now + set cellcontents $hval + } else { + #just write an empty vertical placeholder. The spanned value will be overtyped below + set cellcontents [join [lrepeat [llength [split $hval \n]] ""] \n] + } + set header_cell_startspan [textblock::frame -blockalign $col_blockalign -ellipsis 0 -usecache 1 -width [expr {$hcolwidth+2}] -type [dict get $ftypes header]\ -ansibase $ansibase_header -ansiborder $ansiborder_final\ - -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ + -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ ] - set spanned_parts [list $header_cell_startspan] if {$this_span ne "1"} { - #more parts to append + #puts "===>\n$header_cell_startspan\n<===" + set spanned_parts [list $header_cell_startspan] + #assert this_span == "all" or >1 ie a header that spans other columns + #therefore more parts to append #set remaining_cols [lrange [dict keys $o_columndefs] $cidx end] set remaining_spans [lrange $headerspans $cidx+1 end] #puts ">> remaining_spans: $remaining_spans" set spancol [expr {$cidx + 1}] set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow @@ -1384,6 +1830,8 @@ namespace eval textblock { set next_posn inner } + set next_headerseps_v [dict get $sep_elements_vertical top$next_posn] ;#static top ok + set limj [my Get_boxlimits_and_joins $next_posn $fname_body] set span_joins_body [dict get $limj bodyjoins] set span_joins [dict get $limj joins] @@ -1394,7 +1842,7 @@ namespace eval textblock { #set span_boxlimits_top [struct::set intersect [dict get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] set header_span_boxlimits [struct::set intersect [dict get $o_opts_table_effective -framelimits_header] $span_boxlimits] set header_span_boxlimits_top [struct::set intersect [dict get $o_opts_table_effective -framelimits_header] $span_boxlimits_top] - if {$h == 0} { + if {$hrow == 0} { set hlims $header_span_boxlimits_top } else { set hlims $header_span_boxlimits @@ -1402,22 +1850,22 @@ namespace eval textblock { set this_span_map $span_extend_map if {!$show_seps_v} { - set hlims [struct::set difference $hlims $headerseps_v] + set hlims [struct::set difference $hlims $next_headerseps_v] } else { if {[llength $next_spanlist]} { set spanbelow [lindex $next_spanlist $spancol] if {$spanbelow != 0} { - set downbox [textblock::framedef $ftype_header {down}] + set downbox [textblock::framedef $ftype_header -joins {down}] dict set this_span_map blc [dict get $downbox hlbj] ;#horizontal line bottom with down join - to same frametype } } else { #join to body - set downbox [textblock::framedef $ftype_header [list down-$fname_body]] + set downbox [textblock::framedef $ftype_header -joins [list down-$fname_body]] dict set this_span_map blc [dict get $downbox hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype } } - if {$h == $hmax} { + if {$hrow == $hmax} { set header_joins $span_joins_body } else { set header_joins $span_joins @@ -1426,31 +1874,8 @@ namespace eval textblock { set hlims [struct::set difference $hlims [dict get $::textblock::class::header_edge_parts $rowpos$next_posn] ] } - if {![dict exists $column_width_cache $spancol]} { - #puts "-----> get_column_by_index $spancol -position $next_posn" - set spancolinfo [my get_column_by_index $spancol -position $next_posn -return dict] - set bwidth [dict get $spancolinfo bodywidth] - set hwidth [dict get $spancolinfo headerwidth] - dict set column_width_cache $spancol bodywidth $bwidth - dict set column_width_cache $spancol headerwidth $hwidth - } else { - set bwidth [dict get $column_width_cache $spancol bodywidth] - } - - if {$next_posn eq "right"} { - #This is an unintuitive edge case - review - #spans at tail end are too long when edges are shown if we use bwidth+1 (vlr extends right beyond table) - #spans at tail end are too short if edges are hidden and we use bwidth (short lower horizontal bar) - if {![dict get $o_opts_table -show_edge]} { - set spanwidth [expr {$bwidth+1}] - } else { - set spanwidth $bwidth - } - } else { - set spanwidth [expr {$bwidth+1}] - } - - set header_cell [textblock::frame -width $spanwidth -type [dict get $ftypes header]\ + set contentwidth [my column_width $spancol] + set header_cell [textblock::frame -ellipsis 0 -width [expr {$contentwidth + 2}] -type [dict get $ftypes header]\ -ansibase $ansibase_header -ansiborder $ansiborder_final\ -boxlimits $hlims -boxmap $this_span_map -joins $header_joins $hcell_blank\ ] @@ -1461,10 +1886,10 @@ namespace eval textblock { incr spancol incr i } - } - set spanned_frame [textblock::join {*}$spanned_parts] - if {$this_span eq "all" || $this_span > 1} { - if {$h == 0} { + + set spanned_frame [textblock::join {*}$spanned_parts] + + if {$hrow == 0} { set hlims $header_boxlimits_toprow } else { set hlims $header_boxlimits @@ -1476,62 +1901,71 @@ namespace eval textblock { #use the edge_parts corresponding to the column being written to ie use opt_posn set hlims [struct::set difference $hlims [dict get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] } - set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] - #set spacemap [list hl "\uFFFF" vl "\uFFFF" tlc "\uFFFF" blc "\uFFFF" trc "\uFFFF " brc "\uFFFF"] ;# a debug test - set hblock [textblock::frame -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] - set spanned_frame [overtype::left -experimental test_mode -transparent 1 $spanned_frame $hblock] + + set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements + #set spacemap [list hl * vl * tlc * blc * trc * brc *] + #-usecache 1 ok + #hval is not raw headerval - it has been padded to required width and has ansi applied + set hblock [textblock::frame -ellipsis 0 -type $spacemap -boxlimits $hlims -ansibase $ansibase_header $hval] ;#review -ansibase + #puts "==>boxlimits:'$hlims' hval_width:[string length $hval] blockwidth:[textblock::width $hblock]" + #puts $hblock + #puts "==>hval:'$hval'[a]" + #puts "==>hval:'[ansistring VIEW $hval]'" + #set spanned_frame [overtype::renderspace -experimental test_mode -transparent 1 $spanned_frame $hblock] + + #spanned values default left - todo make configurable + set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] + + } else { + #this_span == 1 + set spanned_frame [textblock::join $header_cell_startspan] } append part_header $spanned_frame append part_header \n } else { - #zero span header - - #JMN - if 0 { - #old version - sort of works - set h_lines [lrepeat $rowh ""] - set hcell_blank [join $h_lines \n] - set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] - set spacemap [list hl "\uFFFF" vl "\uFFFF" tlc "\uFFFF" blc "\uFFFF" trc "\uFFFF " brc "\uFFFF"] ;# a debug test - set header_frame [textblock::frame -width 0 -type [dict get $ftypes header]\ - -ansibase $ansibase_header \ - -boxlimits $hlims -boxmap $spacemap $hcell_blank\ - ] - append part_header $header_frame\n - } else { - #test version - set hw1 [dict get $o_columnstates $cidx maxwidthheaderseen] ;#headers may be masked by spans, or empty - width may depend more on spans than headers in current column - set hw2 [textblock::width $part_header] ;#widest so far - set hw3 [expr {max($hw1,$hw2)}] - set bw [dict get $o_columnstates $cidx maxwidthbodyseen] - set padwidth [expr {max($hw3,$bw)}] - if {[dict exists $column_width_cache $cidx]} { - set hwidth [dict get $column_width_cache $cidx headerwidth] - set padwidth [expr {max($padwidth,$hwidth)}] - } + #zero span header directly in this column ie one that is being colspanned by some column to our left + #previous col will already have built lines for this in it's own header rhs overhang + #we need a block of TSUB chars of the right height and width in this column so that we can join this column to the left ones with the TSUBs being transparent. + + #set padwidth [my column_datawidth $cidx -headers 0 -data 1 -cached 1] - #test hack - wider helps stop the breaks - but leaves junk spaces and ansiresets beyond the rhs border of table - #print function overflow 0 fixes? - set padwidth 20 + #if there are no header elements above then we will need a minimum of the column width + #may be extended to the widest portion of the header in the loop below + set padwidth [my column_width $cidx] - #set bline [string repeat \uFFFF $colwidth] - set bline [string repeat \uFFFF $padwidth] + #under assumption we are building table using L frame method and that horizontal borders are only ever 1 high + # - we can avoid using a frame - but we potentially need to manually adjust for show_hpos show_edge etc + #avoiding frame here is faster.. but not by much (<10%? on textblock::spantest2 ) + if 0 { + #breaks -show_edge 0 + if {$rowpos eq "top" && [dict get $o_opts_table -show_edge]} { + set padheight [expr {$rowh + 2}] + } else { + set padheight [expr {$rowh + 1}] + } + set bline [string repeat $TSUB [expr {$padwidth +1}]] + set h_lines [lrepeat $padheight $bline] + set hcell_blank [::join $h_lines \n] + set header_frame $hcell_blank + } else { + set bline [string repeat $TSUB $padwidth] set h_lines [lrepeat $rowh $bline] set hcell_blank [::join $h_lines \n] - set spacemap [list hl "\uFFFF" vll "\uFFFF" vlr "\uFFFF" tlc "\uFFFF" blc "\uFFFF" trc "\uFFFF " brc "\uFFFF"] ;# a debug test - set header_frame [textblock::frame -width [expr {$padwidth+2}] -type [dict get $ftypes header]\ - -ansibase $ansibase_header \ - -boxlimits $hlims -boxmap $spacemap $hcell_blank\ + # -usecache 1 ok + #frame borders will never display - so use the simplest frametype and don't apply any ansi + #puts "===>zerospan hlims: $hlims" + set header_frame [textblock::frame -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ + -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ ] - append part_header $header_frame\n + } + append part_header $header_frame\n - } } - incr h + incr hrow } if {![llength $header_list]} { #no headers - but we've been asked to show_header @@ -1544,15 +1978,27 @@ namespace eval textblock { set hlims [struct::set difference $hlims [dict get $::textblock::class::header_edge_parts only$opt_posn] ] } set header_joins $header_body_joins - set header_frame [textblock::frame -width [expr {$colwidth+2}] -type [dict get $ftypes header]\ + set header_frame [textblock::frame -width [expr {$hcolwidth+2}] -type [dict get $ftypes header]\ -ansibase $ansibase_header -ansiborder $ansiborder_final\ -boxlimits $hlims -boxmap $hdrmap -joins $header_joins\ ] append part_header $header_frame\n } + set part_header [string trimright $part_header \n] lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + + set padline [string repeat $TSUB $return_headerwidth] + set adjusted_lines [list] + foreach ln [split $part_header \n] { + if {[string first $TSUB $ln] >=0} { + lappend adjusted_lines $padline + } else { + lappend adjusted_lines $ln + } + } + set part_header [join $adjusted_lines \n] + append output $part_header \n } - append output $part_header set r 0 set rmax [expr {[llength $cells]-1}] @@ -1581,10 +2027,10 @@ namespace eval textblock { set colidx [lindex [dict keys $o_columndefs] $index_expression] ;#convert possible end-1,2+2 etc expression to >= 0 integer in dict range set opt_col_ansibase [dict get $o_columndefs $colidx -ansibase] ;#ordinary merge of codes already done in configure_column + #set colwidth [my column_width $colidx] set body_ansibase [dict get $o_opts_table -ansibase_body] #set ansibase [punk::ansi::codetype::sgr_merge_singles [list $body_ansibase $opt_col_ansibase]] ;#allow col to override body - set ansibase $body_ansibase$opt_col_ansibase set body_ansiborder [dict get $o_opts_table -ansiborder_body] if {[dict get $o_opts_table -frametype] eq "block"} { #block is the only style where bg colour can fill the frame content area exactly if the L-shaped border elements are styled @@ -1595,44 +2041,63 @@ namespace eval textblock { set border_ansi $body_ansibase$body_ansiborder } set r 0 + set ftblock [expr {[dict get $o_opts_table -frametype] eq "block"}] foreach c $cells { + set ansibase $body_ansibase$opt_col_ansibase set row_ansibase [dict get $o_rowdefs $r -ansibase] #todo - joinleft,joinright,joindown based on opts in args #append output [textblock::frame -boxlimits {vll blc hlb} $c]\n - if {[dict get $o_opts_table -frametype] eq "block"} { - set row_ansibase [dict get $o_rowdefs $r -ansibase] - set row_bg "" - if {$row_ansibase ne ""} { - set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] - } - set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row - if 1 { - #$c will always have ansi resets due to overtype::left behaviour - #todo - review overtype - if {[punk::ansi::ta::detect $c]} { - #use only the last ansi sequence in the cell value - #Filter out foreground and use background for ansiborder override - set parts [punk::ansi::ta::split_codes_single $c] - #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt - set codes [list] - foreach {pt cd} $parts { - lappend codes $cd - } - #set takebg [lindex $parts end-1] - #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] - set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1] + set cell_ansibase "" - #puts "-->>> [ansistring VIEW $cell_bg] <<<--" + set row_bg "" + if {$row_ansibase ne ""} { + set row_bg [punk::ansi::codetype::sgr_merge_singles [list $row_ansibase] -filter_fg 1] + } + set ansiborder_body_col_row $border_ansi$row_bg + set ansiborder_final $ansiborder_body_col_row + #$c will always have ansi resets due to overtype behaviour ? + #todo - review overtype + if {[punk::ansi::ta::detect $c]} { + #use only the last ansi sequence in the cell value + #Filter out foreground and use background for ansiborder override + set parts [punk::ansi::ta::split_codes_single $c] + #we have detected ansi - so there will always be at least 3 parts beginning and ending with pt pt,ansi,pt,ansi...,pt + set codes [list] + foreach {pt cd} $parts { + if {$cd ne ""} { + lappend codes $cd + } + } + #set takebg [lindex $parts end-1] + #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] + set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] + #puts --->[ansistring VIEW $codes] + + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { + #special case double reset at end of content + set cell_ansi_tail [punk::ansi::codetype::sgr_merge_singles $codes] ;#no filters + set ansibase "" + set row_ansibase "" + if {$ftblock} { + set ansiborder_final [punk::ansi::codetype::sgr_merge [list $ansiborder_body_col_row] -filter_bg 1] + } + set cell_ansibase $cell_ansi_tail + } else { + #single trailing reset in content + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + } + } else { + if {$ftblock} { + #no resets - use cell's bg to extend to the border - only for block frames set ansiborder_final $ansiborder_body_col_row$cell_bg - #JMN } + set cell_ansibase $cell_bg } - } else { - set ansiborder_body_col_row $border_ansi - set ansiborder_final $ansiborder_body_col_row } - set ansibase_final $ansibase$row_ansibase + + + set ansibase_final $ansibase$row_ansibase$cell_ansibase if {$r == 0} { if {$r == $rmax} { @@ -1657,7 +2122,7 @@ namespace eval textblock { set blims [struct::set difference $blims [dict get $::textblock::class::table_edge_parts top$opt_posn] ] } } - set rowframe [textblock::frame -type [dict get $ftypes body] -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] + set rowframe [textblock::frame -type [dict get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c] set return_bodywidth [textblock::width $rowframe] append part_body $rowframe \n } else { @@ -1675,7 +2140,7 @@ namespace eval textblock { set blims [struct::set difference $blims [dict get $::textblock::class::table_edge_parts middle$opt_posn] ] } } - append part_body [textblock::frame -type [dict get $ftypes body] -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n + append part_body [textblock::frame -type [dict get $ftypes body] -width [expr {$colwidth+2}] -blockalign $col_blockalign -ansibase $ansibase_final -ansiborder $ansiborder_final -boxlimits $blims -boxmap $bmap -joins $joins $c]\n } incr r } @@ -1683,7 +2148,6 @@ namespace eval textblock { if {![llength $cells]} { set joins [lremove $joins [lsearch $joins down*]] #we need to know the width of the column to setup the empty cell properly - #(we didn't need it above because get_column_cells_by_index returned values of the correct width) #even if no header displayed - we should take account of any defined column widths set colwidth [my column_width $index_expression] @@ -1738,11 +2202,18 @@ namespace eval textblock { #assert cidx is integer >=0 set cdef [dict get $o_columndefs $cidx] set headerlist [dict get $cdef -headers] - set num_headers [my header_count] + set num_header_rows [my header_count] - set RST [punk::ansi::a] set ansibase_body [dict get $o_opts_table -ansibase_body] set ansibase_col [dict get $cdef -ansibase] + set textalign [dict get $cdef -textalign] + switch -- $textalign { + left {set pad right} + right {set pad left} + default { + set pad "centre" ;#todo? + } + } set ansibase_header [dict get $o_opts_table -ansibase_header] @@ -1754,64 +2225,52 @@ namespace eval textblock { #store configured widths so we don't look up for each header line set configured_widths [list] foreach c [dict keys $o_columndefs] { + #lappend configured_widths [my column_width $c] + #we don't just want the width of the column in the body - or the headers will get truncated lappend configured_widths [my column_width_configured $c] } set output [dict create] dict set output headers [list] - for {set i 0} {$i < $num_headers} {incr i} { - set hdr [lindex $headerlist $i] - set header_maxdataheight [my header_height $i] ;#from cached headerstates - set header_colspans [dict get $all_colspans $i] - set this_span [lindex $header_colspans $cidx] - set hdrwidth 0 - if {$this_span eq "0"} { - set hdrwidth 0 - } elseif {$this_span eq "all"} { - #all means up to next non-zero - set s "0" - set idx $cidx - while {$s eq "0" && $idx < [llength $header_colspans]} { - incr hdrwidth [lindex $configured_widths $idx] - incr idx - set s [lindex $header_colspans $idx] - } - } else { - set spanned_cols [list] - for {set sc $cidx} {$sc < ($cidx + $this_span)} {incr sc} { - lappend spanned_cols $sc - } - #spanned_cols here includes self - foreach c $spanned_cols { - incr hdrwidth [lindex $configured_widths $c] - } - } - set hdr_line_blank [string repeat " " $hdrwidth] - set header_underlay [lrepeat $header_maxdataheight $hdr_line_blank] - set header_underlay $ansibase_header[join $header_underlay \n] - if {$hdr ne ""} { - dict lappend output headers [overtype::left -experimental test_mode $header_underlay $ansibase_header$hdr] - } else { - dict lappend output headers $header_underlay - } + set showing_vseps [my Showing_vseps] + for {set hrow 0} {$hrow < $num_header_rows} {incr hrow} { + set hdr [lindex $headerlist $hrow] + set header_maxdataheight [my header_height $hrow] ;#from cached headerstates + set headerrow_colspans [dict get $all_colspans $hrow] + set this_span [lindex $headerrow_colspans $cidx] + + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span] ;#widest of headers in this col with same span - allows textalign to work with blockalign + + set hcell_line_blank [string repeat " " $this_hdrwidth] + set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] + set hval_lines [split $hdr \n] + set hval_lines [concat $hval_lines $hcell_lines] + set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top + set hval_block [::join $hval_lines \n] + set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] + dict lappend output headers $hcell } - set colwidth [my column_width $cidx] - set cell_line_blank [string repeat " " $colwidth] + #set colwidth [my column_width $cidx] + #set cell_line_blank [string repeat " " $colwidth] + set datawidth [my column_datawidth $cidx -headers 0 -footers 0 -data 1 -cached 1] + set cell_line_blank [string repeat " " $datawidth] + set items [dict get $o_columndata $cidx] #puts "---> columndata $o_columndata" + #set opt_row_ansibase [dict get $o_rowdefs $r -ansibase] + #set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase + dict set output cells [list];#ensure we return something for cells key if no items in list set r 0 foreach cval $items { - set opt_row_ansibase [dict get $o_rowdefs $r -ansibase] - set cell_ansibase $ansibase_body$ansibase_col$opt_row_ansibase - - #todo move to row_height method + #todo move to row_height method ? set maxdataheight [dict get $o_rowstates $r -maxheight] set rowdefminh [dict get $o_rowdefs $r -minheight] set rowdefmaxh [dict get $o_rowdefs $r -maxheight] @@ -1838,22 +2297,18 @@ namespace eval textblock { } } } - #set cval $cell_ansibase$cval ;#no reset set cell_lines [lrepeat $rowh $cell_line_blank] - set cell_blank [join $cell_lines \n] + #set cell_blank [join $cell_lines \n] set cval_lines [split $cval \n] set cval_lines [concat $cval_lines $cell_lines] set cval_lines [lrange $cval_lines 0 $rowh-1] - set cval_block [join $cval_lines \n] + set cval_block [::join $cval_lines \n] - #TODO! fix overtype library - #set cell [overtype::left -experimental test_mode $cell_ansibase$cell_blank$RST $cval_block] - #set cell [overtype::left -experimental test_mode $cell_blank $cval_block] - set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which right] + set cell [textblock::pad $cval_block -width $datawidth -padchar " " -within_ansi 1 -which $pad] #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] dict lappend output cells $cell @@ -1868,10 +2323,103 @@ namespace eval textblock { } return [dict get $o_columndata $cidx] } - method debug {} { + method debug {args} { + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) + set defaults [dict create\ + -usetables 1\ + ] + dict for {k v} $args { + switch -- $k { + -usetables {} + default { + error "table debug unrecognised option '$k'. Known options: [dict keys $defaults]" + } + } + } + set opts [dict merge $defaults $args] + set opt_usetables [dict get $opts -usetables] + puts stdout "rowdefs: $o_rowdefs" puts stdout "rowstates: $o_rowstates" - puts stdout "columndefs: $o_columndefs" + #puts stdout "columndefs: $o_columndefs" + puts stdout "columndefs:" + if {!$opt_usetables} { + dict for {k v} $o_columndefs { + puts " $k $v" + } + } else { + set t [textblock::class::table new] + $t add_column -headers "Col" + dict for {col coldef} $o_columndefs { + foreach property [dict keys $coldef] { + if {$property eq "-ansireset"} { + continue + } + $t add_column -headers $property + } + break + } + + #build our inner tables first so we can sync widths + set col_header_tables [dict create] + set max_widths [dict create 0 0 1 0 2 0 3 0] ;#max inner table column widths + dict for {col coldef} $o_columndefs { + set row [list $col] + set colheaders [dict get $coldef -headers] + #inner table probably overkill here ..but just as easy + set htable [textblock::class::table new] + $htable configure -show_header 1 -show_edge 0 -show_hseps 0 + $htable add_column -headers row + $htable add_column -headers text + $htable add_column -headers WxH + $htable add_column -headers span + set hnum 0 + set spans [dict get $o_columndefs $col -header_colspans] + foreach h $colheaders s $spans { + lassign [textblock::size $h] _w width _h height + $htable add_row [list "$hnum " $h "${width}x${height}" $s] + incr hnum + } + $htable configure_column 0 -ansibase [a+ web-dimgray] + dict set col_header_tables $col $htable + set colwidths [$htable column_widths] + set icol 0 + foreach w $colwidths { + if {$w > [dict get $max_widths $icol]} { + dict set max_widths $icol $w + } + incr icol + } + } + + dict for {col coldef} $o_columndefs { + set row [list $col] + dict for {property val} $coldef { + switch -- $property { + -ansireset {continue} + -headers { + set htable [dict get $col_header_tables $col] + dict for {innercol maxw} $max_widths { + $htable configure_column $innercol -minwidth $maxw -blockalign left + } + lappend row [$htable print] + $htable destroy + } + default { + lappend row $val + } + } + } + $t add_row $row + } + + + + + $t configure -show_header 1 + puts stdout [$t print] + $t destroy + } puts stdout "columnstates: $o_columnstates" puts stdout "headerstates: $o_headerstates" dict for {k coldef} $o_columndefs { @@ -1885,12 +2433,26 @@ namespace eval textblock { } else { set widest 0 } - append colinfo " widest: $widest" + append colinfo " widest of headers and data: $widest" } else { set colinfo "WARNING - no columndata record for column key '$k'" } puts stdout "column $k columndata info: $colinfo" } + set result "" + set cols [list] + set max [expr {[dict size $o_columndefs]-1}] + foreach c [dict keys $o_columndefs] { + if {$c == 0} { + lappend cols [my get_column_by_index $c -position left] " " + } elseif {$c == $max} { + lappend cols [my get_column_by_index $c -position right] + } else { + lappend cols [my get_column_by_index $c -position inner] " " + } + } + append result [textblock::join {*}$cols] + return $result } #column width including headers - but without colspan consideration method column_width_configured {index_expression} { @@ -1908,6 +2470,8 @@ namespace eval textblock { } else { #set widest [my column_datawidth $cidx -headers 1 -data 1 -footers 1] set hwidest [dict get $o_columnstates $cidx maxwidthheaderseen] + #set hwidest [my column_datawidth $cidx -headers 1 -colspan 1 -data 0 -footers 1] + #set hwidest_singlespan ?? set bwidest [dict get $o_columnstates $cidx maxwidthbodyseen] set widest [expr {max($hwidest,$bwidest)}] #todo - predetermine if any items in column contain newlines and are truncated vertically due to o_rowdefs configuration. @@ -1937,8 +2501,38 @@ namespace eval textblock { return $colwidth } - #column *body* content width method column_width {index_expression} { + if {[llength $o_calculated_column_widths] != [dict size $o_columndefs]} { + my calculate_column_widths -algorithm $o_column_width_algorithm + } + return [lindex $o_calculated_column_widths $index_expression] + } + method column_widths {} { + if {[llength $o_calculated_column_widths] != [dict size $o_columndefs]} { + my calculate_column_widths -algorithm $o_column_width_algorithm + } + return $o_calculated_column_widths + } + + #width of a table includes borders and seps + #whereas width of a column refers to the borderless width (inner width) + method width {} { + #calculate width based on assumption frame verticals are 1-wide - review - what about custom unicode double-wide frame? + set colwidths [my column_widths] + set contentwidth [tcl::mathop::+ {*}$colwidths] + set twidth $contentwidth + if {[my Showing_vseps]} { + incr twidth [llength $colwidths] + incr twidth -1 + } + if {[dict get $o_opts_table -show_edge]} { + incr twidth 2 + } + return $twidth + } + + #column *body* content width + method basic_column_width {index_expression} { set cidx [lindex [dict keys $o_columndefs] $index_expression] if {$cidx eq ""} { return @@ -1950,6 +2544,7 @@ namespace eval textblock { set defmaxw [dict get $cdef -maxwidth] if {"$defminw$defmaxw" ne "" && $defminw eq $defmaxw} { #an exact width is defined for the column - no need to look at data width + #review - this can result in truncation of spanning headers - even though there is enough width in the span-cell to place the full header set colwidth $defminw } else { #set widest [my column_datawidth $cidx -headers 0 -data 1 -footers 0] @@ -2022,6 +2617,11 @@ namespace eval textblock { } set total_spanned_width [expr {$width_max + $others_width}] if {$thiscol_widest_header > $total_spanned_width} { + #this just allocates the extra space in the current column - which is not great. + #A proper algorithm for distributing width created by headers to all the spanned columns is needed. + #This is a tricky problem with multiple header lines and arbitrary spans. + #The calculation should probably be done on the table as a whole first and this function should just look up that result. + #Trying to calculate on a specific column only is unlikely to be easy or efficient. set needed [expr {$thiscol_widest_header - $total_spanned_width}] #puts "-->>col $cidx needed ($thiscol_widest_header - $total_spanned_width): $needed (spanned $spanned)" if {$defmaxw ne ""} { @@ -2068,22 +2668,65 @@ namespace eval textblock { set defaults [dict create\ -headers 0\ -footers 0\ + -colspan *\ -data 1\ + -cached 1\ ] + #-colspan is relevant to header/footer data only dict for {k v} $args { switch -- $k { - -headers - -footers - -data {} + -headers - -footers - -colspan - -data - -cached {} default { error "column_datawidth unrecognised flag '$k'. Known flags: [dict keys $defaults]" } } } set opts [dict merge $defaults $args] + set opt_colspan [dict get $opts -colspan] + set cidx [lindex [dict keys $o_columndefs] $index_expression] if {$cidx eq ""} { return } + + if {[dict get $opts -cached]} { + set hwidest 0 + set bwidest 0 + set fwidest 0 + if {[dict get $opts -headers]} { + if {$opt_colspan eq "*"} { + set hwidest [dict get $o_columnstates $cidx maxwidthheaderseen] + } else { + set colheaders [dict get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans] + set hlist [list] + dict for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + #todo - map 'all' entries to a number? + #we should build a version of header_colspans that does this + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + #set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {string length $v}]] + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + } + } + if {[dict get $opts -data]} { + set bwidest [dict get $o_columnstates $cidx maxwidthbodyseen] + } + if {[dict get $opts -footers]} { + #TODO! + #set bwidest [dict get $o_columnstates $cidx maxwidthfooterseen] + } + return [expr {max($hwidest,$bwidest,$fwidest)}] + } + #assert cidx is >=0 integer in valid range of keys for o_columndefs set values [list] if {[dict get $opts -headers]} { @@ -2154,7 +2797,282 @@ namespace eval textblock { return "No columns matched" } } + method columncalc_spans {allocmethod} { + set colwidths [dict create] ;# to use dict incr + set colspace_added [dict create] + + set ordered_spans [dict create] + dict for {col spandata} [my spangroups] { + set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] + set minwidth [dict get $o_columndefs $col -minwidth] + set maxwidth [dict get $o_columndefs $col -maxwidth] + if {$minwidth ne ""} { + if {$dwidth < $minwidth} { + set dwidth $minwidth + } + } + if {$maxwidth ne ""} { + if {$dwidth > $maxwidth} { + set dwidth $maxwidth + } + } + dict set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered + dict set colspace_added $col 0 + + set spanlengths [dict get $spandata spanlengths] + foreach slen $spanlengths { + set spans [dict get $spandata spangroups $slen] + set spans [lsort -index 7 -integer $spans] + foreach s $spans { + set hwidth [dict get $s headerwidth] + set hrow [dict get $s hrow] + set scol [dict get $s startcol] + dict set ordered_spans $scol,$hrow membercols $col $dwidth + dict set ordered_spans $scol,$hrow headerwidth $hwidth + } + } + } + + dict for {spanid spandata} $ordered_spans { + lassign [split $spanid ,] startcol hrow + set memcols [dict get $spandata membercols] ;#dict with col and initial width - we ignore initial width, it's there in case we want to allocate space based on initial data width ratios + set colids [dict keys $memcols] + set hwidth [dict get $spandata headerwidth] + set num_cols_spanned [dict size $memcols] + if {$num_cols_spanned == 1} { + set col [lindex $memcols 0] + set space_to_alloc [expr {$hwidth - [dict get $colwidths $col]}] + if {$space_to_alloc > 0} { + dict set colwidths $col $hwidth + dict set colspace_added $col $space_to_alloc + } + } elseif {$num_cols_spanned > 1} { + set spannedwidth 0 + foreach col $colids { + incr spannedwidth [dict get $colwidths $col] + } + set space_to_alloc [expr {$hwidth - $spannedwidth}] + if {[my Showing_vseps]} { + set sepcount [expr {$num_cols_spanned -1}] + incr space_to_alloc -$sepcount + } + #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added + switch -- $allocmethod { + 0 { + #add to least-expanded each time + #safer than method 1 - pretty balanced + if {$space_to_alloc > 0} { + for {set i 0} {$i < $space_to_alloc} {incr i} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_all_colids [dict keys $ordered_colspace_added] + foreach testcolid $ordered_all_colids { + if {$testcolid in $colids} { + #assert - we will always find a match + set colid $testcolid + break + } + } + dict incr colwidths $colid + dict incr colspace_added $colid + } + } + } + 1 { + #adds space to all columns - not just those spanned - risk of underallocating and truncating some headers! + #probably not a good idea for tables with complex headers and spans + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [dict keys $ordered_colspace_added] + + foreach col $ordered_colids { + dict incr colwidths $col + dict incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + + } + } + } + } + + set column_widths [dict values $colwidths] + #todo - -maxwidth etc + set table_minwidth [dict get $o_opts_table -minwidth] ;#min width including frame elements + if {[string is integer -strict $table_minwidth]} { + set contentwidth [tcl::mathop::+ {*}$column_widths] + set twidth $contentwidth + if {[my Showing_vseps]} { + incr twidth [llength $column_widths] + incr twidth -1 + } + if {[dict get $o_opts_table -show_edge]} { + incr twidth 2 + } + # + set shortfall [expr {$table_minwidth - $twidth}] + if {$shortfall > 0} { + set space_to_alloc $shortfall + while {$space_to_alloc > 0} { + set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] + set ordered_colids [dict keys $ordered_colspace_added] + + foreach col $ordered_colids { + dict incr colwidths $col + dict incr colspace_added $col + incr space_to_alloc -1 + if {$space_to_alloc == 0} { + break + } + } + } + set column_widths [dict values $colwidths] + } + + } + + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + } + + #spangroups keyed by column + method spangroups {} { + set column_count [dict size $o_columndefs] + set spangroups [dict create] + set headerwidths [dict create] ;#key on col,hrow + foreach c [dict keys $o_columndefs] { + dict set spangroups $c [list spanlengths {}] + set spanlist [my column_get_spaninfo $c] + set index_spanlen_val 5 + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist + + while {[llength $ungrouped]} { + set spanlen [lindex $ungrouped 0 $index_spanlen_val] + set spangroup_posns [lsearch -all -index $index_spanlen_val $ungrouped $spanlen] + set sgroup [list] + foreach p $spangroup_posns { + set spaninfo [lindex $ungrouped $p] + set hcol [dict get $spaninfo startcol] + set hrow [dict get $spaninfo hrow] + set header [lindex [dict get $o_columndefs $hcol -headers] $hrow] + if {[dict exists $headerwidths $hcol,$hrow]} { + set hwidth [dict get $headerwidths $hcol,$hrow] + } else { + set hwidth [textblock::width $header] + dict set headerwidths $hcol,$hrow $hwidth + } + lappend spaninfo headerwidth $hwidth + lappend sgroup $spaninfo + } + set spanlengths [dict get $spangroups $c spanlengths] + lappend spanlengths $spanlen + dict set spangroups $c spanlengths $spanlengths + dict set spangroups $c spangroups $spanlen $sgroup + set ungrouped [lremove $ungrouped {*}$spangroup_posns] + } + } + return $spangroups + } + method column_get_own_spans {cidx} { + set colspans_for_column [dict get $o_columndefs $cidx -header_colspans] + } + method column_get_spaninfo {cidx} { + set spans_by_header [my header_colspans] + set colspans_for_column [dict get $o_columndefs $cidx -header_colspans] + set spaninfo [list] + set numcols [dict size $o_columndefs] + #note that 'all' can occur in positions other than column 0 - meaning all remaining + dict for {hrow rawspans} $spans_by_header { + set thiscol_spanval [lindex $rawspans $cidx] + if {$thiscol_spanval eq "all" || $thiscol_spanval > 0} { + set spanstartcol $cidx ;#own column + if {$thiscol_spanval eq "all"} { + set spanlen [expr {$numcols - $cidx}] + } else { + set spanlen $thiscol_spanval + } + } else { + #look left til we see an all or a non-zero value + for {set i $cidx} {$i > -1} {incr i -1} { + set s [lindex $rawspans $i] + if {$s eq "all" || $s > 0} { + set spanstartcol $i + if {$s eq "all"} { + set spanlen [expr {$numcols - $i}] + } else { + set spanlen $s + } + break + } + } + } + #assert - we should always find 1 answer for each header row + lappend spaninfo [list hrow $hrow startcol $spanstartcol spanlen $spanlen] + } + return $spaninfo + } + method calculate_column_widths {args} { + set column_count [dict size $o_columndefs] + + set defaults [dict create\ + -algorithm $o_column_width_algorithm\ + ] + dict for {k v} $args { + switch -- $k { + -algorithm {} + default { + error "Unknown option '$k'. Known options: [dict keys $defaults]" + } + } + } + set opts [dict merge $defaults $args] + set opt_algorithm [dict get $opts -algorithm] + #puts stderr "--- recalculating column widths -algorithm $opt_algorithm" + set known_algorithms [list basic simplistic span] + switch -- $opt_algorithm { + basic { + #basic column by column - This allocates extra space to first span/column as they're encountered. + #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans + #The header values can extend over some of the spanned columns - but not optimally so. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my basic_column_width $c] + } + } + simplistic { + #just uses the widest column data or header element. + #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column + #This is a conservative option potentially useful in testing/debugging. + set o_calculated_column_widths [list] + for {set c 0} {$c < $column_count} {incr c} { + lappend o_calculated_column_widths [my column_width_configured $c] + } + } + span { + #widest of smallest spans first method + set calcresult [my columncalc_spans 0] + set o_calculated_column_widths [dict get $calcresult colwidths] + } + span2 { + #allocates more evenly - but truncates headers sometimes + set calcresult [my columncalc_spans 1] + set o_calculated_column_widths [dict get $calcresult colwidths] + } + default { + error "calculate_column_widths unknown algorithm $opt_algorithm" + } + } + #remember the last algorithm used + set o_column_width_algorithm $opt_algorithm + return $o_calculated_column_widths + } method print {args} { + variable full_column_cache + set full_column_cache [dict create] + if {![llength $args]} { set cols [dict keys $o_columndata] } else { @@ -2197,7 +3115,14 @@ namespace eval textblock { set flags [list -position inner] } #lappend blocks [my get_column_by_index $c {*}$flags] - set columninfo [my get_column_by_index $c -return dict {*}$flags] + #todo - only check and store in cache if table has header or footer colspans > 1 + if {[dict exists $full_column_cache $c]} { + #puts "!!print used full_column_cache for $c" + set columninfo [dict get $full_column_cache $c] + } else { + set columninfo [my get_column_by_index $c -return dict {*}$flags] + dict set full_column_cache $c $columninfo + } set nextcol [dict get $columninfo column] set bodywidth [dict get $columninfo bodywidth] @@ -2205,12 +3130,12 @@ namespace eval textblock { set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { - set nextcol [textblock::join [textblock::block $padwidth $height "\uFFFF"] $nextcol] - set table [overtype::left -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] + set nextcol [textblock::join [textblock::block $padwidth $height $TSUB] $nextcol] + set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] #JMN #set nextcol [textblock::join [textblock::block $padwidth $height "\uFFFF"] $nextcol] - #set table [overtype::left -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] + #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] } incr padwidth $bodywidth incr colposn @@ -2218,6 +3143,42 @@ namespace eval textblock { if {[llength $cols]} { #return [textblock::join {*}$blocks] + if {[dict get $o_opts_table -show_edge]} { + #title is considered part of the edge ? + set offset 1 ;#make configurable? + set titlepad [string repeat $TSUB $offset] + if {[dict get $o_opts_table -title] ne ""} { + set titlealign [dict get $o_opts_table -titlealign] + switch -- $titlealign { + left { + set tstring $titlepad[dict get $o_opts_table -title] + } + right { + set tstring [dict get $o_opts_table -title]$titlepad + } + default { + set tstring [dict get $o_opts_table -title] + } + } + set opt_titletransparent [dict get $o_opts_table -titletransparent] + switch -- $opt_titletransparent { + 0 { + set mapchar "" + } + 1 { + set mapchar " " + } + default { + #won't work if not a single char - review - check also frame behaviour + set mapchar $opt_titletransparent + } + } + if {$mapchar ne ""} { + set tstring [string map [list $mapchar $TSUB] $tstring] + } + set table [overtype::block -blockalign $titlealign -transparent $TSUB $table[unset table] $tstring] + } + } return $table } else { return "No columns matched" @@ -2253,11 +3214,39 @@ namespace eval textblock { set t [list_as_table 5 {a b c d e aa bb cc dd ee X Y} -return object] $t configure_column 0 -headers {span3 span4 span5/5 "span-all etc blah 123 hmmmmm" span2} $t configure_column 0 -header_colspans {3 4 5 all 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + + #more complex colspans + proc spantest2 {} { + set t [list_as_table 5 {a b c d e aa bb cc dd ee X Y} -return object] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} + $t configure_column 0 -header_colspans {3 4 1 all 2} + $t configure_column 1 -header_colspans {0 0 2 0 0} $t configure_column 2 -headers {"" "" "" "" c2span2} $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 2 0 0} $t configure -show_header 1 -ansiborder_header [a+ cyan] return $t } + proc spantest3 {} { + set t [list_as_table 5 {a b c d e aa bb cc dd ee X Y} -return object] + $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} + $t configure_column 0 -header_colspans {3 4 1 all 2 1} + $t configure_column 1 -header_colspans {0 0 4 0 0 1} + $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} + $t configure_column 2 -headers {"" "" "" "" "" c2span2} + $t configure_column 2 -header_colspans {0 0 0 0 1 2} + $t configure_column 4 -headers {"4" "444" "" "" "" "44"} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + return $t + } + + + proc periodic {args} { #For an impressive interactive terminal app (javascript) # see: https://github.com/spirometaxas/periodic-table-cli @@ -2265,10 +3254,11 @@ namespace eval textblock { set defaults [dict create\ -return "string"\ -compact 1\ + -forcecolour 0\ ] dict for {k v} $args { switch -- $k { - -return - -compact {} + -return - -compact - -forcecolour {} default { "textblock::periodic unknown option '$k'. Known options: [dict keys $defaults]" } @@ -2276,6 +3266,11 @@ namespace eval textblock { } set opts [dict merge $defaults $args] set opt_return [dict get $opts -return] + if {[dict get $opts -forcecolour]} { + set fc forcecolour + } else { + set fc "" + } #examples ptable.com set elements [list\ @@ -2296,61 +3291,61 @@ namespace eval textblock { set ecat [dict create] set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ Web-gold web-black] + set ansi [a+ {*}$fc Web-gold web-black] foreach e $cat_alkaline_earth { dict set ecat $e [list ansi $ansi cat alkaline_earth] } set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - set ansi [a+ Web-lightgreen web-black] + set ansi [a+ {*}$fc Web-lightgreen web-black] foreach e $cat_reactive_nonmetal { dict set ecat $e [list ansi $ansi cat reactive_nonmetal] } set cat [list Li Na K Rb Cs Fr] - set ansi [a+ Web-Khaki web-black] + set ansi [a+ {*}$fc Web-Khaki web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat alkali_metals] } set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - set ansi [a+ Web-lightsalmon web-black] + set ansi [a+ {*}$fc Web-lightsalmon web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat transition_metals] } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ Web-lightskyblue web-black] + set ansi [a+ {*}$fc Web-lightskyblue web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat post_transition_metals] } set cat [list B Si Ge As Sb Te At] - set ansi [a+ Web-turquoise web-black] + set ansi [a+ {*}$fc Web-turquoise web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat metalloids] } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ Web-orchid web-black] + set ansi [a+ {*}$fc Web-orchid web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat noble_gases] } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ Web-plum web-black] + set ansi [a+ {*}$fc Web-plum web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat actinoids] } set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - set ansi [a+ Web-tan web-black] + set ansi [a+ {*}$fc Web-tan web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat lanthanoids] } set cat [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] - set ansi [a+ Web-whitesmoke web-black] + set ansi [a+ {*}$fc Web-whitesmoke web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat other] } @@ -2359,7 +3354,9 @@ namespace eval textblock { foreach e $elements { if {[dict exists $ecat $e]} { set ansi [dict get $ecat $e ansi] - lappend elements1 [textblock::pad $ansi$e -width 2 -which right] + #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] + #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway + lappend elements1 $ansi$e } else { lappend elements1 $e } @@ -2369,7 +3366,7 @@ namespace eval textblock { #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options - set header_0 [list "" 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] + set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] set c 0 foreach h $header_0 { $t configure_column $c -headers [list $h] -minwidth 2 @@ -2388,14 +3385,14 @@ namespace eval textblock { if {$opt_return eq "string"} { $t configure -frametype_header light - $t configure -ansiborder_header [a+ web-white] - $t configure -ansibase_header [a+ Web-black] - $t configure -ansibase_body [a+ Web-black] - $t configure -ansiborder_body [a+ web-black] + $t configure -ansiborder_header [a+ {*}$fc web-white] + $t configure -ansibase_header [a+ {*}$fc Web-black] + $t configure -ansibase_body [a+ {*}$fc Web-black] + $t configure -ansiborder_body [a+ {*}$fc web-black] $t configure -frametype block - set output [textblock::frame -ansiborder [a+ Web-black web-cornflowerblue] -type heavy -title "[a+ Web-black] Periodic Table " [$t print]] + set output [textblock::frame -ansiborder [a+ {*}$fc Web-black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Web-black] Periodic Table " [$t print]] return $output } return $t @@ -2543,12 +3540,29 @@ namespace eval textblock { lappend rainbow_list purple lappend rainbow_list cyan lappend rainbow_list {white Red} + + set rainbow_direction "horizontal" + set vpos [lsearch $colour vertical] + if {$vpos >= 0} { + set rainbow_direction vertical + set colour [lremove $colour $vpos] + } + set hpos [lsearch $colour horizontal] + if {$hpos >=0} { + #horizontal is the default and superfluous but allowed for symmetry + set colour [lremove $colour $hpos] + } + set chars [concat [punk::range 1 9] A B C D E F] set charsubset [lrange $chars 0 $size-1] - set RST [a] - if {"rainbow" in $colour} { + if {"noreset" in $colour} { + set RST "" + } else { + set RST [a] + } + if {"rainbow" in $colour && $rainbow_direction eq "vertical"} { #column first - colour change each column set c [::join $charsubset \n] @@ -2560,7 +3574,27 @@ namespace eval textblock { set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } - return [textblock::join {*}$clist] + if {"noreset" in $colour} { + return [textblock::join -ansiresets 0 {*}$clist] + } else { + return [textblock::join {*}$clist] + } + } elseif {"rainbow" in $colour} { + #direction must be horizontal + set block "" + for {set r 0} {$r < $size} {incr r} { + set colour2 [string map [list rainbow [lindex $rainbow_list $r]] $colour] + set ansi [a+ {*}$colour2] + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] + set row "$ansicode" + foreach c $charsubset { + append row $c + } + append row $RST + append block $row\n + } + set block [string trimright $block \n] + return $block } else { #row first - set rows [list] @@ -2599,6 +3633,19 @@ namespace eval textblock { } return [punk::char::ansifreestring_width $textblock] } + #when we know the block is uniform in width - just examine topline + proc widthtopline {textblock} { + set firstnl [string first \n $textblock] + if {$firstnl >= 0} { + set tl [string range $textblock 0 $firstnl] + } else { + set tl $textblock + } + if {[punk::ansi::ta::detect $tl]} { + set tl [punk::ansi::stripansi $tl] + } + return [punk::char::ansifreestring_width $tl] + } #uses tcl's string length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. proc string_length_line_max textblock { tcl::mathfunc::max {*}[lmap v [split $textblock \n] {string length $v}] @@ -2672,8 +3719,10 @@ namespace eval textblock { } return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [stripansi $v]}]] } - pipealias ::textblock::padleft .= {list $input [string repeat " " $indent]} |/0,padding/1> punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- punk:lib::lines_as_list -- |> .= {lmap v $data {overtype::right $padding $v}} |> punk::lib::list_as_lines -- punk::lib::lines_as_list -- |> .= {lmap v $data {overtype::left $padding $v}} |> punk::lib::list_as_lines -- } punk::lib::lines_as_list -- {| - data2 - >} .=lhs> punk::lib::lines_as_list -- {| - >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - data2 - >} .=lhs> punk::lib::lines_as_list -- {| - >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - >} punk::lib::list_as_lines -- } punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| + # >} punk::lib::list_as_lines -- } .=> punk::lib::lines_as_list -- {| - data2 - >} .=lhs> punk::lib::lines_as_list -- {| - >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - >} punk::lib::list_as_lines } .=> punk::lib::lines_as_list -- {| + # data2 + # >} .=lhs> punk::lib::lines_as_list -- {| + # >} .= {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 red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] + set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] + set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] + set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] set RST [a] set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] set punks [textblock::join $pleft $pright] @@ -3079,7 +4297,7 @@ namespace eval textblock { set spantable [[spantest] print] append out [textblock::join $fancy " " $spantable] \n #append out [textblock::frame -title gr $gr0] - append out [textblock::periodic] + append out [textblock::periodic -forcecolour $opt_forcecolour] return $out } @@ -3185,11 +4403,33 @@ namespace eval textblock { return [dict create category predefined type $f] } } - proc framedef {f {joins ""}} { + variable framedef_cache [dict create] + proc framedef {f args} { #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. #the arc set can't even join to itself e.g with curved equivalents of T-like shapes + variable framedef_cache + set cache_key [concat $f $args] + if {[dict exists $framedef_cache $cache_key]} { + return [dict get $framedef_cache $cache_key] + } + set defaults [dict create\ + -joins ""\ + -boxonly 0\ + ] + dict for {k v} $args { + switch -- $k { + -joins - -boxonly {} + default { + error "framedef unknown option '$k'. Known options [dict keys $args]" + } + } + } + set opts [dict merge $defaults $args] + set joins [dict get $opts -joins] + set boxonly [dict get $opts -boxonly] + #sorted order down left right up #1 x choose 4 @@ -4297,16 +5537,73 @@ namespace eval textblock { set vlrj $vlr } } - return [dict create\ - tlc $tlc hlt $hlt trc $trc\ - vll $vll vlr $vlr\ - blc $blc hlb $hlb brc $brc\ - hltj $hltj\ - hlbj $hlbj\ - vllj $vllj\ - vlrj $vlrj\ - ] + if {$boxonly} { + set result [dict create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + ] + dict set framedef_cache $cache_key $result + return $result + } else { + set result [dict create\ + tlc $tlc hlt $hlt trc $trc\ + vll $vll vlr $vlr\ + blc $blc hlb $hlb brc $brc\ + hltj $hltj\ + hlbj $hlbj\ + vllj $vllj\ + vlrj $vlrj\ + ] + dict set framedef_cache $cache_key $result + return $result + } + } + + variable frame_cache + set frame_cache [dict create] + proc frame_cache {{action ""}} { + if {$action ni [list clear ""]} { + error "frame_cache action '$action' not understood. Valid actions: clear" + } + variable frame_cache + set out "" + if {[catch { + set termwidth [dict get [punk::console::get_size] columns] + }]} { + set termwidth 80 + } + + dict for {k v} $frame_cache { + lassign $v _f frame _used used + #set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? + set fwidth [textblock::width $frame] + set frameinfo "$k used:$used " + set allinone_width [expr {[string length $frameinfo] + $fwidth}] + if {$allinone_width >= $termwidth} { + #split across 2 lines + append out "$frameinfo\n" + append out $frame \n + } else { + append out [textblock::join $frameinfo $frame]\n + } + append out \n ;# frames used to build tables often have joins - keep a line in between for clarity + } + if {$action eq "clear"} { + set frame_cache [dict create] + append out \nCLEARED + } + return $out } + #options before content argument - which is allowed to be absent + #frame performance (noticeable with complex tables even of modest size) is improved significantly by frame_cache - but is still (2024) a fairly expensive operation. + # + #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) + # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it + # - but we would need to maintain support for the rendered-string based operations too. proc frame {args} { variable frametypes set expect_optval 0 @@ -4354,13 +5651,18 @@ namespace eval textblock { -height ""\ -ansiborder ""\ -ansibase ""\ - -align "left"\ + -blockalign "centre"\ + -textalign "left"\ -ellipsis 1\ + -usecache 1\ + -buildcache 1\ ] + #todo -blockalignbias -textalignbias? + #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache set opts [dict merge $defaults $arglist] foreach {k v} $opts { switch -- $k { - -etabs - -type - -boxlimits - -boxmap - -joins - -title - -subtitle - -width - -height - -ansiborder - -ansibase - -align - -ellipsis {} + -etabs - -type - -boxlimits - -boxmap - -joins - -title - -subtitle - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -usecache - -buildcache {} default { error "frame option '$k' not understood. Valid options are [dict keys $defaults]" } @@ -4372,6 +5674,10 @@ namespace eval textblock { set opt_boxlimits [dict get $opts -boxlimits] set opt_joins [dict get $opts -joins] set opt_boxmap [dict get $opts -boxmap] + set opt_usecache [dict get $opts -usecache] + set opt_buildcache [dict get $opts -buildcache] + set usecache $opt_usecache ;#may need to override + set buildcache $opt_buildcache set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] set known_frametypes $frametypes ;# light, heavey etc as defined in textblock::frametypes variable @@ -4476,16 +5782,24 @@ namespace eval textblock { set opt_width [dict get $opts -width] set opt_height [dict get $opts -height] # -- --- --- --- --- --- - set opt_align [dict get $opts -align] - set opt_align [string tolower $opt_align] - switch -- $opt_align { + set opt_blockalign [dict get $opts -blockalign] + switch -- $opt_blockalign { left - right - centre - center {} default { - error "frame option -align must be left|right|centre|center - received: $$opt_align" + error "frame option -blockalign must be left|right|centre|center - received: $opt_blockalign" } } #these are all valid commands for overtype:: # -- --- --- --- --- --- + set opt_textalign [dict get $opts -textalign] + switch -- $opt_textalign { + left - right - centre - center {} + default { + error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" + } + } + # -- --- --- --- --- --- + set opt_ansiborder [dict get $opts -ansiborder] set opt_ansibase [dict get $opts -ansibase] ;#experimental set opt_ellipsis [dict get $opts -ellipsis] @@ -4503,7 +5817,7 @@ namespace eval textblock { } } set contents [string map [list \r\n \n] $contents] - set actual_contentwidth [textblock::width $contents] + set actual_contentwidth [textblock::width $contents] ;#length of longest line in contents (contents can be ragged) set actual_contentheight [textblock::height $contents] } else { set actual_contentwidth 0 @@ -4519,306 +5833,474 @@ namespace eval textblock { } if {$opt_width eq ""} { - set contentwidth $content_or_title_width + set frame_inner_width $content_or_title_width } else { - set contentwidth [expr {max(0,$opt_width - 2)}] ;#default + set frame_inner_width [expr {max(0,$opt_width - 2)}] ;#default } if {$opt_height eq ""} { - set contentheight $actual_contentheight + set frame_inner_height $actual_contentheight } else { - set contentheight [expr {max(0,$opt_height -2)}] ;#default + set frame_inner_height [expr {max(0,$opt_height -2)}] ;#default } - if {$contentheight == 0 && $contentwidth == 0} { + if {$frame_inner_height == 0 && $frame_inner_width == 0} { set has_contents 0 } - #todo - render it with vertical overflow so we can process ansi moves? #set linecount [textblock::height $contents] - set linecount $contentheight - set rst [a] - #set column [string repeat " " $contentwidth] ;#default - may need to override for custom frame - set underlayline [string repeat " " $contentwidth] - set underlay [::join [lrepeat $linecount $underlayline] \n] - - set vll_width 1 ;#default for all except custom (printing width) - set vlr_width 1 - - set framedef [textblock::framedef $framedef $opt_joins] - dict with framedef {} ;#extract vll,hlt,tlc etc vars - - #puts "---> $opt_boxmap" - dict for {boxelement sub} $opt_boxmap { - if {$boxelement eq "vl"} { - set vll $sub - set vlr $sub - set hl $sub - } elseif {$boxelement eq "hl"} { - set hlt $sub - set hlb $sub - set hl $sub + set linecount $frame_inner_height + + # -- --- --- --- --- --- --- --- --- + variable frame_cache + #review - custom frame affects frame_inner_width - exclude from caching? + #set cache_key [concat $arglist $frame_inner_width $frame_inner_height] + set hashables [concat $arglist $frame_inner_width $frame_inner_height] + package require md5 + set hash [md5::md5 -hex $hashables] + set cache_key "$hash-$frame_inner_width-$frame_inner_height-actualcontentwidth:$actual_contentwidth" + #should be in a unicode private range different to that used in table construction + #e.g BMP PUA U+E000 -> U+F8FF - although this is commonly used for example by nerdfonts + #also supplementary private use blocks + #however these display double wide on for example cmd terminal despite having wcswidth 1 (makes layout debugging difficult) + #U+F0000 -> U+FFFD + #U+100000 -> U+10FFFD + #FSUB options: \uf0ff \uF1FF \uf2ff (no nerdfont glyphs - should look like standard replacement char) \uF2DD (circular thingy) + #should be something someone is unlikely to use as part of a custom frame character. + #ideally a glyph that doesn't auto-expand into whitespace and is countable when in a string (narrower is better) + #As nerdfont glyphs tend to be mostly equal height & width - circular glyphs tend to be more distinguishable in a string + #terminal settings may need to be adjusted to stop auto glyph resizing - a rather annoying misfeature that some people seem to think they like. + #e.g in wezterm config: allow_square_glyphs_to_overflow_width = "Never" + #review - we could consider wasting a few cycles to check for a conflict and use a different FSUB + set FSUB \uF2DD + + + #this occurs commonly in table building with colspans - review + if {$actual_contentwidth > $frame_inner_width || $actual_contentheight != $frame_inner_height} { + set usecache 0 + #set buildcache 0 ;#comment out for debug/analysis so we can see + #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" + set cache_key [a+ Web-red web-white]$cache_key[a] + } + if {$buildcache && $actual_contentwidth < $frame_inner_width} { + #colourise cache_key to warn + if {$actual_contentwidth == 0} { + #we can still substitute with right length + set cache_key [a+ Web-steelblue web-black]$cache_key[a] } else { - set $boxelement $sub + #actual_contentwidth is narrower than frame - check template's patternwidth + if {[dict exists $frame_cache $cache_key]} { + set cache_patternwidth [dict get $frame_cache $cache_key patternwidth] + } else { + set cache_patternwidth [$actual_contentwidth] + } + if {$actual_contentwidth < $cache_patternwidth} { + set usecache 0 + set cache_key [a+ Web-orange web-black]$cache_key[a] + } elseif {$actual_contentwidth == $cache_patternwidth} { + #set usecache 1 + } else { + #actual_contentwidth > pattern + set usecache 0 + set cache_key [a+ Web-red web-black]$cache_key[a] + } } } - switch -- $frameset { - custom { - - set vll_width [punk::ansi::printing_length $vll] - set hlb_width [punk::ansi::printing_length $hlb] - set hlt_width [punk::ansi::printing_length $hlt] + #JMN debug + #set usecache 0 - 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 is_cached 0 + if {$usecache && [dict exists $frame_cache $cache_key]} { + set cache_patternwidth [dict get $frame_cache $cache_key patternwidth] + set template [dict get $frame_cache $cache_key frame] + set used [dict get $frame_cache $cache_key used] + dict set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + set is_cached 1 + } - 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}] + # -- --- --- --- --- --- --- --- --- + if {!$is_cached} { + set rst [a] + #set column [string repeat " " $frame_inner_width] ;#default - may need to override for custom frame + set underlayline [string repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + + + set vll_width 1 ;#default for all except custom (printing width) + set vlr_width 1 + + set framedef [textblock::framedef $framedef -joins $opt_joins] + dict with framedef {} ;#extract vll,hlt,tlc etc vars + + #puts "---> $opt_boxmap" + #review - we handle double-wide in custom frames - what about for boxmaps? + dict for {boxelement sub} $opt_boxmap { + if {$boxelement eq "vl"} { + set vll $sub + set vlr $sub + set hl $sub + } elseif {$boxelement eq "hl"} { + set hlt $sub + set hlb $sub + set hl $sub } 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 $boxelement $sub } - #set column [string repeat " " $contentwidth] - set underlayline [string repeat " " $contentwidth] - set underlay [::join [lrepeat $linecount $underlayline] \n] + } - 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] - if {$hlt_width > 0} { - set count [expr {($tbarwidth / $hlt_width) + 1}] + switch -- $frameset { + custom { + #REVIEW - textblock::table assumes that at least the vl elements are 1-wide + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely + set vll_width [punk::ansi::printing_length $vll] + set hlb_width [punk::ansi::printing_length $hlb] + set hlt_width [punk::ansi::printing_length $hlt] + + 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 {$frame_inner_width + 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 + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $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 count 0 + set frame_inner_width [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 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 - } - if {$hlb_width == 1} { - set bbar [string repeat $hlb $bbarwidth] - } else { - set blank [string repeat " " $bbarwidth] - if {$hlb_width > 0} { - set count [expr {($bbarwidth / $hlb_width) + 1}] + #set column [string repeat " " $frame_inner_width] + set underlayline [string repeat " " $frame_inner_width] + set underlay [::join [lrepeat $linecount $underlayline] \n] + #cache? + + if {$hlt_width == 1} { + set tbar [string repeat $hlt $tbarwidth] } else { - set count 0 + #possibly mixed width chars that make up hlt - string range won't get width right + set blank [string repeat " " $tbarwidth] + if {$hlt_width > 0} { + set count [expr {($tbarwidth / $hlt_width) + 1}] + } else { + set count 0 + } + 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 + } + if {$hlb_width == 1} { + set bbar [string repeat $hlb $bbarwidth] + } else { + set blank [string repeat " " $bbarwidth] + if {$hlb_width > 0} { + set count [expr {($bbarwidth / $hlb_width) + 1}] + } else { + set count 0 + } + set bbar [string repeat $hlb $count] + #set bbar [string range $bbar 0 $bbarwidth-1] + set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] } - set bbar [string repeat $hlb $count] - #set bbar [string range $bbar 0 $bbarwidth-1] - set bbar [overtype::left -overflow 0 -exposed1 " " -exposed2 " " $blank $bbar] - } - } - altg { - set tbar [string repeat $hlt $contentwidth] - set tbar [cd::groptim $tbar] - set bbar [string repeat $hlb $contentwidth] - set bbar [cd::groptim $bbar] - } - default { - set tbar [string repeat $hlt $contentwidth] - set bbar [string repeat $hlb $contentwidth] - - } - } - - set leftborder 0 - set rightborder 0 - set topborder 0 - set bottomborder 0 - # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - #puts "----->$exact_boxlimits" - foreach lim $exact_boxlimits { - switch -- $lim { - hlt { - set topborder 1 - } - hlb { - set bottomborder 1 - } - vll { - set leftborder 1 - } - vlr { - set rightborder 1 - } - tlc { - set topborder 1 - set leftborder 1 - } - trc { - set topborder 1 - set rightborder 1 } - blc { - set bottomborder 1 - set leftborder 1 + altg { + set tbar [string repeat $hlt $frame_inner_width] + set tbar [cd::groptim $tbar] + set bbar [string repeat $hlb $frame_inner_width] + set bbar [cd::groptim $bbar] } - brc { - set bottomborder 1 - set rightborder 1 + default { + set tbar [string repeat $hlt $frame_inner_width] + set bbar [string repeat $hlb $frame_inner_width] + } } - } - if {$opt_width ne "" && $opt_width < 2} { - set rightborder 0 - } - #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 - } - #boxlimits used for partial borders in table generation - set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] - set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] - foreach lim $unspecified_limits { - switch -- $lim { - vll { - set blank_vll [string repeat " " $vll_width] - set lhs [string repeat $blank_vll\n $linecount] - set lhs [string range $lhs 0 end-1] - } - vlr { - set blank_vlr [string repeat " " $vlr_width] - set rhs [string repeat $blank_vlr\n $linecount] - set rhs [string range $rhs 0 end-1] - } - hlt { - set bar_width [punk::ansi::printing_length $tbar] - set tbar [string repeat " " $bar_width] - } - tlc { - set tlc_width [punk::ansi::printing_length $tlc] - set tlc [string repeat " " $tlc_width] - } - trc { - set trc_width [punk::ansi::printing_length $trc] - set trc [string repeat " " $trc_width] - } - hlb { - set bar_width [punk::ansi::printing_length $bbar] - set bbar [string repeat " " $bar_width] - } - blc { - set blc_width [punk::ansi::printing_length $blc] - set blc [string repeat " " $blc_width] - } - brc { - set brc_width [punk::ansi::printing_length $brc] - set brc [string repeat " " $brc_width] + set leftborder 0 + set rightborder 0 + set topborder 0 + set bottomborder 0 + # hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + #puts "----->$exact_boxlimits" + foreach lim $exact_boxlimits { + switch -- $lim { + hlt { + set topborder 1 + } + hlb { + set bottomborder 1 + } + vll { + set leftborder 1 + } + vlr { + set rightborder 1 + } + tlc { + set topborder 1 + set leftborder 1 + } + trc { + set topborder 1 + set rightborder 1 + } + blc { + set bottomborder 1 + set leftborder 1 + } + brc { + set bottomborder 1 + set rightborder 1 + } } } - } + if {$opt_width ne "" && $opt_width < 2} { + set rightborder 0 + } + #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 - } - if {$opt_ansibase eq ""} { - set rstbase [a] - } else { - set rstbase [a]$opt_ansibase - } + #boxlimits used for partial borders in table generation + set all_exact_boxlimits [list vll vlr hlt hlb tlc blc trc brc] + set unspecified_limits [struct::set difference $all_exact_boxlimits $exact_boxlimits] + foreach lim $unspecified_limits { + switch -- $lim { + vll { + set blank_vll [string repeat " " $vll_width] + set lhs [string repeat $blank_vll\n $linecount] + set lhs [string range $lhs 0 end-1] + } + vlr { + set blank_vlr [string repeat " " $vlr_width] + set rhs [string repeat $blank_vlr\n $linecount] + set rhs [string range $rhs 0 end-1] + } + hlt { + set bar_width [punk::ansi::printing_length $tbar] + set tbar [string repeat " " $bar_width] + } + tlc { + set tlc_width [punk::ansi::printing_length $tlc] + set tlc [string repeat " " $tlc_width] + } + trc { + set trc_width [punk::ansi::printing_length $trc] + set trc [string repeat " " $trc_width] + } + hlb { + set bar_width [punk::ansi::printing_length $bbar] + set bbar [string repeat " " $bar_width] + } + blc { + set blc_width [punk::ansi::printing_length $blc] + set blc [string repeat " " $blc_width] + } + brc { + set brc_width [punk::ansi::printing_length $brc] + set brc [string repeat " " $brc_width] + } + } + } - if {$opt_title ne ""} { - #title overrides -boxlimits for topborder - set topborder 1 - } - set fs "" - #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? - if {$topborder} { - if {$leftborder && $rightborder} { - append fs $tlc$topbar$trc + 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 { - if {$leftborder} { - append fs $tlc$topbar - } elseif {$rightborder} { - append fs $topbar$trc - } else { - append fs $topbar - } + set topbar $tbar } - } - if {$has_contents || $opt_height > 2} { - #if {$topborder && $fs ne "xx"} { - # append fs \n - #} - if {$topborder} { - append fs \n + 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 } - #set inner [overtype::$opt_align -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$contents$rstbase] - set inner [overtype::$opt_align -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $contents] - if {$leftborder && $rightborder} { - set bodyparts [list $lhs $opt_ansibase$inner$rstbase $rhs] + if {$opt_ansibase eq ""} { + set rstbase [a] } else { - if {$leftborder} { - set bodyparts [list $lhs $opt_ansibase$inner$rstbase] - } elseif {$rightborder} { - set bodyparts [list $opt_ansibase$inner$rstbase $rhs] - } else { - set bodyparts [list $opt_ansibase$inner$rstbase] - } + set rstbase [a]$opt_ansibase } - set body [textblock::join -- {*}$bodyparts] - append fs $body - } - if {$opt_height eq "" || $opt_height > 1} { - if {$opt_subtitle ne ""} { - #subtitle overrides boxlimits for bottomborder - set bottomborder 1 + if {$opt_title ne ""} { + #title overrides -boxlimits for topborder + set topborder 1 + } + set fs "" + set fscached "" + set cache_patternwidth 0 + #todo - output nothing except maybe newlines depending on if opt_height 0 and/or opt_width 0? + if {$topborder} { + if {$leftborder && $rightborder} { + append fs $tlc$topbar$trc + } else { + if {$leftborder} { + append fs $tlc$topbar + } elseif {$rightborder} { + append fs $topbar$trc + } else { + append fs $topbar + } + } } - if {$bottomborder} { - if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { + append fscached $fs + if {$has_contents || $opt_height > 2} { + #if {$topborder && $fs ne "xx"} { + # append fs \n + #} + if {$topborder} { append fs \n + append fscached \n } - if {$leftborder && $rightborder} { - append fs $blc$bottombar$brc + switch -- $opt_textalign { + right {set pad "left"} + left {set pad "right"} + default {set pad $opt_textalign} + } + #set textaligned_contents [textblock::pad $contents -width $actual_contentwidth -which $pad -within_ansi 1] + #set inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$textaligned_contents] + + set cache_contentline [string repeat $FSUB $actual_contentwidth] + set cache_patternwidth $actual_contentwidth + set cache_contentpattern [::join [lrepeat $linecount $cache_contentline] \n] + set cache_inner [overtype::block -blockalign $opt_blockalign -ellipsis $opt_ellipsis $opt_ansibase$underlay$rstbase $opt_ansibase$cache_contentpattern] + #after overtype::block - our actual patternwidth may be less + set cache_patternwidth [string length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] + + if {$leftborder && $rightborder} { + #set bodyparts [list $lhs $inner $rhs] + set cache_bodyparts [list $lhs $cache_inner $rhs] } else { if {$leftborder} { - append fs $blc$bottombar + #set bodyparts [list $lhs $inner] + set cache_bodyparts [list $lhs $cache_inner] } elseif {$rightborder} { - append fs $bottombar$brc + #set bodyparts [list $inner $rhs] + set cache_bodyparts [list $cache_inner $rhs] + } else { + #set bodyparts [list $inner] + set cache_bodyparts [list $cache_inner] + } + } + #set body [textblock::join -- {*}$bodyparts] + set cache_body [textblock::join -- {*}$cache_bodyparts] + append fscached $cache_body + #append fs $body + } + + if {$opt_height eq "" || $opt_height > 1} { + if {$opt_subtitle ne ""} { + #subtitle overrides boxlimits for bottomborder + set bottomborder 1 + } + if {$bottomborder} { + if {($topborder & $fs ne "xx" ) || ($has_contents || $opt_height > 2)} { + #append fs \n + append fscached \n + } + if {$leftborder && $rightborder} { + #append fs $blc$bottombar$brc + append fscached $blc$bottombar$brc } else { - append fs $bottombar + if {$leftborder} { + #append fs $blc$bottombar + append fscached $blc$bottombar + } elseif {$rightborder} { + #append fs $bottombar$brc + append fscached $bottombar$brc + } else { + #append fs $bottombar + append fscached $bottombar + } + } + } + } + set template $fscached + ;#end !$is_cached + } + + #use the same mechanism to build the final frame - whether from cache or template + if {$actual_contentwidth == 0} { + set fs [string map [list $FSUB " "] $template] + } else { + set resultlines [list] + set overwritable [string repeat $FSUB $cache_patternwidth] + set contentindex 0 + switch -- $opt_textalign { + left {set pad right} + right {set pad left} + default {set pad $opt_textalign} + } + + #review + if {[string is integer -strict $opt_height] && $actual_contentheight < ($opt_height -2)} { + set diff [expr {($opt_height -2) - $actual_contentheight}] + append contents [::join [lrepeat $diff \n] ""] + } + + set paddedcontents [textblock::pad $contents -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedwidth [textblock::widthtopline $paddedcontents] + + #review - horizontal truncation + if {$paddedwidth > $cache_patternwidth} { + set paddedcontents [overtype::renderspace -width $cache_patternwidth "" $paddedcontents] + } + set contentblock [textblock::join $paddedcontents] ;#make sure each line has ansi replays + + set tlines [split $template \n] + + #we will need to strip off the leading reset on each line when stitching together with template lines so that ansibase can come into play too. + #after textblock::join the reset will be a separate code ie should be exactly ESC[0m + set R [a] + set rlen [string length $R] + set clines [split $contentblock \n] + + foreach tline $tlines { + if {[string first $FSUB $tline] >= 0} { + set content_line [lindex $clines $contentindex] + if {[string first $R $content_line] == 0} { + set content_line [string range $content_line $rlen end] } + #make sure to replay opt_ansibase to the right of the replacement + lappend resultlines [string map [list $overwritable $content_line$opt_ansibase] $tline] + incr contentindex + } else { + lappend resultlines $tline } } + set fs [::join $resultlines \n] } - return $fs + if {$is_cached} { + return $fs + } else { + if {$buildcache} { + dict set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] + } + return $fs + } } proc gcross {{size 1} args} { if {$size == 0} { diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index ef48a42b..9fc0951d 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -7222,11 +7222,6 @@ namespace eval punk { interp alias {} tmhere {} .= pwd |path> {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| - #interp alias {} c {} clear ;#external executable 'clear' may not always be available - #todo - review - #repl::term notifies prompt system of reset - interp alias {} clear {} repl::term::reset - interp alias {} c {} repl::term::reset interp alias {} colour {} punk::console::colour @@ -7237,7 +7232,18 @@ namespace eval punk { interp alias {} a {} punk::console::code_a interp alias {} a? {} punk::console::code_a? - + #interp alias {} c {} clear ;#external executable 'clear' may not always be available + #todo - review + interp alias {} clear {} ::punk::reset + interp alias {} c {} ::punk::reset + proc reset {} { + if {[llength [info commands ::punk::repl::reset_terminal]]} { + #punk::repl::reset_terminal notifies prompt system of reset + punk::repl::reset_terminal + } else { + puts -nonewline stdout [punk::ansi::reset] + } + } diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index f9aed044..2492bb9e 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -966,7 +966,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu dict set WEB_colour_map_purple violet 238-130-238 ;# #EE82EE dict set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD dict set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8 - dict set WEB_colour_map_purple lavender 230-230-150 ;# #E6E6FA + dict set WEB_colour_map_purple lavender 230-230-250 ;# #E6E6FA # -- --- --- #Blue colours variable WEB_colour_map_blue @@ -1422,33 +1422,66 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $SGR_map } - proc colourmap1 {{bgname White}} { - package require textblock + proc colourmap1 {args} { + set defaults {-bg Web-white -forcecolour 0} + dict for {k v} $args { + switch -- $k { + -bg - -forcecolour {} + default { + error "colourmap1 unrecognised option $k. Known-options: [dict keys $defaults] + } + } + } + set opts [dict merge $defaults $args] + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } else { + set fc "" + } + set bgname [dict get $opts -bg] - set bg [textblock::block 33 3 "[a+ $bgname] [a]"] + package require textblock + set bg [textblock::block 33 3 "[a+ {*}$fc $bgname] [a]"] set colourmap "" + set RST [a] for {set i 0} {$i <= 7} {incr i} { - append colourmap "_[a+ white bold 48\;5\;$i] $i [a]" + #append colourmap "_[a+ white bold 48\;5\;$i] $i [a]" + append colourmap "_[a+ {*}$fc white bold Term-$i] $i $RST" } set map1 [overtype::left -transparent _ $bg "\n$colourmap"] return $map1 } - proc colourmap2 {{bgname White}} { + proc colourmap2 {args} { + set defaults {-forcecolour 0 -bg Web-white} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set bgname [dict get $opts -bg] + package require textblock - set bg [textblock::block 39 3 "[a+ $bgname] [a]"] + set bg [textblock::block 39 3 "[a+ {*}$fc $bgname] [a]"] set colourmap "" + set RST [a] for {set i 8} {$i <= 15} {incr i} { if {$i == 8} { set fg "bold white" } else { set fg "black normal" ;#black normal is often blacker than black bold - which can display as a grey } - append colourmap "_[a+ {*}$fg 48\;5\;$i] $i [a]" + append colourmap "_[a+ {*}$fc {*}$fg 48\;5\;$i] $i $RST" } set map2 [overtype::left -transparent _ $bg "\n$colourmap"] return $map2 } - proc colourtable_216 {} { + proc colourtable_216 {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } package require textblock set clist [list] set fg "black" @@ -1460,7 +1493,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fg "black" } } - lappend clist "[a+ {*}$fg Term$i][format %3s $i]" + lappend clist "[a+ {*}$fc {*}$fg Term$i][format %3s $i]" } set t [textblock::list_as_table 36 $clist -return object] @@ -1470,7 +1503,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #1st 16 colours of 256 - match SGR colours - proc colourblock_16 {} { + proc colourblock_16 {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } set out "" set fg "bold white" for {set i 0} {$i <= 15} {incr i} { @@ -1478,11 +1517,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {$i > 8} { set fg "web-black" } - append out "[a+ {*}$fg Term$i][format %3s $i] " + append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] " } return $out[a] } - proc colourtable_16_names {} { + proc colourtable_16_names {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } variable TERM_colour_map_reverse set rows [list] set row [list] @@ -1500,8 +1545,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } elseif {$i > 6} { set fg "web-black" } - #lappend row "[a+ {*}$fg Term-$cname][format %3s $i] $cname " - lappend row "[a+ {*}$fg Term-$i][format %3s $i] $cname " + #lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname " + lappend row "[a+ {*}$fc {*}$fg Term-$i][format %3s $i] $cname " } lappend rows $row foreach r $rows { @@ -1514,7 +1559,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #216 colours of 256 - proc colourblock_216 {} { + proc colourblock_216 {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } set out "" set fg "web-black" for {set i 16} {$i <=231} {incr i} { @@ -1528,14 +1579,22 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set br "" } - append out "$br[a+ {*}$fg Term$i][format %3s $i] " + append out "$br[a+ {*}$fc {*}$fg Term$i][format %3s $i] " } append out [a] return [string trimleft $out \n] } #x6 is reasonable from a width (124 screen cols) and colour viewing perspective - proc colourtable_216_names {{cols 6}} { + proc colourtable_216_names {args} { + set defaults {-forcecolour 0 -columns 6} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set cols [dict get $opts -columns] + set out "" #use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names variable TERM_colour_map_reverse @@ -1557,7 +1616,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fg "web-black" } } - lappend row "[a+ {*}$fg Term-$cname][format %3s $i] $cname " + lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname " } lappend rows $row foreach r $rows { @@ -1568,7 +1627,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out [a] return [string trimleft $out \n] } - proc colourtable_term_pastel {} { + proc colourtable_term_pastel {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } set out "" set rows [list] #see https://www.hackitu.de/termcolor256/ @@ -1597,7 +1662,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu foreach r $rows { set rowcells [list] foreach cnum $r { - lappend rowcells "[a+ $fg Term-$cnum][format %3s $cnum] " + lappend rowcells "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " } $t add_row $rowcells } @@ -1606,14 +1671,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set pastel8 [list 102 138 144 108 109 103 139 145] set p8 "" foreach cnum $pastel8 { - append p8 "[a+ $fg Term-$cnum][format %3s $cnum] " + append p8 "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " } append p8 [a]\n append out \n $p8 return $out } - proc colourtable_term_rainbow {} { + proc colourtable_term_rainbow {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } set out "" set rows [list] set fgwhite [list 16 52 88 124 160 22 17 18 19 20 21 57 56 93 55 92 54 91 53 90 89 126 88 125 124 160] @@ -1666,7 +1737,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set fg "web-black" } - lappend rowcells "[a+ $fg Term-$cnum][format %3s $cnum] " + lappend rowcells "[a+ {*}$fc $fg Term-$cnum][format %3s $cnum] " } $t add_row $rowcells } @@ -1675,19 +1746,33 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $out } #24 greys of 256 - proc colourblock_24 {} { + proc colourblock_24 {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set out "" set fg "bold white" for {set i 232} {$i <= 255} {incr i} { if {$i > 243} { set fg "web-black" } - append out "[a+ {*}$fg Term$i][format %3s $i] " + append out "[a+ {*}$fc {*}$fg Term$i][format %3s $i] " } return $out[a] } - proc colourtable_24_names {} { + proc colourtable_24_names {args} { + set defaults {-forcecolour 0} + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + variable TERM_colour_map_reverse set rows [list] set row [list] @@ -1703,7 +1788,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {$i > 243} { set fg "web-black" } - lappend row "[a+ {*}$fg Term-$cname][format %3s $i] $cname " + lappend row "[a+ {*}$fc {*}$fg Term-$cname][format %3s $i] $cname " } lappend rows $row foreach r $rows { @@ -1729,7 +1814,23 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # $WEB_colour_map_white\ # $WEB_colour_map_gray\ #] - proc colourtable_web {{groups *}} { + proc colourtable_web {args} { + set defaults {-forcecolour 0 -groups *} + foreach {k v} $args { + switch -- $k { + -groups - -forcecolour {} + default { + error "colourtable_web unrecognised option '$k'. Known-options: [dict keys $defaults]" + } + } + } + set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } + set groups [dict get $opts -groups] + #set all_groupnames [list basic pink red orange yellow brown purple blue cyan green white gray] set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray] switch -- $groups { @@ -1772,13 +1873,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set fg "web-black" } - #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ $fg Rgb-$cdec] - $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ $fg Web-$cname] + #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] + $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] } $t configure -frametype {} $t configure_column 0 -headers [list "[string totitle $g] colours"] $t configure_column 0 -header_colspans [list all] - $t configure -ansibase_header [a+ web-black Web-white] + $t configure -ansibase_header [a+ {*}$fc web-black Web-white] lappend grouptables [$t print] $t destroy } @@ -1794,17 +1895,22 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable X11_colour_map_diff variable WEB_colour_map set defaults [dict create\ + -forcecolour 0\ -return "string"\ ] dict for {k v} $args { switch -- $k { - -return {} + -return - -forcecolour {} default { error "colourtable_x11diff unrecognised option '$k'. Known options [dict keys $defaults]" } } } set opts [dict merge $defaults $args] + set fc "" + if {[dict get $opts -forcecolour]} { + set fc "forcecolour" + } set comparetables [list] ;# 2 side by side x11 and web @@ -1814,12 +1920,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu dict for {cname cdec} [set X11_colour_map_diff] { $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] set fg "web-white" - $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ $fg X11-$cname] + $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg X11-$cname] } $t configure -frametype block $t configure_column 0 -headers [list "X11"] $t configure_column 0 -header_colspans [list all] - $t configure -ansibase_header [a+ web-black Web-white] + $t configure -ansibase_header [a+ {*}$fc web-black Web-white] lappend comparetables [$t print] $t destroy # -- --- --- @@ -1835,12 +1941,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu dict for {cname cdec} [set WEB_map_subset] { $t add_row [list "$cname " "[colour_dec2hex $cdec] " $cdec] set fg "web-white" - $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ $fg Web-$cname] + $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] } $t configure -frametype block $t configure_column 0 -headers [list "Web"] $t configure_column 0 -header_colspans [list all] - $t configure -ansibase_header [a+ web-black Web-white] + $t configure -ansibase_header [a+ {*}$fc web-black Web-white] lappend comparetables [$t print] $t destroy # -- --- --- @@ -1862,12 +1968,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #[para]Return an ansi string representing a table of codes and a panel showing the colours variable SGR_setting_map variable SGR_colour_map + set fcposn [lsearch $args "forcecol*"] + set fc "" + set opt_forcecolour 0 + if {$fcposn >= 0} { + set fc "forcecolour" + set opt_forcecolour 1 + set args [lremove $args $fcposn] + } if {![llength $args]} { set out "" set indent " " set RST [a] - append out "[a+ web-white]Extended underlines$RST" \n + append out "[a+ {*}$fc web-white]Extended underlines$RST" \n set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST" set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST" set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST" @@ -1876,8 +1990,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out "${indent}$underdashed" \n append out "${indent}$underline_c" \n append out "${indent}Extended underlines/colours can suppress other SGR codes on terminals that don't support them if codes are merged." \n - append out "${indent}punk::ansi tries to keep them in separate escape sequences even during merge operations to avoid this" \n - append out "[a+ web-white]Standard SGR colours and attributes $RST" \n + append out "${indent}punk::ansi tries to keep them in separate escape sequences (standard SGR followed by extended) even during merge operations to avoid this." \n + append out "${indent}If a fallback to standard underline is required, underline should be added along with extended codes such as underlinedotted, underlinedouble etc" \n + append out "${indent}e.g cyan with curly yellow underline or fallback all cyan underlined \[a+ cyan undercurly underline undt-yellow\]text\[a] -> [a+ {*}$fc cyan undercurly underline undt-yellow]text$RST" \n + append out "[a+ {*}$fc web-white]Standard SGR colours and attributes $RST" \n set settings_applied $SGR_setting_map set strmap [list] dict for {k v} $SGR_setting_map { @@ -1903,37 +2019,45 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out [textblock::join $indent [string map $strmap $settings_applied]] \n append out [textblock::join $indent [string trim $SGR_colour_map \n]] \n append out [textblock::join $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n - set bgname "White" - set map1 [colourmap1 $bgname] - set map1 [overtype::centre -transparent 1 $map1 "[a black $bgname]Standard colours[a]"] - set map2 [colourmap2 $bgname] - set map2 [overtype::centre -transparent 1 $map2 "[a black $bgname]High-intensity colours[a]"] + set bgname "Web-white" + set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour] + set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"] + set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour] + set map2 [overtype::centre -transparent 1 $map2 "[a {*}$fc black $bgname]High-intensity colours[a]"] append out [textblock::join $indent [textblock::join $map1 $map2]] \n - append out "[a+ web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n - append out [textblock::join $indent [colourblock_216]] \n - append out "[a+ web-white]24 Greyscale colours[a]" \n - append out [textblock::join $indent [colourblock_24]] \n + append out "[a+ {*}$fc web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n + append out [textblock::join $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n + append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n + append out [textblock::join $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n append out \n - append out [textblock::join $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ Term-92 term-49]text[a]"] \n - append out [textblock::join $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ Term-lightsteelblue term-gold1]text[a]"] \n - append out [textblock::join $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ term-lightsteelblue Term-gold1]text[a]"] \n + append out [textblock::join $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n + append out [textblock::join $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n + append out [textblock::join $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n append out \n - append out "[a+ web-white]16 Million colours[a]" \n + append out "[a+ {*}$fc web-white]16 Million colours[a]" \n #dict set WEB_colour_map mediumvioletred 199-21-133 ;# #C71585 - append out [textblock::join $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ rgb-199-21-133]text[a]"] \n - append out [textblock::join $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ Rgb#C71585]text[a]"] \n + append out [textblock::join $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n + append out [textblock::join $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n append out [textblock::join $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n append out \n - append out "[a+ web-white]Web colours[a]" \n + append out "[a+ {*}$fc web-white]Web colours[a]" \n append out [textblock::join $indent "To see all names use: a? web"] \n append out [textblock::join $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n append out [textblock::join $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n append out \n - append out [textblock::join $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ Web-springgreen web-coral]text[a]"] \n + append out [textblock::join $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n append out \n - append out "[a+ web-white]X11 colours[a] - mostly match Web colours" \n + append out "[a+ {*}$fc web-white]X11 colours[a] - mostly match Web colours" \n append out [textblock::join $indent "To see differences: a? x11"] \n + if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { + append out \n + if {$fc ne ""} { + append out "[a+ {*}$fc web-white]Colour is currently disabled - returning with colour anyway because 'forcecolour' argument was supplied[a]" \n + } else { + append out "Colour is currently disabled - to return with colour anyway - add the 'forcecolour' argument" \n + } + } } on error {result options} { puts stderr "Failed to draw colourmap" @@ -1952,22 +2076,22 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set out "16 basic colours\n" - append out [colourtable_16_names] \n + append out [colourtable_16_names -forcecolour $opt_forcecolour] \n append out "216 colours\n" - append out [colourtable_216_names] \n + append out [colourtable_216_names -forcecolour $opt_forcecolour] \n append out "24 greyscale colours\n" - append out [colourtable_24_names] + append out [colourtable_24_names -forcecolour $opt_forcecolour] foreach ta $termargs { switch -- $ta { pastel { append out \n append out "Pastel Colour Space (punk::ansi::colourtable_term_pastel)\n" - append out [colourtable_term_pastel] + append out [colourtable_term_pastel -forcecolour $opt_forcecolour] } rainbow { append out \n append out "Rainbow Colours (punk::ansi::colourtable_term_rainbow)\n" - append out [colourtable_term_rainbow] + append out [colourtable_term_rainbow -forcecolour $opt_forcecolour] } } } @@ -1975,12 +2099,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return $out } web { - return [colourtable_web [lrange $args 1 end]] + return [colourtable_web -forcecolour $opt_forcecolour -groups [lrange $args 1 end]] } x11 { set out "" append out " Mostly same as web - known differences displayed" \n - append out [colourtable_x11diff] + append out [colourtable_x11diff -forcecolour $opt_forcecolour] return $out } } @@ -1997,7 +2121,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set resultlist [list] foreach i $args { set f4 [string range $i 0 3] - set s [a+ $i]sample + set s [a+ {*}$fc $i]sample switch -- $f4 { web- - Web- - WEB- { set tail [string tolower [string trim [string range $i 4 end] -]] @@ -2083,6 +2207,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu undercurly - underdotted - underdashed - undersingle - underdouble { $t add_row [list $i extended $s [ansistring VIEW $s]] } + underline { + $t add_row [list $i "SGR 4" $s [ansistring VIEW $s]] + } default { $t add_row [list $i UNKNOWN $s [ansistring VIEW $s]] } @@ -2102,7 +2229,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - set ansi [a+ {*}$args] + set ansi [a+ {*}$fc {*}$args] set s ${ansi}sample #set merged [punk::ansi::codetype::sgr_merge_singles [list $ansi]] set merged [punk::ansi::codetype::sgr_merge [list $ansi]] @@ -2187,8 +2314,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #function name part of cache-key because a and a+ return slightly different results (a has leading reset) variable sgr_cache - if {[dict exists $sgr_cache a+$args]} { - return [dict get $sgr_cache a+$args] + set cache_key a+$args ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key + if {[dict exists $sgr_cache $cache_key]} { + return [dict get $sgr_cache $cache_key] } #don't disable ansi here. @@ -2196,6 +2324,20 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable WEB_colour_map variable TERM_colour_map + + set colour_disabled 0 + #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear + if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { + set colour_disabled 1 + } + #allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything. + set forcecolour 0 + set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour + if {$fcpos >= 0} { + set forcecolour 1 + set args [lremove $args $fcpos] + } + set t [list] set e [list] ;#extended codes needing to go in own escape sequence foreach i $args { @@ -2250,6 +2392,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu underline { lappend t 4 ;#underline } + underextendedoff { + #lremove any existing 4:1 etc + set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } undersingle { lappend e 4:1 } @@ -2265,10 +2412,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu underdashed { lappend e 4:5 } + default { + puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)" + } } } doub {lappend t 21 ;#doubleunderline} - noun {lappend t 24 ;#nounderline} + noun { + lappend t 24 ;#nounderline + #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } stri {lappend t 9 ;#strike} nost {lappend t 29 ;#nostrike} ital {lappend t 3 ;#italic} @@ -2451,6 +2605,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu default { if {[string is integer -strict $i] || [string first ";" $i] > 0} { lappend t $i + } elseif {[string first : $i] > 0} { + lappend e $i } else { puts stderr "ansi name unmatched: '$i' in call 'a+ $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" } @@ -2458,6 +2614,32 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } + #the performance penalty must not be placed on the standard colour_enabled path. + #This is punk. Colour is the happy path despite the costs. + #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. + #As no_color doesn't strip all ansi - the motivation for it should not generally be + if {$colour_disabled && !$forcecolour} { + set tkeep [list] + foreach code $t { + switch -- $code { + 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { + #SGR underline and other non colour effects + lappend tkeep $code + } + } + } + set t $tkeep + set ekeep [list] + foreach code $e { + switch -- $code { + 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { + lappend ekeep $code + } + } + } + set e $ekeep + } + # \033 - octal. equivalently \x1b in hex which is more common in documentation if {![llength $t]} { if {![llength $e]} { @@ -2472,7 +2654,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m" } } - dict set sgr_cache a+$args $result + dict set sgr_cache $cache_key $result return $result } @@ -2489,8 +2671,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #It's important to put the functionname in the cache-key because a and a+ return slightly different results variable sgr_cache - if {[dict exists $sgr_cache a_$args]} { - return [dict get $sgr_cache a_$args] + set cache_key a_$args + if {[dict exists $sgr_cache $cache_key]} { + return [dict get $sgr_cache $cache_key] } #don't disable ansi here. @@ -2498,6 +2681,19 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable WEB_colour_map variable TERM_colour_map + set colour_disabled 0 + #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear + if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { + set colour_disabled 1 + } + #allow a mechanism to override the colour_disabled terminal preference - for code that is generating colour for something else - don't let no_color ruin everything. + set forcecolour 0 + set fcpos [lsearch $args "forcecol*"] ;#allow forcecolor forcecolour + if {$fcpos >=0} { + set forcecolour 1 + set args [lremove $args $fcpos] + } + set t [list] set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence foreach i $args { @@ -2549,6 +2745,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu underline { lappend t 4 ;#underline } + underextendedoff { + #lremove any existing 4:1 etc + set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } undersingle { lappend e 4:1 } @@ -2564,10 +2765,17 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu underdashed { lappend e 4:5 } + default { + puts stderr "ansi term unmatched: unde* '$i' in call 'a $args' (underline,undersingle,underdouble,undercurly,underdotted,underdashed)" + } } } doub {lappend t 21 ;#doubleunderline} - noun {lappend t 24 ;#nounderline} + noun { + lappend t 24 ;#nounderline + #set e [struct::set difference $e [list 4:1 4:2 4:3 4:4 4:5]] + lappend e 4:0 + } stri {lappend t 9 ;#strike} nost {lappend t 29 ;#nostrike} ital {lappend t 3 ;#italic} @@ -2750,6 +2958,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu default { if {[string is integer -strict $i] || [string first ";" $i] > 0} { lappend t $i + } elseif {[string first : $i] > 0} { + lappend e $i } else { puts stderr "ansi name unmatched: '$i' in call 'a $args' Perhaps missing prefix? e.g web- x11- term- rgb# rgb-" } @@ -2757,16 +2967,38 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } + if {$colour_disabled && !$forcecolour} { + set tkeep [list] + foreach code $t { + switch -- $code { + 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { + #SGR underline and other non colour effects + lappend tkeep $code + } + } + } + set t $tkeep + set ekeep [list] + foreach code $e { + switch -- $code { + 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { + lappend ekeep $code + } + } + } + set e $ekeep + } + # \033 - octal. equivalently \x1b in hex which is more common in documentation # empty list [a] should do reset - same for [a nonexistant] # explicit reset at beginning of parameter list for a= (as opposed to a+) set t [linsert $t[unset t] 0 0] - if {[![llength $e]]} { + if {![llength $e]} { set result "\x1b\[[join $t {;}]m" } else { set result "\x1b\[[join $t {;}]m\x1b\[[join $e {;}]m" } - dict set sgr_cache a_$args $result + dict set sgr_cache $cache_key $result return $result } @@ -3400,10 +3632,15 @@ namespace eval punk::ansi { dict set codestate_empty italic "" ;#3 on 23 off dict set codestate_empty underline "" ;#4 on 24 off - #nonstandard 4:3,4:4,4:5 - dict set codestate_empty curlyunderline "" - dict set codestate_empty dottedunderline "" - dict set codestate_empty dashedunderline "" + #nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5 + #4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions + #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines + dict set codestate_empty underextended "" ;#4:0 for no extended underline 4:1 etc for underline styles + #dict set codestate_empty undersingle "" + #dict set codestate_empty underdouble "" + #dict set codestate_empty undercurly "" + #dict set codestate_empty underdottedn "" + #dict set codestate_empty underdashed "" dict set codestate_empty blink "" ;#5 or 6 for slow/fast, 25 for off dict set codestate_empty reverse "" ;#7 on 27 off @@ -3411,7 +3648,7 @@ namespace eval punk::ansi { dict set codestate_empty strike "" ;#9 on 29 off dict set codestate_empty font "" ;#10, 11-19 10 being primary dict set codestate_empty gothic "" ;#20 - dict set codestate_empty doubleunderline "" ;#21 + dict set codestate_empty doubleunderline "" ;#21 (standard SGR double as opposed to underdouble) dict set codestate_empty proportional "" ;#26 - see note below dict set codestate_empty frame_or_circle "" ;#51,52 on - 54 off (54 off) (not generally used - mintty has repurposed for emoji variation selector) @@ -3422,7 +3659,7 @@ namespace eval punk::ansi { dict set codestate_empty ideogram_doubleoverline "" dict set codestate_empty ideogram_clear "" - dict set codestate_empty overline "" ;#53 on 55 off - probably not supported - pass through. + dict set codestate_empty overline "" ;#53 on 55 off - probably not supported - pass through. Seem to be ok to merge with other SGR even if not supported. dict set codestate_empty underlinecolour "" ;#58 - same arguments as 256colour and rgb (nonstandard - in Kitty ,VTE,mintty and iTerm2) # -- mintty? @@ -3556,26 +3793,24 @@ namespace eval punk::ansi { } else { switch -- [lindex $paramsplit 1] { 0 { - #no underline - dict set codestate underline 24 - dict set codestate curlyunderline "" - dict set codestate dottedunderline "" - dict set codestate dashedunderline "" + #no *extended* underline + #dict set codestate underline 24 + dict set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended } 1 { - dict set codestate underline 4 ;#straight underline + dict set codestate underextended 4:1 } 2 { - dict set codestate doubleunderline 21 + dict set codestate underextended 4:2 } 3 { - dict set codestate curlyunderline "4:3" + dict set codestate underextended "4:3" } 4 { - dict set codestate dottedunderline "4:4" + dict set codestate underextended "4:4" } 5 { - dict set codestate dashedunderline "4:5" + dict set codestate underextended "4:5" } } @@ -3614,9 +3849,7 @@ namespace eval punk::ansi { } 24 { dict set codestate underline 24 ;#off - dict set codestate curlyunderline "" - dict set codestate dottedunderline "" - dict set codestate dashedunderline "" + dict set codestate underextended "4:0" ;#review } 25 { dict set codestate blink 25 ;#off @@ -3806,7 +4039,7 @@ namespace eval punk::ansi { append codemerge "${v}\;" } } - underlinecolour - curlyunderline - dashedunderline - dottedunderline { + underlinecolour - underextended { append unmergeable "${v}\;" } default { @@ -3822,7 +4055,7 @@ namespace eval punk::ansi { "" {} default { switch -- $k { - underlinecolour - curlyunderline - dashedunderline - dottedunderline { + underlinecolour - underextended { append unmergeable "${v}\;" } default { diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index e6dd08be..5589468c 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -775,29 +775,10 @@ namespace eval punk::console { #a and a+ functions are not very useful when emitting directly to console #e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first - #proc a {args} { - # variable colour_disabled - # variable ansi_wanted - # if {$colour_disabled || $ansi_wanted <= 0} { - # return - # } - # #stdout - # tailcall 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 a? {args} { #stdout - variable colour_disabled variable ansi_wanted - if {$colour_disabled || $ansi_wanted <= 0} { + if {$ansi_wanted <= 0} { puts -nonewline [punk::ansi::stripansi [::punk::ansi::a?]] } else { tailcall ansi::a? {*}$args @@ -805,9 +786,8 @@ namespace eval punk::console { } proc code_a+ {args} { - variable colour_disabled variable ansi_wanted - if {$colour_disabled || $ansi_wanted <= 0} { + if {$ansi_wanted <= 0} { return } #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here @@ -815,24 +795,27 @@ namespace eval punk::console { ::punk::ansi::a+ {*}$args } proc code_a {args} { - variable colour_disabled variable ansi_wanted - if {$colour_disabled || $ansi_wanted <= 0} { + if {$ansi_wanted <= 0} { return } #tailcall punk::ansi::a {*}$args ::punk::ansi::a {*}$args } proc code_a? {args} { - variable colour_disabled variable ansi_wanted - if {$colour_disabled || $ansi_wanted <= 0} { + if {$ansi_wanted <= 0} { return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]] } else { tailcall ::punk::ansi::a? {*}$args } } + #REVIEW! this needs reworking. + #It needs to be clarified as to what ansi off is supposed to do. + #Turning ansi off only stops new ansi being generated - but what about codes stored in configurations of existing elements such as tables/frames? + #It will stop underlines/bold/reverse as well as SGR colours + #what about ansi movement codes etc? proc ansi {{onoff {}}} { variable ansi_wanted if {[string length $onoff]} { @@ -859,25 +842,36 @@ namespace eval punk::console { } } } - catch {repl::reset_prompt} + catch {punk::repl::reset_prompt} return [expr {$ansi_wanted}] } - proc colour {{onoff {}}} { + + #colour + # Turning colour off will stop SGR colour codes from being generated unless 'forcecolour' is added to the argument list for the punk::ans::a functions + proc colour {{on {}}} { variable colour_disabled - if {[string length $onoff]} { - set onoff [string tolower $onoff] + if {$on ne ""} { + if {![string is boolean -strict $on]} { + error "punk::console::colour expected a boolean e.g 0|1|on|off|true|false|yes|no" + } #an experiment with complete disabling vs test of state for each call - if {$onoff in [list 1 on true yes]} { - 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 - set colour_disabled 1 + if {$on} { + if {$colour_disabled} { + #change of state + punk::ansi::sgr_cache clear + catch {punk::repl::reset_prompt} + set colour_disabled 0 + } } else { - error "punk::console::colour expected 0|1|on|off|true|false|yes|no" + #we don't disable a/a+ entirely - they must still emit underlines/bold/reverse + if {!$colour_disabled} { + #change of state + punk::ansi::sgr_cache clear + catch {punk::repl::reset_prompt} + set colour_disabled 1 + } } } - catch {repl::reset_prompt} return [expr {!$colour_disabled}] } @@ -1253,7 +1247,7 @@ namespace eval punk::console { proc infocmp {} { set cmd1 [auto_execok infocmp] if {[string length $cmd1]} { - puts stderr "Using infocmp executable" + puts stderr "" return [exec {*}$cmd1] } else { puts stderr "infocmp doesn't seem to be present" diff --git a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd index 047321ee..9de4c125 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd @@ -54,9 +54,9 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' @REM @ECHO nextshelltype is %nextshelltype[win32___________]% @REM @SET "selected_shelltype=%nextshelltype[win32___________]%" @SET "selected_shelltype=%nextshelltype[win32___________]%" -@ECHO selected_shelltype %selected_shelltype% +@REM @ECHO selected_shelltype %selected_shelltype% @CALL :stringTrimTrailingUnderscores %selected_shelltype% selected_shelltype_trimmed -@ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% +@REM @ECHO selected_shelltype_trimmed %selected_shelltype_trimmed% @SET "selected_shellpath=%nextshellpath[win32___________]%" @CALL :stringTrimTrailingUnderscores %selected_shellpath% selected_shellpath_trimmed @CALL SET "keyRemoved=%%validshelltypes:!selected_shelltype!=%%" @@ -202,8 +202,8 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' IF NOT "x%keyRemoved%"=="x%validshelltypes%" ( REM sh on windows uses /c/ instead of /mnt/c - at least if using msys. Todo, review what is the norm on windows with and without msys2,cygwin,wsl REM and what logic if any may be needed. For now sh with /c/xxx seems to work the same as sh with c:/xxx - %selected_shellpath_trimmed% "%~dp0%fname%" %arglist% - SET task_exitcode=!errorlevel! + REM The compound statement with trailing call is required to stop batch termination confirmation, whilst still capturing exitcode + %selected_shellpath_trimmed% "%~dp0%fname%" %arglist% & SET task_exitcode=!errorlevel! & Call; ) ELSE ( ECHO %fname% has invalid nextshelltype value %selected_shelltype% valid options are %validshelltypes% SET task_exitcode=66 diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 0f594b47..6cb25e06 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -54,7 +54,7 @@ if {![info exists ::env(TERM)]} { #} } -#todo - move to less generic namespace +#todo - move to less generic namespace ie punk::repl namespace eval repl { variable screen_last_chars "" ;#a small sliding append buffer for last char of any screen output to detect \n vs string variable screen_last_char_list [list] @@ -65,11 +65,12 @@ namespace eval repl { #important not to initialize - as it can be preset by cooperating package before app-punk has been package required #(this is an example of a deaddrop) variable post_script - variable signal_control_c 0 } namespace eval punk::repl { variable debug_repl 0 + variable signal_control_c 0 + variable signal_control_c_msg "" proc todo {} { puts "tcl History" @@ -100,7 +101,7 @@ namespace eval punk::repl { #todo - make optional/configurable? proc bgerror2 {args} { puts stderr "====================" - puts stderr "repl::bgerror" + puts stderr "punk::repl::bgerror" puts stderr "====================" puts stderr "[lindex $args 0]" puts stderr "-------------------" @@ -124,79 +125,107 @@ namespace eval punk::repl { } if {![llength [info commands ::bgerror]]} { - #interp alias {} bgerror {} ::repl::bgerror + #interp alias {} bgerror {} ::punk::repl::bgerror } interp bgerror "" ::punk::repl::bgerror } namespace eval repl { -} -namespace eval ::repl::term { } -package require term::ansi::code::ctrl - if {$::tcl_platform(platform) eq "windows"} { - #jmn disable twapi - #package require zzzload - #zzzload::pkg_require twapi - after idle [list after 1000 { #puts stdout "===============repl loading twapi===========" - #zzzload::pkg_wait twapi - - if {![catch {package require twapi}]} { - - proc ::repl::term::handler_console_control {args} { - #puts -nonewline stdout . - #flush stdout - incr ::repl::signal_control_c - #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 "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 "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 "signal ctrl-c x3 received - quitting" - flush stderr - after 25 - quit - return 1 - } elseif {$::repl::signal_control_c == 4} { - puts stderr "signal ctrl-c x4 received - one more to hard exit" - flush stderr + if {![catch {package require twapi}]} { + + #If script launched with windows batch file - we have to be careful to stop a ctrl-c from eventually reaching the batch file when the program terminates, even if fully handled here. + #This is done from within the launching batch file + proc ::punk::repl::handler_console_control {args} { + variable signal_control_c + variable signal_control_c_msg + switch -- [lindex $args 0] { + ctrl-c { + #puts stderr "->event $args" + flush stderr + incr signal_control_c + #rputs stderr "* console_control: $args" + if {$::punk::console::is_raw} { + if {[lindex $::errorCode 0] eq "CHILDKILLED"} { + #rputs stderr "\n|repl> ctrl-c errorCode: $::errorCode" + #avoid spurious triggers after interrupting a command.. + #review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl + set ::punk::repl::signal_control_c 0 + set preverr [string map [list "child killed" "child_killed"] $::errorInfo] + catch {error $preverr} ;#for errorInfo display + return 42 + } else { + #how to let rawmode loop handle it? It doesn't seem to get through if we return 0 + #puts stderr "signal ctrl-c while in raw mode" + #flush stderr + set signal_control_c_msg "signal ctrl-c while in raw mode" + if {$signal_control_c > 5} { + puts stderr "signal ctrl-c $signal_control_c received - sending to default handler" + flush stderr + punk::mode line + return 0 + } + + return 1 + #after 200 {exit 42} ;#temp + #return 42 + } + } + + + if {[lindex $::errorCode 0] eq "CHILDKILLED"} { + set signal_control_c 0 + set preverr [string map [list "child killed" "child_killed"] $::errorInfo] + catch {error $preverr} ;#for errorInfo display + return 42 + } + #note - returning 0 means pass event to other handlers including OS default handler + if {$signal_control_c <= 2} { + set remaining [expr {3 - $signal_control_c}] + puts stderr "signal ctrl-c (perform $remaining more to quit, enter to return to repl)" + flush stderr + return 1 + } elseif {$signal_control_c == 3} { + puts stderr "signal ctrl-c x3 received - quitting." + flush stderr + after 25 + quit + return 1 + } elseif {$signal_control_c == 4} { + puts stderr "signal ctrl-c x4 received - one more to hard exit" + flush stderr + return 1 + } elseif {$signal_control_c >= 5} { + #a script that allows events to be processed could still be running + 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 "signal ctrl-c $signal_control_c received" + flush stderr + #return 0 to fall through to default handler + return 0 + } + + } + default { + puts stderr "unhandled console signal $args" return 1 - } elseif {$::repl::signal_control_c >= 5} { - #a script that allows events to be processed could still be running - 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 "signal ctrl-c $::repl::signal_control_c received" - flush stderr - #return 0 to fall through to default handler - return 0 } } - twapi::set_console_control_handler ::repl::term::handler_console_control - #we can't yet emit from an event with proper prompt handling - - #repl::rputs stdout "twapi loaded" - } else { - #repl::rputs stderr " Failed to load twapi" } - }] + twapi::set_console_control_handler ::punk::repl::handler_console_control + #we can't yet emit from an event with proper prompt handling - + #repl::rputs stdout "twapi loaded" + } else { + #repl::rputs stderr " Failed to load twapi" + } } else { #TODO } @@ -367,7 +396,7 @@ proc ::unknown args { } - #experiment todo - use twapi and named pipes + #windows experiment todo - use twapi and named pipes #twapi::namedpipe_server {\\.\pipe\something} #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc @@ -379,90 +408,24 @@ proc ::unknown args { set c1 $new } - # 'script' command to fake a tty - # note that we lose the exit code from the underlying command by using 'script' if we call shellfilter::run without -e option to script - set scr [auto_execok script] - set scr "" ;#set src to empty to disable - script is just a problematic experiment - if {$scr ne ""} { - #set scriptrun "( $c1 [lrange $args 1 end] )" - - - if 0 { - set scriptrun "( $c1 " - foreach a [lrange $args 1 end] { - if {[string first " " $a] > 0} { - #append scriptrun "\"$a\"" - append scriptrun $a - } else { - append scriptrun $a - } - append scriptrun " " - } - append scriptrun " )" - } - #------------------------------------- - if 0 { - package require string::token::shell - set shellparts [string token shell -indices $args] - - set scriptrun "( $c1 " - foreach info [lrange $shellparts 1 end] { - set type [lindex $info 0] - if {$type eq "D:QUOTED"} { - append scriptrun "\"" - append scriptrun [lindex $info 3] - append scriptrun "\"" - } elseif {$type eq "S:QUOTED"} { - append scriptrun "'" - append scriptrun [lindex $info 3] - append scriptrun "'" - } elseif {$type eq "PLAIN"} { - append scriptrun [lindex $info 3] - } else { - error "Can't interpret '$args' with sh-like syntax" - } - append scriptrun " " - } - append scriptrun " )" - } - - #------------------------------------- - - #uplevel 1 [list ::catch \ - [list ::shellfilter::run [list $scr -q -e -c $scriptrun /dev/null] -teehandle punk -inbuffering line -outbuffering none ] \ + # -- --- --- --- --- + set idlist_stdout [list] + set idlist_stderr [list] + set shellrun::runout "" + #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + + if {![dict get $::punk::config::running exec_unknown]} { + #This runs external executables in a context in which they are not attached to a terminal + #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output + #ctrl-c propagation also needs to be considered + + set teehandle punksh + uplevel 1 [list ::catch \ + [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] \ ::tcl::UnknownResult ::tcl::UnknownOptions] - if {[string tolower [file rootname [file tail $new]]] ne "script"} { - - if {$::env(SHELL) eq "punk86"} { - set shellcmdflag "punk86 cmdb" - } elseif {$::env(SHELL) eq "cmd"} { - set shellcmdflag "cmd /c" - } elseif {$::env(SHELL) eq "pwsh"} { - set shellcmdflag "pwsh -c" - } else { - # sh etc - #set shellcmdflag "$::env(SHELL) -c" - set shellcmdflag "-c" - } - - - #set commandlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not [concat [list $new ] [lrange $args 1 end]]] - set commandlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $args $shellcmdflag] - puts stderr ">>> [lindex $commandlist 4]" - } else { - set commandlist [list $new {*}[lrange $args 1 end]] - } - - puts stderr ">>>scriptrun_commandlist: $commandlist" - - #ansiwrap for testing - #set id_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] - uplevel #0 [list ::catch [list ::shellfilter::run $commandlist -teehandle punk -inbuffering line -outbuffering none ] ::tcl::UnknownResult ::tcl::UnknownOptions] - #shellfilter::stack::remove stderr $id_stderr - - - puts stdout "script result $::tcl::UnknownOptions $::tcl::UnknownResult" if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { dict set ::tcl::UnknownOptions -code error set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" @@ -472,57 +435,37 @@ proc ::unknown args { set ::tcl::UnknownResult "" } } else { - set idlist_stdout [list] - set idlist_stderr [list] - set shellrun::runout "" - #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks - #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] - #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] - - if {![dict get $::punk::config::running exec_unknown]} { - uplevel 1 [list ::catch \ - [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle punk -inbuffering line -outbuffering none ] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - - if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { - dict set ::tcl::UnknownOptions -code error - set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" - } else { - #no point returning "exitcode 0" if that's the only non-error return. - #It is misleading. Better to return empty string. - set ::tcl::UnknownResult "" - } + set ::punk::last_run_display [list] + + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" } else { - set ::punk::last_run_display [list] - - set redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] - #we can't detect stdout/stderr output from the exec - #for now emit an extra \n on stderr - #todo - use console apis (twapi on windows) to detect cursor posn? - # - # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit - if {[dict get $::tcl::UnknownOptions -code] == 0} { - set c green - set m "ok" - } else { - set c yellow - set m "errorCode $::errorCode" - } - set chunklist [list] - lappend chunklist [list "info" "[a $c]$m[a] " ] - set ::punk::last_run_display $chunklist - + set c yellow + set m "errorCode $::errorCode" } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + set ::punk::last_run_display $chunklist - foreach id $idlist_stdout { - shellfilter::stack::remove stdout $id - } - foreach id $idlist_stderr { - shellfilter::stack::remove stderr $id - } } + foreach id $idlist_stdout { + shellfilter::stack::remove stdout $id + } + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + # -- --- --- --- --- + #uplevel 1 [list ::catch \ # [concat exec $redir $new [lrange $args 1 end]] \ @@ -573,6 +516,7 @@ proc ::unknown args { } } } + #punk - disable prefix match search set default_cmd_search 0 if {$default_cmd_search} { @@ -602,16 +546,16 @@ punk::configure_unknown ;#must be called because we hacked the tcl 'unknown' pro -proc repl::reset_prompt {} { +proc punk::repl::reset_prompt {} { variable prompt_reset_flag set prompt_reset_flag 1 } -#todo - review -proc repl::term::reset {} { +#aliases c and clear to this by ::punk +proc punk::repl::reset_terminal {} { set prompt_reset_flag 1 #clear ;#call to external executable which may not be available - puts stdout [::term::ansi::code::ctrl::rd] + puts -nonewline stdout [::punk::ansi::reset] } proc repl::get_prompt_config {} { @@ -630,6 +574,7 @@ proc repl::get_prompt_config {} { return [list resultprompt $resultprompt nlprompt $nlprompt infoprompt $infoprompt debugprompt $debugprompt] } proc repl::start {inchan args} { + #puts stderr "-->repl::start $inchan $args" variable commandstr variable readingchunk @@ -647,6 +592,7 @@ proc repl::start {inchan args} { variable startinstance variable loopinstance if {[namespace exists ::punkapp]} { + #review - document ? if {[dict exists $args -defaultresult]} { set ::punkapp::default_result [dict get $args -defaultresult] } @@ -680,10 +626,12 @@ proc repl::start {inchan args} { #set punk::console::tabwidth [punk::console::get_tabstop_apparent_width] } vwait [namespace current]::done + #puts stderr "-->start done = $::repl::done" #todo - override exit? #after 0 ::repl::post_operations after idle ::repl::post_operations vwait repl::post_operations_done + #puts stderr "-->start post_operations_done = $::repl::post_operations_done" if {[namespace exists ::punkapp]} { #todo check and get punkapp::result array - but what key? if {[info exists ::punkapp::result(shell)]} { @@ -696,6 +644,7 @@ proc repl::start {inchan args} { return $temp } } + punk::mode line return 0 } proc repl::post_operations {} { @@ -730,18 +679,21 @@ proc repl::reopen_stdin {} { twapi::SetStdHandle -10 $h } puts stderr "restarting repl on inputchannel:$s" - return [repl::start $s] + return [repl::start $s -title "reopen_stdin a"] } else { #/dev/tty - reference to the controlling terminal for a process #review/test set s [open "/dev/tty" r] } - repl::start stdin + repl::start stdin -title "reopen_stdin b" } +#todo - avoid putting this in gobal namespace? +#collisions with other libraries apps? proc quit {} { set ::repl::done "quit" + #puts stderr "quit called" return "" ;#make sure to return nothing so "quit" doesn't land on stdout } @@ -1463,30 +1415,78 @@ namespace eval punk::repl::class { } } -proc repl::repl_handler_checkchannel {inputchan} { - if {$::repl::signal_control_c > 0 || [chan eof $inputchan]} { - - if {[lindex $::errorCode 0] eq "CHILDKILLED"} { - #rputs stderr "\n|repl> ctrl-c errorCode: $::errorCode" - #avoid spurious triggers after interrupting a command.. - #review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl - set ::repl::signal_control_c 0 - set preverr [string map [list "child killed" "child_killed"] $::errorInfo] - catch {error $preverr} ;#for errorInfo display - } else { - set ::repl::signal_control_c 0 - fileevent $inputchan readable {} - set reading 0 - set running 0 + +proc ::punk::repl::repl_handler_checkchannel {inputchan} { + if {[catch {chan eof $inputchan} is_eof]} { + ::repl::rputs stderr "\n|repl> repl_handler_checkchannel error on $inputchan. (closed?) msg:$is_eof" + } else { + if {$is_eof} { + if {$::tcl_interactive} { + ::repl::rputs stderr "\n|repl> repl_handler_checkchannel EOF on $inputchan." + } + } + } +} +proc ::punk::repl::repl_handler_checkcontrolsignal_linemode {inputchan} { + #todo - what? + return + variable signal_control_c + if {$signal_control_c > 0} { + if {$::tcl_interactive} { + ::repl::rputs stderr "\n|repl> repl_handler_checkcontrolsignal_linemode ctrl-c errorCode 0: [lindex $::errorCode 0]" + } + } +} +proc ::punk::repl::repl_handler_checkcontrolsignal_rawmode {inputchan} { + variable signal_control_c + variable signal_control_c_msg + if {$signal_control_c > 0 && $signal_control_c_msg ne "" } { + #if {$::tcl_interactive} { + # ::repl::rputs stderr "\n|repl> repl_handler_checkcontrolsignal_rawmode ctrl-c errorCode 0: [lindex $::errorCode 0]" + #} + set signal_control_c_msg "" + if {$signal_control_c <= 2} { + set remaining [expr {3 - $signal_control_c}] if {$::tcl_interactive} { - rputs stderr "\n|repl> EOF on $inputchan." + puts stderr "rawmode signal ctrl-c (perform $remaining more to quit, enter to return to repl)" + flush stderr + } + return 1 + } elseif {$signal_control_c == 3} { + if {$::tcl_interactive} { + puts stderr "rawmode signal ctrl-c x3 received - quitting" + flush stderr + } + after 25 + quit + return 1 + } elseif {$signal_control_c == 4} { + if {$::tcl_interactive} { + puts stderr "rawmode signal ctrl-c x4 received - one more to hard exit" + flush stderr + } + return 1 + } elseif {$signal_control_c >= 5} { + #a script that allows events to be processed could still be running + if {$::tcl_interactive} { + puts stderr "rawmode signal ctrl-c x5 received - hard exit" + flush stderr } - set [namespace current]::done 1 - after 1 [list repl::reopen_stdin] - #tailcall repl::reopen_stdin + punk::mode line + after 25 + exit 499 ;# HTTP 'client closed request' - just for the hell of it. + } else { + #shouldn't get here.. if we do somehow - let the default handler have a go + puts stderr "rawmode signal ctrl-c $signal_control_c received" + flush stderr + #return 0 to fall through to default handler + punk::mode line + return 0 } } } + + 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? @@ -1502,8 +1502,16 @@ proc repl::repl_handler_restorechannel {inputchan previous_input_state} { return [chan conf $inputchan] } proc repl::repl_handler {inputchan prompt_config} { + # -- review variable in_repl_handler set in_repl_handler [list $inputchan $prompt_config] + # -- + + variable prompt_reset_flag + if {$prompt_reset_flag == 1} { + set prompt_config [get_prompt_config] + set prompt_reset_flag 0 + } fileevent $inputchan readable {} upvar ::punk::console::input_chunks_waiting input_chunks_waiting @@ -1593,7 +1601,8 @@ proc repl::repl_handler {inputchan prompt_config} { } } else { - repl_handler_checkchannel $inputchan + punk::repl::repl_handler_checkchannel $inputchan + punk::repl::repl_handler_checkcontrolsignal_linemode $inputchan # -- --- --- #set chunksize [gets $inputchan chunk] # -- --- --- @@ -1628,7 +1637,9 @@ proc repl::repl_handler {inputchan prompt_config} { } else { - repl_handler_checkchannel $inputchan + punk::repl::repl_handler_checkchannel $inputchan + punk::repl::repl_handler_checkcontrolsignal_rawmode $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 @@ -1663,21 +1674,30 @@ proc repl::repl_handler {inputchan prompt_config} { } #################################################### } else { - #rputs stderr "repl_handler EOF inputchannel:[chan conf $inputchan]" - repl_handler_checkchannel $inputchan + #repl_handler_checkchannel $inputchan + fileevent $inputchan readable {} + set reading 0 + set running 0 + if {$::tcl_interactive} { + rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" + #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." + } + set [namespace current]::done 1 + after 1 [list repl::reopen_stdin] } set in_repl_handler [list] } -proc repl::editbuf {index args} { - variable editbuf_list - set editbuf [lindex $editbuf_list $index] + +proc punk::repl::editbuf {index args} { + set editbuf [lindex $::repl::editbuf_list $index] if {$editbuf ne ""} { $editbuf {*}$args } else { return "No such index in editbuf list" } } -interp alias {} editbuf {} ::repl::editbuf +interp alias {} editbuf {} ::punk::repl::editbuf + proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} { variable loopinstance variable loopcomplete @@ -1800,13 +1820,13 @@ proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} { #if we get just ctrl-c in one chunk #ctrl-c if {$chunk eq "\x03"} { - #::repl::term::handler_console_control "ctrl-c_via_rawloop" + #::punk::repl::handler_console_control "ctrl-c_via_rawloop" error "character 03 -> ctrl-c" } #for now - exit with small delay for tidyup #ctrl-z if {$chunk eq "\x1a"} { - #::repl::term::handler_console_control "ctrl-z_via_rawloop" + #::punk::repl::handler_console_control "ctrl-z_via_rawloop" punk::mode line after 1000 exit return @@ -2483,8 +2503,8 @@ proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} { } else { #append commandstr \n - if {$::repl::signal_control_c} { - set ::repl::signal_control_c 0 + if {$::punk::repl::signal_control_c} { + set ::punk::repl::signal_control_c 0 fileevent $inputchan readable {} rputs stderr "* console_control: control-c" flush stderr @@ -2579,8 +2599,7 @@ package provide punk::repl [namespace eval punk::repl { set version 0.1 }] -#repl::start stdin -#exit 0 - #repl::start $program_read_stdin_pipe + + diff --git a/src/modules/shellfilter-0.1.9.tm b/src/modules/shellfilter-0.1.9.tm index eaef5a42..888b5fdb 100644 --- a/src/modules/shellfilter-0.1.9.tm +++ b/src/modules/shellfilter-0.1.9.tm @@ -128,117 +128,6 @@ namespace eval shellfilter::pipe { } } -namespace eval shellfilter::ansi2 { - #shellfilter::ansi procs only: adapted from ansicolor page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control except where otherwise marked - variable test "blah\033\[1;33mETC\033\[0;mOK" - namespace export + = ? - #CSI m = SGR (Select Graphic Rendition) - variable SGR_setting_map { - bold 1 dim 2 blink 5 fastblink 6 noblink 25 hide 8 normal 22 - underline 4 doubleunderline 21 nounderline 24 strike 9 nostrike 29 italic 3 noitalic 23 - reverse 7 noreverse 27 defaultfg 39 defaultbg 49 - overline 53 nooverline 55 frame 51 framecircle 52 noframe 54 - } - variable SGR_colour_map { - black 30 red 31 green 32 yellow 33 blue 34 purple 35 cyan 36 white 37 - Black 40 Red 41 Green 42 Yellow 43 Blue 44 Purple 45 Cyan 46 White 47 - BLACK 100 RED 101 GREEN 102 YELLOW 103 BLUE 104 PURPLE 105 CYAN 106 WHITE 107 - } - variable SGR_map - set SGR_map [dict merge $SGR_colour_map $SGR_setting_map] - - proc + {args} { - #don't disable ansi here. - #we want this to be available to call even if ansi is off - variable SGR_map - set t [list] - foreach i $args { - if {[string is integer -strict $i]} { - lappend t $i - } elseif {[string first ";" $i] >=0} { - #literal with params - lappend t $i - } else { - if {[dict exists $SGR_map $i]} { - lappend t [dict get $SGR_map $i] - } else { - #accept examples for foreground - # 256f-# or 256fg-# or 256f# - # rgbf--- or rgbfg--- or rgbf-- - switch -nocase -glob $i { - "256f*" { - set cc [string trim [string range $i 4 end] -gG] - lappend t "38;5;$cc" - } - "256b*" { - set cc [string trim [string range $i 4 end] -gG] - lappend t "48;5;$cc" - } - "rgbf*" { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "38;2;$r;$g;$b" - } - "rgbb*" { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "48;2;$r;$g;$b" - } - } - } - } - } - # \033 - octal. equivalently \x1b in hex which is more common in documentation - if {![llength $t]} { - return "" ;# a+ nonexistent should return nothing rather than a reset ( \033\[\;m is a reset even without explicit zero(s)) - } - return "\x1b\[[join $t {;}]m" - } - proc = {args} { - #don't disable ansi here. - #we want this to be available to call even if ansi is off - variable SGR_map - set t [list] - foreach i $args { - if {[string is integer -strict $i]} { - lappend t $i - } elseif {[string first ";" $i] >=0} { - #literal with params - lappend t $i - } else { - if {[dict exists $SGR_map $i]} { - lappend t [dict get $SGR_map $i] - } else { - #accept examples for foreground - # 256f-# or 256fg-# or 256f# - # rgbf--- or rgbfg--- or rgbf-- - if {[string match -nocase "256f*" $i]} { - set cc [string trim [string range $i 4 end] -gG] - lappend t "38;5;$cc" - } elseif {[string match -nocase 256b* $i]} { - set cc [string trim [string range $i 4 end] -gG] - lappend t "48;5;$cc" - } elseif {[string match -nocase rgbf* $i]} { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "38;2;$r;$g;$b" - } elseif {[string match -nocase rgbb* $i]} { - set rgb [string trim [string range $i 4 end] -gG] - lassign [split $rgb -] r g b - lappend t "48;2;$r;$g;$b" - } - } - } - } - # \033 - octal. equivalently \x1b in hex which is more common in documentation - # empty list [a=] should do reset - same for [a= nonexistant] - # explicit reset at beginning of parameter list for a= (as opposed to a+) - set t [linsert $t 0 0] - return "\x1b\[[join $t {;}]m" - } - - -} diff --git a/src/modules/shellrun-0.1.1.tm b/src/modules/shellrun-0.1.1.tm index baf95b31..43ba4994 100644 --- a/src/modules/shellrun-0.1.1.tm +++ b/src/modules/shellrun-0.1.1.tm @@ -279,8 +279,8 @@ namespace eval shellrun { } else { set e $::shellrun::runerr } - #append chunk "[a+ red light]$e$RST\n" - append chunk "[a+ red light]$e$RST" + #append chunk "[a+ red normal]$e$RST\n" + append chunk "[a+ red normal]$e$RST" } lappend chunklist [list stderr $chunk] @@ -391,7 +391,7 @@ namespace eval shellrun { } else { set o $::shellrun::runout } - append chunk "[a+ white light]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. + append chunk "[a+ white normal]$o[a]\n" ;#this newline is the display output separator - always there whether data has trailing newline or not. } lappend chunklist [list stdout $chunk] diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 21f5717d..2909add9 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -3254,10 +3254,11 @@ namespace eval textblock { set defaults [dict create\ -return "string"\ -compact 1\ + -forcecolour 0\ ] dict for {k v} $args { switch -- $k { - -return - -compact {} + -return - -compact - -forcecolour {} default { "textblock::periodic unknown option '$k'. Known options: [dict keys $defaults]" } @@ -3265,6 +3266,11 @@ namespace eval textblock { } set opts [dict merge $defaults $args] set opt_return [dict get $opts -return] + if {[dict get $opts -forcecolour]} { + set fc forcecolour + } else { + set fc "" + } #examples ptable.com set elements [list\ @@ -3285,61 +3291,61 @@ namespace eval textblock { set ecat [dict create] set cat_alkaline_earth [list Be Mg Ca Sr Ba Ra] - set ansi [a+ Web-gold web-black] + set ansi [a+ {*}$fc Web-gold web-black] foreach e $cat_alkaline_earth { dict set ecat $e [list ansi $ansi cat alkaline_earth] } set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - set ansi [a+ Web-lightgreen web-black] + set ansi [a+ {*}$fc Web-lightgreen web-black] foreach e $cat_reactive_nonmetal { dict set ecat $e [list ansi $ansi cat reactive_nonmetal] } set cat [list Li Na K Rb Cs Fr] - set ansi [a+ Web-Khaki web-black] + set ansi [a+ {*}$fc Web-Khaki web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat alkali_metals] } set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - set ansi [a+ Web-lightsalmon web-black] + set ansi [a+ {*}$fc Web-lightsalmon web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat transition_metals] } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ Web-lightskyblue web-black] + set ansi [a+ {*}$fc Web-lightskyblue web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat post_transition_metals] } set cat [list B Si Ge As Sb Te At] - set ansi [a+ Web-turquoise web-black] + set ansi [a+ {*}$fc Web-turquoise web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat metalloids] } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ Web-orchid web-black] + set ansi [a+ {*}$fc Web-orchid web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat noble_gases] } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ Web-plum web-black] + set ansi [a+ {*}$fc Web-plum web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat actinoids] } set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - set ansi [a+ Web-tan web-black] + set ansi [a+ {*}$fc Web-tan web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat lanthanoids] } set cat [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] - set ansi [a+ Web-whitesmoke web-black] + set ansi [a+ {*}$fc Web-whitesmoke web-black] foreach e $cat { dict set ecat $e [list ansi $ansi cat other] } @@ -3379,14 +3385,14 @@ namespace eval textblock { if {$opt_return eq "string"} { $t configure -frametype_header light - $t configure -ansiborder_header [a+ web-white] - $t configure -ansibase_header [a+ Web-black] - $t configure -ansibase_body [a+ Web-black] - $t configure -ansiborder_body [a+ web-black] + $t configure -ansiborder_header [a+ {*}$fc web-white] + $t configure -ansibase_header [a+ {*}$fc Web-black] + $t configure -ansibase_body [a+ {*}$fc Web-black] + $t configure -ansiborder_body [a+ {*}$fc web-black] $t configure -frametype block - set output [textblock::frame -ansiborder [a+ Web-black web-cornflowerblue] -type heavy -title "[a+ Web-black] Periodic Table " [$t print]] + set output [textblock::frame -ansiborder [a+ {*}$fc Web-black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Web-black] Periodic Table " [$t print]] return $output } return $t @@ -4247,14 +4253,31 @@ namespace eval textblock { # >} .= {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 red [a+ {*}$fc red]; set redb [a+ {*}$fc red bold] + set green [a+ {*}$fc green]; set greenb [a+ {*}$fc green bold] + set cyan [a+ {*}$fc cyan];set cyanb [a+ {*}$fc cyan bold] + set blue [a+ {*}$fc blue];set blueb [a+ {*}$fc blue bold] set RST [a] set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] set punks [textblock::join $pleft $pright] @@ -4274,7 +4297,7 @@ namespace eval textblock { set spantable [[spantest] print] append out [textblock::join $fancy " " $spantable] \n #append out [textblock::frame -title gr $gr0] - append out [textblock::periodic] + append out [textblock::periodic -forcecolour $opt_forcecolour] return $out } diff --git a/src/modules/winlibreoffice-999999.0a1.0.tm b/src/modules/winlibreoffice-999999.0a1.0.tm index 5e9d180f..5afd6ffe 100644 --- a/src/modules/winlibreoffice-999999.0a1.0.tm +++ b/src/modules/winlibreoffice-999999.0a1.0.tm @@ -18,6 +18,7 @@ ## Requirements ##e.g package require frobz package require uri ;#tcllib +package require punk::lib #windows? REVIEW - can we provide a common api for other platforms with only script? tcluno instead? @@ -90,7 +91,7 @@ namespace eval winlibreoffice { return $fpath } - #this + # proc convertFromUrl {fileuri} { if {[string match "file:/*" $fileuri]} { set finfo [uri::split $fileuri] @@ -136,6 +137,7 @@ namespace eval winlibreoffice { set dt [get_desktop] set doc [$dt loadComponentFromUrl "private:factory/$type" "_blank" 0 ""] ;#doesn't work without final param - empty string seems to work puts "doc title: [$doc Title]" + #title can be set with [$doc settitle "titletext"] return $doc } @@ -160,6 +162,7 @@ namespace eval winlibreoffice { set sheets [$doc getSheets] set s [$sheets getByIndex $idx] puts stdout "Sheet: [$s getName]" + #set name with [$s setName "xxx"] return $s } proc calcsheet_cell_range_by_name {sheet rangename} { @@ -175,8 +178,42 @@ namespace eval winlibreoffice { $cell setPropertyValue {*}$propset #e.g "NumberFormat" 49 # YYYY-MM-DD + + #can also use in this case [$cell NumberFormat] } - + + proc calccell_setCellBackColorRGB {cell rgb} { + set rgb [string trim $rgb #] + set dec [punk::lib::hex2dec $rgb] + $cell setPropertyValue "CellBackColor" [expr {$dec}] ;#colour value must be integer - will fail if string + } + proc calccell_setCharColorRGB {cell rgb} { + set rgb [string trim $rgb #] + set dec [punk::lib::hex2dec $rgb] + $cell setPropertyValue "CharColor" [expr {$dec}] + } + + + #cell charFontName + + #cell charWeight + #com.sun.star.awt.FontWeight + #https://api.libreoffice.org/docs/idl/ref/FontWeight_8idl.html + # values are listed with 6 DPs - but one seems to work + # only setting to normal and bold seem to result in a value (regular & bold) in the format->font style dialog for the cell. + #DONTKNOW 0.0 + #THIN 50.0 + #ULTRALIGHT 60.0 + #LIGHT 75.0 + #SEMILIGHT 90.0 + #NORMAL 100.0 + #SEMIBOLD 110.0 + #BOLD 150.0 + #ULTRABOLD 175.0 + #BLACK 200.0 + + + #a hack #return libreoffice date in days since 1899.. proc date_from_clockseconds_approx {cs} { diff --git a/src/punk86.vfs/lib/app-punk/repl.tcl b/src/punk86.vfs/lib/app-punk/repl.tcl index 420b3540..ee65436e 100644 --- a/src/punk86.vfs/lib/app-punk/repl.tcl +++ b/src/punk86.vfs/lib/app-punk/repl.tcl @@ -134,7 +134,7 @@ foreach pkg $required { } package require punk::repl -repl::start stdin +repl::start stdin -title app-punk diff --git a/src/punk86.vfs/main.tcl b/src/punk86.vfs/main.tcl index 77e23048..fa711bb6 100644 --- a/src/punk86.vfs/main.tcl +++ b/src/punk86.vfs/main.tcl @@ -18,6 +18,8 @@ if {[llength $::argv]} { package require app-shellspy } else { package require app-punk - repl::start stdin + + #app-punk starts repl + #repl::start stdin -title "main.tcl" }