From 27b7695fee339c7bbbefb29a03d27586d0e39350 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 14 Mar 2024 05:53:25 +1100 Subject: [PATCH] punk::ansi work in progress, punk::assertion --- .../#tarjar-loadscript-tarjar.tcl | 2 +- src/modules/flagfilter-0.3.tm | 7 +- src/modules/punk-0.1.tm | 174 ++- src/modules/punk/ansi-999999.0a1.0.tm | 818 +++++++++--- src/modules/punk/args-999999.0a1.0.tm | 2 +- src/modules/punk/assertion-999999.0a1.0.tm | 412 ++++++ src/modules/punk/assertion-buildversion.txt | 3 + src/modules/punk/cap-999999.0a1.0.tm | 2 +- .../cap/handlers/templates-999999.0a1.0.tm | 4 +- src/modules/punk/char-999999.0a1.0.tm | 5 +- src/modules/punk/console-999999.0a1.0.tm | 16 + src/modules/punk/fileline-999999.0a1.0.tm | 8 +- src/modules/punk/lib-999999.0a1.0.tm | 2 +- .../mix/commandset/scriptwrap-999999.0a1.0.tm | 2 +- .../templates/layouts/project/src/make.tcl | 2 +- src/modules/punk/ns-999999.0a1.0.tm | 24 +- src/modules/punk/repl-0.1.tm | 12 +- src/modules/punk/winrun-999999.0a1.0.tm | 2 +- src/testansi/belinda.ans | 100 ++ src/testansi/timebend.ans | 62 + src/vendormodules/overtype-1.6.0.tm | 1160 ++++++++++++----- 21 files changed, 2273 insertions(+), 546 deletions(-) create mode 100644 src/modules/punk/assertion-999999.0a1.0.tm create mode 100644 src/modules/punk/assertion-buildversion.txt create mode 100644 src/testansi/belinda.ans create mode 100644 src/testansi/timebend.ans diff --git a/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl b/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl index dfe7dc99..57927403 100644 --- a/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl +++ b/src/modules/#tarjar-tarjar-2.3/#tarjar-loadscript-tarjar.tcl @@ -1447,7 +1447,7 @@ proc ::tarjar::wrap {scriptfile args} { catch {unset create_args($k)} } - #assert: $versionpart now has a value + #assertion: versionpart now has a value if {![string length [string trim $tm_version]]} { error "Missing value for 'tm_version'" } diff --git a/src/modules/flagfilter-0.3.tm b/src/modules/flagfilter-0.3.tm index d3f7ad7f..d341ac74 100644 --- a/src/modules/flagfilter-0.3.tm +++ b/src/modules/flagfilter-0.3.tm @@ -591,7 +591,8 @@ namespace eval flagfilter { - + #review - should we be using control::assert here? + #It depends if this is intended to raise error at runtime - would using control::assert and disabling assertions cause problems? #todo - show caller info proc assert_equal {a b} { if {![expr {$a eq $b}]} { @@ -1360,7 +1361,7 @@ namespace eval flagfilter { } } - #assert - should be none? + #assertion - should be none? #set remaining_values [lrange $source_values $a_index end] #do_debug 3 $debugc "-------->________>end of processing - remaining vals $remaining_values" @@ -2138,7 +2139,7 @@ namespace eval flagfilter { } } - set classifications [dict get $processed_arguments classifications] ;#assert - ordered by numerically increasing key representing positions in supplied argument list + set classifications [dict get $processed_arguments classifications] ;#assertion - ordered by numerically increasing key representing positions in supplied argument list set rangesets [$RETURNED_VMAP get_ranges_from_classifications $classifications] set ranges [dict get $rangesets -ranges] set rangesbytype [dict get $rangesets -rangesbytype] ;#unallocated are split into flag,operand and endofoptions - further splitting is easy enough to do by looking up the classifications list for each position in the supplied arg list. diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index fa4e6625..c4fb6b4c 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -88,6 +88,20 @@ package require punk::du package require punk::mix::base namespace eval punk { + # -- --- --- + #namespace import ::control::assert ;#according to tcllib doc - assert can be enabled/disabled per namespace + # using control::control assert enabled within a namespace for which ::control::assert wasn't imported can produce surprising results. + #e.g setting to zero may keep asserts enabled - (e.g if the assert command is still available due to namespace path etc) - but.. querying the enabled status may show zero even in the parent namespace where asserts also still work. + #package require control + #control::control assert enabled 1 + + #We will use punk::assertion instead + + package require punk::assertion + namespace import ::punk::assertion::assert + punk::assertion::active on + # -- --- --- + interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system if {[catch { package require pattern @@ -97,9 +111,7 @@ namespace eval punk { package require shellfilter package require punkapp package require funcl - package require control - control::control assert enabled 1 - namespace import ::control::assert + package require struct::list package require fileutil #package require punk::lib @@ -133,8 +145,153 @@ namespace eval punk { debug header "dbg> " + if {"::lremove" ne [info commands ::lremove]} { + puts stderr "Warning - no built-in lremove" + proc ::lremove {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lsearch -all -inline -index 1 -subindices $keep *] + } + #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers + proc ::lremove2 {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lmap v $keep {lindex $v 1}] + } + #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 - and even in 8.7 it doesn't seem to allow returning one index of the stridden 'group' + } + if {"::lpop" ne [info commands ::lpop]} { + puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lpop + } + proc lpop {lvar args} { + upvar $lvar l + if {![llength $args]} { + set args [list end] + } + set v [lindex $l {*}$args] + set newlist $l + set path [list] + set subl $l + for {set i 0} {$i < [llength $args]} {incr i} { + set idx [lindex $args $i] + if {![llength [lrange $subl $idx $idx]]} { + error "tcl_lpop index \"$idx\" out of range" + } + #if {[list_index_get $subl $idx] == -1} { + # error "tcl_lpop index \"$idx\" out of range" + #} + lappend path [lindex $args $i] + set subl [lindex $l {*}$path] + } + set sublist_path [lrange $args 0 end-1] + set tailidx [lindex $args end] + if {![llength $sublist_path]} { + #set newlist [lremove $newlist $tailidx] + set newlist [lreplace $newlist $tailidx $tailidx] + } else { + set sublist [lindex $newlist {*}$sublist_path] + #set sublist [lremove $sublist $tailidx] + set sublist [lreplace $sublist $tailidx $tailidx] + lset newlist {*}$sublist_path $sublist + } + #puts "[set l] -> $newlist" + set l $newlist + return $v + } + proc list_index_resolve {list index} { + #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr + if {![llength $list]} { + return -1 + } + set index [string map [list _ ""] $index] ;#forward compatibility with integers such as 1_000 + if {[string is integer -strict $index]} { + #can match +i -i + if {$index < 0} { + return -1 + } elseif {$index >= [llength $list]} { + return -1 + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } else { + if {[string match end* $index]} { + if {$index ne "end"} { + set op [string index $index 3] + set offset [string range $index 4 end] + if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} + if {$op eq "+" && $offset != 0} { + return -1 + } + } else { + set offset 0 + } + #by now, if op = + then offset = 0 so we only need to handle the minus case + if {$offset == 0} { + set index [expr {[llength $list]-1}] + } else { + set index [expr {([llength $list]-1) - $offset}] + } + if {$index < 0} { + return -1 + } else { + return $index + } + } else { + #plain +- already handled above. + #we are trying to avoid evaluating unbraced expr of potentially insecure origin + if {[regexp {(.*)([+-])(.*)} $index _match a op b]} { + if {[string is integer -strict $a] && [string is integer -strict $b]} { + if {$op eq "-"} { + set index [expr {$a - $b}] + } else { + set index [expr {$a + $b}] + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + if {$index < 0 || $index >= [llength $list]} {return -1} + return $index + } + } + } + proc list_index_resolve2 {list index} { + set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. + for {set i 0} {$i < [llength $list]} {incr i} { + lappend indices $i + } + set idx [lindex $indices $index] + if {$idx eq ""} { + return -1 + } else { + return $idx + } + } + proc list_index_get {list index} { + set resultlist [lrange $list $index $index] + if {![llength $resultlist]} { + return -1 + } else { + #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. + #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator + return [dict create value [lindex $resultlist 0]] + } + } variable last_run_display [list] @@ -2179,7 +2336,7 @@ namespace eval punk { set returnval "" set i 0 - #assert i incremented at each continue and at each end of loop - at end i == list length + 1 + #assertion i incremented at each continue and at each end of loop - at end i == list length + 1 #always use 'assigned' var in each loop # (for consistency and to assist with returnval) # ^var means a pinned variable - compare value of $var to rhs - don't assign @@ -2222,7 +2379,7 @@ namespace eval punk { #For booleans the final val may later be normalised to 0 or 1 - #assert all var_actions were set with leading question mark + #assertion all var_actions were set with leading question mark #perform assignments only if matched ok debug.punk.pipe.var {VAR_CLASS: $var_class} 5 @@ -2709,13 +2866,13 @@ namespace eval punk { } default { set first_bound [lsearch -index 0 $var_actions $varname] - #assert first_bound >=0, we will always find something - usually self + #assertion first_bound >=0, we will always find something - usually self if {$first_bound == $i} { lset match_state $i 1 lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs" lhs - rhs $val] } else { - #assert - first_bound < $i + assert {$first_bound < $i} assertion_fail: _multi_bind_result condition: [list $first_bound < $i] set expectedinfo [lindex $expected_values $first_bound] set expected_earlier [dict get $expectedinfo rhs] if {$expected_earlier ne $val} { @@ -2856,8 +3013,7 @@ namespace eval punk { #var_name entries can be blank - but it will still be a list dict set returndict result $data } else { - #punk::assert {$i == [llength $var_names]} - + assert {$i == [llength $var_names]} assertion_fail _multi_bind_result condition {$i == [llength $var_names]} dict set returndict result $returnval } return $returndict diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index c47e2912..933f55ac 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -50,6 +50,7 @@ package require Tcl 8.6- package require punk::char +package require punk::assertion #*** !doctools #[item] [package {Tcl 8.6-}] #[item] [package {punk::char}] @@ -69,6 +70,7 @@ package require punk::char namespace eval punk::ansi::class { if {![llength [info commands class_ansi]]} { + oo::class create class_ansi { variable o_ansistringobj @@ -87,7 +89,7 @@ namespace eval punk::ansi::class { set o_render_dimensions $dimensions set o_ansistringobj [ansistring NEW $ansitext] } - method rawdata {} { + method get {} { return [$o_ansistringobj get] } method render {{dimensions ""}} { @@ -105,8 +107,8 @@ 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 -appendlines 1 $b [$o_ansistringobj get]] - set o_rendered [overtype::left -overflow 0 -wrap 1 -width 80 -appendlines 1 "" [$o_ansistringobj get]] + #set o_rendered [overtype::left -overflow 0 -wrap 1 -appendlines 1 $b [$o_ansistringobj GET]] + set o_rendered [overtype::left -overflow 0 -wrap 1 -width $w -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] @@ -119,6 +121,54 @@ namespace eval punk::ansi::class { #todo - store rendered and allow partial rendering of new data lines? return $o_rendered } + method rendertest {{dimensions ""}} { + if {$dimensions eq ""} { + set dimensions $o_render_dimensions + } + if {![regexp {^([0-9]+)[xX]([0-9]+)$} $dimensions _m w h]} { + error "class_ansi::render dimensions must be of the form x" + } + set o_dimensions $dimensions + + + set rendered [overtype::left -experimental {test_mode} -overflow 0 -wrap 1 -width $w -appendlines 1 "" [$o_ansistringobj get]] + return $rendered + } + method render_to_input_line {x {minuschar 0}} { + set lfvis [ansistring VIEW -lf 1 \n] + set maplf [list \n "[a+ green bold reverse]${lfvis}[a]\n"] ;#a mapping to highlight newlines + + set lines [split [$o_ansistringobj get] \n] + set rlines [lrange $lines 0 $x] + set chunk [::join $rlines \n] + append chunk \n + if {$minuschar ne "0"} { + set chunk [string range $chunk 0 end-$minuschar] + } + set rendered [overtype::left -experimental {test_mode} -overflow 0 -wrap 1 -width 80 -appendlines 1 "" $chunk] + set marker "" + for {set i 1} {$i <= 80} {incr i} { + if {$i % 10 == 0} { + ::append marker "|" + } elseif {$i % 5 == 0} { + ::append marker * + } else { + ::append marker "." + } + } + ::append rendered \n $marker + set xline [lindex $rlines $x]\n + set xlinev [ansistring VIEWSTYLE $xline] + set xlinev [string map $maplf $xlinev] + set xlinedisplay [overtype::left -wrap 1 -width 80 "" $xlinev] + ::append rendered \n $xlinedisplay + + set chunk [ansistring VIEWSTYLE $chunk] + set chunk [string map $maplf $chunk] + set chunkdisplay [overtype::left -wrap 1 -width 80 "" $chunk] + textblock::join $rendered $chunkdisplay + } + method checksum {} { return [$o_ansistringobj checksum] } @@ -138,11 +188,16 @@ namespace eval punk::ansi::class { method viewstyle {} { return [ansistring VIEWSTYLE [$o_ansistringobj get]] } - method append {ansistring} { + method append_noreturn {ansistring} { $o_ansistringobj append $ansistring #don't return the raw data - it may be big and probably won't play nicely with default terminal dimensions etc. return } + #like Tcl append - returns the result + #Tcl's append changes a variable state, this changes the object state + method append {ansistring} { + $o_ansistringobj append $ansistring + } } } @@ -156,6 +211,46 @@ namespace eval punk::ansi { #[para] Core API functions for punk::ansi #[list_begin definitions] + #old-school ansi graphics - C0 control glyphs. + variable cp437_map + #for cp437 images we need to map these *after* splitting ansi, to single-width unicode chars + #It would also probably be problematic to map \u000A to the glyph - as this is the newline - it included in the map anyway for completeness. The caller may have to manually carve that or other specific c0 controls out of the map to use it depending on the situation(?) + #Layout for cp437 won't be right if you don't at least set width of control-chars to 1 - but also some images specifically use these glyphs + #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too + #by mapping these we can display regardless. + #nul char - no cp437 image. (which is good - because we use nul as a filler to mean empty column in overtype rendering) + dict set cp437_map \u0001 \u263A ;#smiley + dict set cp437_map \u0003 \u263B ;#smiley-filled + dict set cp437_map \u0003 \u2665 ;#heart + dict set cp437_map \u0004 \u2666 ;#diamond + dict set cp437_map \u0005 \u2663 ;#club + dict set cp437_map \u0006 \u2660 ;#spade + dict set cp437_map \u0007 \u2022 ;#dot + dict set cp437_map \u0008 \u25D8 ;#square hollow dot + dict set cp437_map \u0009 \u25CB ;#hollow dot + dict set cp437_map \u000A \u25D9 ;#square and dot (\n) + dict set cp437_map \u000B \u2642 ;#male + dict set cp437_map \u000C \u2640 ;#female + dict set cp437_map \u000D \u266A ;#note1 (\r) + dict set cp437_map \u000E \u266B ;#note2 + dict set cp437_map \u000F \u263C ;#sun + dict set cp437_map \u0010 \u25BA ;#right arrow triangle + dict set cp437_map \u0011 \u25CA ;#left arrow triangle + dict set cp437_map \u0012 \u2195 ;#updown arrow + dict set cp437_map \u0013 \u203C ;#double bang + dict set cp437_map \u0014 \u00B6 ;#pilcrow (paragraph mark / blind P) + dict set cp437_map \u0015 \u00A7 ;#Section Sign + dict set cp437_map \u0016 \u25AC ;#Heavy horizontal? + dict set cp437_map \u0017 \u21A8 ;#updown arrow 2 ? + dict set cp437_map \u0018 \u2191 ;#up arrow + dict set cp437_map \u0019 \u2193 ;#down arrow + dict set cp437_map \u001A \u2192 ;#right arrow + dict set cp437_map \u001B \u2190 ;#left arrow + dict set cp437_map \u001C \u221F ;#bottom left corner + dict set cp437_map \u001D \u2194 ;#left-right arrow + dict set cp437_map \u001E \u25B2 ;#up arrow triangle + dict set cp437_map \u001F \u25BC ;#down arrow triangle + #see also ansicolor page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control @@ -205,22 +300,34 @@ namespace eval punk::ansi { #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? + #In testing old ansi graphics files available on the web, some files need encoding {utf-8 cp437} some just cp437 proc readfile {fname {encoding cp437}} { #todo #1- look for BOM - read according to format given by BOM #2- assume utf-8 #3- if errors - assume cp437? - set ansidata [fcat -encoding $encoding $fname] - set obj [punk::ansi::class::class_ansi new $ansidata] + if {[llength $encoding] == 1} { + set ansidata [fcat -encoding $encoding $fname] + set obj [punk::ansi::class::class_ansi new $ansidata] + } elseif {[llength $encoding] == 2} { + set ansidata [fcat -encoding [lindex $encoding 0] $fname] + set ansidata [encoding convertfrom [lindex $encoding 1] $ansidata] + set obj [punk::ansi::class::class_ansi new $ansidata] + } else { + error "encoding list '$encoding' not supported. Use 1 or 2 encodings (first for file read, second as encoding convertfrom)" + } return $obj } proc ansicat {fname args} { set encnames [encoding names] set encoding "" set dimensions "" + set test_mode 0 foreach a $args { - if {$a in $encnames} { + if {$a eq "test_mode"} { + set test_mode 1 + } elseif {$a in $encnames} { set encoding $a } else { if {[regexp {[0-9]+(?:x|X)[0-9]+} $a]} { @@ -231,20 +338,29 @@ namespace eval punk::ansi { if {$encoding eq ""} { set encoding cp437 } + if {$dimensions eq ""} { set dimensions 80x26 } set ansidata [fcat -encoding $encoding $fname] set obj [punk::ansi::class::class_ansi new $ansidata] - $obj render $dimensions + if {$test_mode} { + set result [$obj rendertest $dimensions] + } else { + set result [$obj render $dimensions] + } + $obj destroy + return $result } #utf-8/ascii encoded cp437 proc ansicat2 {fname {encoding utf-8}} { set data [fcat -encoding $encoding $fname] set ansidata [encoding convertfrom cp437 $data] set obj [punk::ansi::class::class_ansi new $ansidata] - $obj render + set result [$obj render] + $obj destroy + return $result } proc is_utf8_char {char} { regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) @@ -1006,8 +1122,13 @@ namespace eval punk::ansi { #tput rmam return \x1b\[?7l } - #DECRQM to query line-wrap state - # \x1b\[?7\$p + proc query_mode_line_wrap {} { + #*** !doctools + #[call [fun query_mode_line_wrap]] + #[para] DECRQM to query line-wrap state + #[para] The punk::ansi::query_mode_ functions just emit the ansi query sequence. + return \x1b\[?7\$p + } #DECRPM responses e.g: # \x1b\[?7\;1\$y # \x1b\[?7\;2\$y @@ -1274,6 +1395,8 @@ namespace eval punk::ansi { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- #with thanks to Helmut Giese and other Authors of tcllib textutil #this version is adjusted to handle ANSI SGR strings + #TODO! ANSI aware version + proc untabifyLine { line num } { variable Spaces @@ -2047,8 +2170,109 @@ namespace eval punk::ansi::ta { } # -- --- --- --- --- --- --- --- --- --- --- namespace eval punk::ansi::class { + #assertions specifically for punk::ansi::class namespace + namespace import ::punk::assertion::assert + punk::assertion::active 1 + + namespace eval renderer { + oo::class create base_renderer { + variable o_width o_wrap o_overflow o_appendlines o_looplimit + + variable o_cursor_column o_cursor_row + #variable o_render_index ;#index of input (from_ansistring) grapheme/ansi-code that *has* been rendered + variable o_rendereditems + + variable o_from_ansistring o_to_ansistring + variable o_ns_from o_ns_to ;#some dirty encapsulation violation as a 'friend' of ansistring objects - direct record of namespaces as they are frequently accessed + constructor {args} { + if {[llength $args] < 2} { + error {usage: ?-width ? ?-wrap [1|0]? ?-overflow [1|0]? from_ansistring to_ansistring} + } + lassign [lrange $args end-1 end] from_ansistring to_ansistring + set defaults [dict create\ + -width \uFFEF\ + -wrap 1\ + -overflow 0\ + -appendlines 1\ + -looplimit 15000\ + -experimental {}\ + -cursor_column 1\ + -cursor_row 1\ + ] + puts "[info object class [self]] renderer [self] constructor from ansistring $from_ansistring to ansistring $to_ansistring" + set argsflags [lrange $args 0 end-2] + dict for {k v} $argsflags { + switch -- $k { + -width - -wrap - -overflow - -appendlines - -looplimit - -experimental {} + default { + set known_opts [dict keys $defaults] + #don't use [self class] - or we'll get the superclass + error "[info object class [self]] unknown option '$k'. Known options: $known_opts" + } + } + } + set opts [dict merge $defaults $argsflags] + set o_width [dict get $opts -width] + set o_wrap [dict get $opts -wrap] + set o_overflow [dict get $opts -overflow] + set o_appendlines [dict get $opts -appendlines] + set o_looplimit [dict get $opts -looplimit] + set o_cursor_column [dict get $opts -cursor_column] + set o_cursor_row [dict get $opts -cursor_row] + + set o_from_ansistring $from_ansistring + set o_ns_from [info object namespace $o_from_ansistring] + set o_to_ansistring $to_ansistring + set o_ns_to [info object namespace $o_to_ansistring] + #set o_render_index -1 ;#zero based. -1 indicates nothing yet rendered. + set o_rendereditems [list] ;#graphemes + controls + individual ansi codes from input $o_from_ansistring + } + #temporary test method + method eval_in {script} { + eval $script + } + method cursor_column {{col ""}} { + if {$col eq ""} { + return $o_cursor_column + } + if {$col < 1} { + error "Minimum cursor_column is 1" + } + set o_cursor_column $col + } + method cursor_row {{row ""}} { + if {$row eq ""} { + return $o_cursor_row + } + if {$row < 1} { + error "Minimum cursor_row is 1" + } + set o_cursor_row $row + } + method rendernext {} { + upvar ${o_ns_from}::o_ansisplits from_ansisplits + upvar ${o_ns_from}::o_elements elements + + if {![llength $from_ansisplits]} {$o_from_ansistring eval_in {my MakeSplit}} ;#!!todo - a better way to keep this method semi hidden but call from a 'friend' + set elements_unrendered [expr {[llength $elements] - [llength $o_rendereditems]}] + #we need to render in pt code chunks - not each grapheme element individually + #translate from element index to ansisplits index? + + return [dict create count_unrendered $elements_unrendered] + } + + } + #name all with prefix class_ for rendertype detection + oo::class create class_cp437 { + superclass base_renderer + } + oo::class create class_editbuf { + superclass base_renderer + } + } #As this is intended for column-based terminals - it has a different notion of string length, string index etc than for a plain string. + #oo names beginning with uppercase are private - so we can't use capitalisation as a hint to distinguish those which differ from Tcl semantics oo::class create class_ansistring { variable o_cksum_command variable o_string @@ -2059,8 +2283,23 @@ namespace eval punk::ansi::class { variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes variable o_ansisplits ;#store our plaintext/ansi-code splits so we don't keep re-running the regexp to split + + #State regarding output renderstring (if any) + variable o_renderout ;#another class_ansistring instance + variable o_renderer ;# punk::ansi::class::renderer::class_ instance + variable o_renderwidth + variable o_rendertype + + variable o_elements o_sgrstacks ;#elements contains entry for each grapheme/control + each ansi code, stacks has list of ansi sgr codes + variable o_gx0states + constructor {string} { set o_string $string + set nspath [namespace path] + if {"::punk::ansi::class" ni $nspath} { + lappend nspath ::punk::ansi::class + } + namespace path $nspath #we choose not to generate an internal split-state for the initial string - which may potentially be large. #there are a few methods such as get, has_ansi, show_state,checksum that can run efficiently on the initial string without generating it. @@ -2072,6 +2311,21 @@ namespace eval punk::ansi::class { #o_ansisplits and o_ptlist should only remain empty if an empty string was passed to the contructor, or no methods have yet triggered the initial string to have it's internal state built. set o_cksum_command [list sha1::sha1 -hex] + + + #empty if no render methods used + # -- + set o_renderer "" + set o_renderout "" ;#class_ansistring + # -- + + set o_renderwidth 80 + set o_rendertype cp437 + } + + #temporary test method + method eval_in {script} { + eval $script } method checksum {} { if {[catch { @@ -2085,7 +2339,7 @@ namespace eval punk::ansi::class { method show_state {{verbose 0}} { #show some state info - without updating anything - #only use 'my' methods that don't update the state e.g has_ansi + #only use 'my' methods that don't update the state e.g has_ansi set result "" if {![llength $o_ansisplits]} { append result "No internal splits. " @@ -2105,6 +2359,15 @@ namespace eval punk::ansi::class { append result \n -------------------------------------------------- } } + if {$o_renderer ne ""} { + append result \n " renderer obj: $o_renderer" + append result \n " renderer class: [info object class $o_renderer]" + } + if {$o_renderout ne ""} { + append result \n " render target ansistring: $o_renderout" + append result \n " render target has ansi : [$o_renderout has_ansi]" + append result \n " render target count : [$o_renderout count]" + } if {$verbose} { append result \n "ansisplits listing" #we will use a foreach with a single var rather than foreach {pt code} - so that if something goes wrong it's clearer. @@ -2123,12 +2386,54 @@ namespace eval punk::ansi::class { } return $result } + + #private method method MakeSplit {} { #The split with each code as it's own element is more generally useful. set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; set o_ptlist [list] - foreach {pt _code} $o_ansisplits { + set codestack [list] + set gx0_state 0 ;#default off + foreach {pt code} $o_ansisplits { lappend o_ptlist $pt + foreach grapheme [punk::char::grapheme_split $pt] { + lappend o_elements [list g $grapheme] + lappend o_sgrstacks $codestack + lappend o_gx0states $gx0_state + } + if {$code ne ""} { + lappend o_sgrstacks $codestack + lappend o_gx0states $gx0_state + + #maintenance warning - dup in append! + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] + lappend o_elements [list sgr $code] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + lappend o_elements [list sgr $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + lappend o_elements [list sgr $code] + } else { + if {[punk::ansi::codetype::is_gx_open $code]} { + set gx0_state 1 + lappend o_elements [list gx0 1] ;#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 gx0_state 0 + lappend o_elements [list gx0 0] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } else { + lappend o_elements [list other $code] + } + } + } + #assertion every grapheme and every individual code has been added to o_elements + #every element has an entry in o_sgrstacks + #every element has an entry in o_gx0states + assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states]} } } method convert_altg {} { @@ -2155,7 +2460,7 @@ namespace eval punk::ansi::class { return [string length [regsub -all $re_diacritics $plaintext ""]] } - #This is the count of visible graphems + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! + #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! method count {} { if {$o_count eq ""} { #only initial string present @@ -2182,6 +2487,90 @@ namespace eval punk::ansi::class { } return [string length [join $o_ptlist ""]] } + method length_raw {} { + return [string length $o_string] + } + + #channels for stream in/out.. these are vaguely analogous to the input/output between a shell and a PTY Slave - but this is not intended to be a full pseudoterminal + #renderstream_to_render (private?) + # write end held by outer ansistring? read end by inner render ansistring ? + #renderstream_from_render (public?) + + method rendertypes {} { + set classes [info commands ::punk::ansi::class::renderer::class_*] + #strip off class_ + set ctypes [lmap v $classes {string range [namespace tail $v] 6 end}] + } + method rendertype {{rtype ""}} { + if {$rtype eq ""} { + return $o_rendertype + } + set rtypes [my rendertypes] + if {$rtype ni $rtypes} { + error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" + } + if {$o_renderout eq ""} { + #tell ansistring that it's a renderbuf for another ansistring? point it to the renderer or the parent ansistring? + set o_renderout [punk::ansi::class::class_ansistring new ""] + } + if {$o_renderer ne ""} { + set oinfo [info object class $o_renderer] + set tail [namespace tail $oinfo] + set currenttype [string range $tail 6 end] + if {$rtype ne $currenttype} { + puts "switch rendertype from $currenttype to $rtype - destroying renderer and creating a new one" + $o_renderer destroy ;#what happens to data in target ansistring obj? when does it make sense to keep output and keep rendering vs clearing? + set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout] + } else { + return $currenttype + } + } else { + puts "creating first renderer" + set o_renderer [punk::ansi::class::renderer::class_$rtype new [self] $o_renderout] + } + } + #--- progressive rendering buffer - another ansistring object + method renderwidth {{rw ""}} { + #report or set the renderwidth - may invalidate existing render progress? restart? + if {$rw eq ""} { + return $o_renderwidth + } + if {$rw eq $o_renderwidth} { + return $o_renderwidth + } + #re-render if needed? + + + set o_renderwidth $rw + } + method render_state {} { + #? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary + #but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split. + #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work + } + method renderbuf {} { + #get the underlying renderobj - if any + return $o_renderout ;#also class_ansistring + } + method render {} { + #full render - return buffer ansistring + } + method rendernext {} { + #render next available pt/code chunk only - not to end of available input + if {$o_renderer eq ""} { + my rendertype $o_rendertype ;#review - proper way to initialise rendering + } + $o_renderer rendernext + } + method render_cursorstate {{row_x_col ""}} { + #report /set? cursor posn + if {$o_renderer eq ""} { + error "No renderer. Call render methods first" + } + return [dict create row [$o_renderer cursor_row] column [$o_renderer cursor_column]] + } + #--- + method get {} { return $o_string } @@ -2194,6 +2583,13 @@ namespace eval punk::ansi::class { return [expr {[llength $o_ansisplits] != 1}] } } + #todo - has_ansi_movement ? + #If an arbirary ANSI string has movement/cursor restore - then the number of apparent rows in the input will potentially bear no relation to the number of lines of output. + #i.e a 'rendered' ANSI string should contain just ANSI SGR character attributes and linefeeds for rows + #Knowing which is which can be helpful as far as use of any methods which use the concepts of terminal row/column + + #analagous to Tcl string append + #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient method append {args} { set catstr [join $args ""] if {$catstr eq ""} { @@ -2213,12 +2609,19 @@ namespace eval punk::ansi::class { #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits #even though we can use lset to add to a list - we can't for empty lappend o_ptlist $catstr - #assert - if o_ptlist is empty so is o_ansisplits + #assertion - if o_ptlist is empty so is o_ansisplits lappend o_ansisplits $catstr } else { lset o_ptlist end [string cat [lindex $o_ptlist end] $catstr] lset o_ansisplits end [string cat [lindex $o_ansisplits end] $catstr] } + set last_codestack [lindex $o_sgrstacks end] + set last_gx0state [lindex $o_gx0states end] + foreach grapheme [punk::char::grapheme_split $catstr] { + lappend o_elements [list g $grapheme] + lappend o_sgrstacks $last_codestack + lappend o_gx0states $last_gx0state + } incr o_count [my DoCount $catstr] } else { if {![llength $o_ansisplits]} { @@ -2227,23 +2630,217 @@ namespace eval punk::ansi::class { my MakeSplit set combined_plaintext [join $o_ptlist ""] set o_count [my DoCount $combined_plaintext] + assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states]} return $o_string } else { #update each element of internal state incrementally without reprocessing what is already there. append o_string $catstr set newsplits [punk::ansi::ta::split_codes_single $catstr] set ptnew "" + set codestack [lindex $o_sgrstacks end] + set gx0_state [lindex $o_gx0states end] foreach {pt code} $newsplits { lappend o_ptlist $pt append ptnew $pt + foreach grapheme [punk::char::grapheme_split $catstr] { + lappend o_elements [list g $grapheme] + lappend o_sgrstacks $codestack + lappend o_gx0states $gx0_state + } + if {$code ne ""} { + lappend o_sgrstacks $codestack + lappend o_gx0states $gx0_state + #maintenance - dup in MakeSplit! + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] + lappend o_elements [list sgr $code] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + lappend o_elements [list sgr $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $codestack $code] ;#must be -exact because of square-bracket glob chars + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + lappend o_elements [list sgr $code] + } else { + if {[punk::ansi::codetype::is_gx_open $code]} { + set gx0_state 1 + lappend o_elements [list gx0 1] ;#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 gx0_state 0 + lappend o_elements [list gx0 0] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } else { + lappend o_elements [list other $code] + } + } + } } lset o_ansisplits end [string cat [lindex $o_ansisplits end] [lindex $newsplits 0]] lappend o_ansisplits {*}[lrange $newsplits 1 end] incr o_count [my DoCount $ptnew] } } + assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states]} return $o_string } + #method append_and_render - append and render up to end of appended data at same time + + method view {args} { + if {$o_string eq ""} { + return "" + } + #ansistring VIEW relies only on the raw ansi input as it is essentially just a string map. + #We don't need to force an ansisplit if we happen to have an unsplit initial string + ansistring VIEW $o_string + } + method viewcodes {args} { + if {$o_string eq ""} { + return "" + } + if {![llength $o_ansisplits]} {my MakeSplit} + + set redb [a+ red bold] ;#osc/apm ? anything with potential security risks or that is unusual + set greenb [a+ green bold] ;#SGR + set cyanb [a+ cyan bold] ;#col,row movement + set blueb [a+ blue bold] ;# + set blueb_r [a+ blue bold reverse] + set whiteb [a+ white bold] ;#SGR reset (or highlight first part if leading reset) + set GX [a+ black White bold] ;#alt graphics + set unk [a+ yellow bold] ;#unknown/unhandled + set RST [a] + + set re_col_move {\x1b\[([0-9]*)(C|D|G)$} + set re_row_move {\x1b\[([0-9]*)(A|B)$} + set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} + set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} + set re_cursor_save {\x1b\[s$} + set re_cursor_restore {\x1b\[u$} + set re_cursor_save_dec {\x1b7$} + set re_cursor_restore_dec {\x1b8$} + + set arrow_left \u2190 + set arrow_right \u2192 + set arrow_up \u2191 + set arrow_down \u2193 + set arrow_lr \u2194 + set arrow_du \u2195 + #2024 - there is no 4-arrow symbol or variations (common cursor and window icon) in unicode - despite requests and argument from the community that this has been in use for decades. + #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. + + #don't split into lines first - \n is valid within ST sections + set output "" + #set splits [punk::ansi::ta::split_codes_single $string] + + foreach {pt code} $o_ansisplits { + append output [ansistring VIEW {*}$args $pt] + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set displaycode [ansistring VIEW $code] + append output ${whiteb}$displaycode$RST + } elseif {[punk::ansi::codetype::is_gx_open $code]} { + append output ${GX}GX+$RST + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + append output ${GX}GX-$RST + } elseif {[punk::ansi::codetype::is_sgr $code]} { + set displaycode [ansistring VIEW $code] + if {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + #highlight the esc & leftbracket in white as indication there is a leading reset + set cposn [string first ";" $displaycode] + append output ${whiteb}[string range $displaycode 0 $cposn]$RST${greenb}[string range $displaycode $cposn+1 end]$RST + } else { + append output ${greenb}$displaycode$RST + } + } else { + switch -regexp -matchvar matchinfo -- $code\ + $re_row_move { + set displaycode [ansistring VIEW $code] + set displaycode [string map [list A "A$arrow_up" B "B$arrow_down"] $displaycode] + append output ${cyanb}$displaycode$RST + }\ + $re_col_move { + lassign $matchinfo _match num type + set displaycode [ansistring VIEW $code] + set displaycode [string map [list C "C$arrow_right" D "D$arrow_left" G "G$arrow_lr"] $displaycode] + append output ${cyanb}$displaycode$RST + }\ + $re_both_move { + lassign $matchinfo _match row col + set displaycode [ansistring VIEW $code] + if {$col eq ""} { + #row only move + set map [list H "H${arrow_lr}"] + } else { + #row and col move + set map [list H "H${arrow_lr}${arrow_du}"] + } + set displaycode [string map $map $displaycode] + append output ${cyanb}$displaycode$RST + }\ + $re_cursor_save -\ + $re_cursor_save_dec { + append output ${blueb}[ansistring VIEW $code]$RST + }\ + $re_cursor_restore -\ + $re_cursor_restore_dec { + append output ${blueb_r}[ansistring VIEW $code]$RST + }\ + default { + #if the code is a PM (or other encapsulation type code e.g terminated by ST) we want to see linefeeds as visual representation character + append output ${unk}[ansistring VIEW -lf 1 $code]$RST + } + + } + } + return $output + } + + method viewstyle {args} { + if {$o_string eq ""} { + return "" + } + if {![llength $o_ansisplits]} {my MakeSplit} + + #set splits [punk::ansi::ta::split_codes_single $string] + set output "" + set codestack [list] + set gx_stack [list] ;#not actually a stack + set cursor_saved "" + foreach {pt code} $o_ansisplits { + if {[llength $args]} { + set pt [ansistring VIEW {*}$args $pt] + } + append output [punk::ansi::codetype::sgr_merge_list {*}$codestack]$pt + if {$code ne ""} { + append output [a][ansistring VIEW -lf 1 $code] + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } elseif {[punk::ansi::codetype::is_sgr $code]} { + #basic simplification first.. straight dups + set dup_posns [lsearch -all -exact $codestack $code] ;#-exact because of square-bracket glob chars + #lremove not present in pre 8.7! + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } elseif {[regexp {\x1b7|\x1b\[s} $code]} { + #cursor_save + set cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$codestack] + } elseif {[regexp {\x1b8|\x1b\[u} $code]} { + #cursor_restore + set codestack [list $cursor_saved] + } else { + #leave SGR stack as is + if {[punk::ansi::codetype::is_gx_open $code]} { + set gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + set gx_stack [list] + } + } + } + } + return $output + + } } } namespace eval punk::ansi::ansistring { @@ -2256,7 +2853,7 @@ namespace eval punk::ansi::ansistring { namespace path [list ::punk::ansi ::punk::ansi::ta] namespace ensemble create - namespace export length trim trimleft trimright index COUNT VIEW VIEWCODES VIEWSTYLE INDEXABSOLUTE INDEXCOLUMNS COLUMNINDEX NEW + namespace export length trim trimleft trimright INDEX COUNT VIEW VIEWCODES VIEWSTYLE INDEXABSOLUTE INDEXCOLUMNS COLUMNINDEX NEW #todo - expose _splits_ methods so caller can work efficiently with the splits themselves #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single @@ -2623,142 +3220,32 @@ namespace eval punk::ansi::ansistring { #test of ISO2047 - 7bit - limited set, limited support, somewhat obscure glyphs #return [string map [list \033 \U2296 \007 \U237E] $string] } + + #The implementation of viewcodes,viewstyle is more efficiently done in an object for the case where repeated calls of various methods can re-use the internal splits. + #for oneshots here - there is only minor overhead to use and destroy the object here. proc VIEWCODES {args} { set string [lindex $args end] - set arglist [lrange $args 0 end-1] - if {$string eq ""} { return "" } - set redb [a+ red bold] ;#osc/apm ? anything with potential security risks or that is unusual - set greenb [a+ green bold] ;#SGR - set cyanb [a+ cyan bold] ;#col,row movement - set blueb [a+ blue bold] ;# - set blueb_r [a+ blue bold reverse] - set whiteb [a+ white bold] ;#SGR reset (or highlight first part if leading reset) - set GX [a+ black White bold] ;#alt graphics - set unk [a+ yellow bold] ;#unknown/unhandled - set RST [a] - - set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - set re_row_move {\x1b\[([0-9]*)(A|B)$} - set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} - set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - set re_cursor_save {\x1b\[s$} - set re_cursor_restore {\x1b\[u$} - set re_cursor_save_dec {\x1b7$} - set re_cursor_restore_dec {\x1b8$} - - set arrow_left \u2190 - set arrow_right \u2192 - set arrow_up \u2191 - set arrow_down \u2193 - set arrow_lr \u2194 - set arrow_du \u2195 - #2024 - there is no 4-arrow symbol or variations (common cursor and window icon) in unicode - despite requests and argument from the community that this has been in use for decades. - #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. - - #don't split into lines first - \n is valid within ST sections - set output "" - set splits [punk::ansi::ta::split_codes_single $string] - foreach {pt code} $splits { - append output [ansistring VIEW {*}$arglist $pt] - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set displaycode [ansistring VIEW $code] - append output ${whiteb}$displaycode$RST - } elseif {[punk::ansi::codetype::is_gx_open $code]} { - append output ${GX}GX+$RST - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - append output ${GX}GX-$RST - } elseif {[punk::ansi::codetype::is_sgr $code]} { - set displaycode [ansistring VIEW $code] - if {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - #highlight the esc & leftbracket in white as indication there is a leading reset - set cposn [string first ";" $displaycode] - append output ${whiteb}[string range $displaycode 0 $cposn]$RST${greenb}[string range $displaycode $cposn+1 end]$RST - } else { - append output ${greenb}$displaycode$RST - } - } else { - switch -regexp -matchvar matchinfo -- $code\ - $re_row_move { - set displaycode [ansistring VIEW $code] - set displaycode [string map [list A "A$arrow_up" B "B$arrow_down"] $displaycode] - append output ${cyanb}$displaycode$RST - }\ - $re_col_move { - lassign $matchinfo _match num type - set displaycode [ansistring VIEW $code] - set displaycode [string map [list C "C$arrow_right" D "D$arrow_left" G "G$arrow_lr"] $displaycode] - append output ${cyanb}$displaycode$RST - }\ - $re_both_move { - lassign $matchinfo _match row col - set displaycode [ansistring VIEW $code] - if {$col eq ""} { - #row only move - set map [list H "H${arrow_lr}"] - } else { - #row and col move - set map [list H "H${arrow_lr}${arrow_du}"] - } - set displaycode [string map $map $displaycode] - append output ${cyanb}$displaycode$RST - }\ - $re_cursor_save -\ - $re_cursor_save_dec { - append output ${blueb}[ansistring VIEW $code]$RST - }\ - $re_cursor_restore -\ - $re_cursor_restore_dec { - append output ${blueb_r}[ansistring VIEW $code]$RST - }\ - default { - append output ${unk}[ansistring VIEW $code]$RST - } - - } - } - return $output + set arglist [lrange $args 0 end-1] + set ansistr [ansistring NEW $string] + set result [$ansistr viewcodes {*}$arglist] + $ansistr destroy + return $result } #an attempt to show the codes and colour/style of the *input* #ie we aren't looking at the row/column positioning - but we do want to keep track of cursor attribute saves and restores - proc VIEWSTYLE {string} { - set splits [punk::ansi::ta::split_codes_single $string] - set output "" - set codestack [list] - set gx_stack [list] ;#not actually a stack - set cursor_saved "" - foreach {pt code} $splits { - append output [punk::ansi::codetype::sgr_merge_list {*}$codestack]$pt - if {$code ne ""} { - append output [a][VIEW $code] - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set codestack [list] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #basic simplification first.. straight dups - set dup_posns [lsearch -all -exact $codestack $code] ;#-exact because of square-bracket glob chars - set codestack [lremove $codestack {*}$dup_posns] - lappend codestack $code - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #cursor_save - set cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$codestack] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #cursor_restore - set codestack [list $cursor_saved] - } else { - #leave SGR stack as is - if {[punk::ansi::codetype::is_gx_open $code]} { - set gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set gx_stack [list] - } - } - } + proc VIEWSTYLE {args} { + set string [lindex $args end] + if {$string eq ""} { + return "" } - return $output + set arglist [lrange $args 0 end-1] + set ansistr [ansistring NEW $string] + set result [$ansistr viewstyle {*}$arglist] + $ansistr destroy + return $result } @@ -2777,7 +3264,7 @@ namespace eval punk::ansi::ansistring { #[para]To get the width, use punk::ansi::printing_length instead, which is also ansi aware. #stripping diacritics only makes sense if we are counting them as combiners and also treating unicode grapheme combinations as single entities. - #as Our ansistring index function returns the character with diacritics, and will ultimately return grapheme clusters as a single element - we strip theme here as not counted. + #as Our ansistring INDEX function returns the character with diacritics, and will ultimately return grapheme clusters as a single element - we strip theme here as not counted. #todo - combiners/diacritics? just map them away here? set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set string [regsub -all $re_diacritics $string ""] @@ -2785,17 +3272,17 @@ namespace eval punk::ansi::ansistring { #we want length to return number of glyphs.. not screen width. Has to be consistent with index function string length [stripansi $string] } - - proc length {string} { - string length [stripansi $string] - } - #included as a test/verification - slightly slower. #grapheme split version may end up being used once it supports unicode grapheme clusters proc count2 {string} { - #we want length to return number of glyphs.. not screen width. Has to be consistent with index function + #we want count to return number of glyphs.. not screen width. Has to be consistent with index function return [llength [punk::char::grapheme_split [stripansi $string]]] } + + proc length {string} { + string length [stripansi $string] + } + proc trimleft {string args} { set intext 0 @@ -2827,7 +3314,8 @@ namespace eval punk::ansi::ansistring { join [_splits_trimright [_splits_trimleft [split_codes $string]]] "" } - proc index {string index} { + #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index + proc INDEX {string index} { #*** !doctools #[call [fun index] [arg string] [arg index]] #[para]Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes) @@ -2835,7 +3323,6 @@ namespace eval punk::ansi::ansistring { #[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output. #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) #[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them. - #[para]todo: SGR codes within ST-terminated strings not yet ignored properly #[para]If the caller wants just the character - they should use a normal string index after calling stripansi, or call stripansi afterwards. #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use stripansi and standard string index if the ansi coded output isn't required and they are using and end-based index. #[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using stripansi and normal string operations on that. @@ -2918,7 +3405,8 @@ namespace eval punk::ansi::ansistring { set pt_index -2 set pt_found -1 set char "" - set codes_in_effect "" + #set grapheme_codestacks [list] ;#stack of codes per grapheme - will be flattened/coalesced + set codestack [list] #we can't only apply leading sequence from previous code - as there may be codes in effect from earlier, so we have to track as we go #(this would apply even if we used split_codes - but then we would need to do further splitting of each codeset anyway) foreach {pt code} $ansisplits { @@ -2940,21 +3428,23 @@ namespace eval punk::ansi::ansistring { } if {[punk::ansi::codetype::is_sgr_reset $code]} { - #we can throw away previous codes_in_effect - set codes_in_effect "" + #we can throw away previous codestack + set codestack [list] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] } else { - #may have partial resets - but we don't want to track individual states of SGR features - #A possible feature would be some function to optimise an ansi code sequence - which we could then apply at the end. + #may have partial resets + #sgr_merge_list will handle at end #we don't apply non SGR codes to our output. This is probably what is wanted - but should be reviewed. #Review - consider if any other types of code make sense to retain in the output in this context. if {[punk::ansi::codetype::is_sgr $code]} { - append codes_in_effect $code + lappend codestack $code } } } if {$pt_found >= 0} { - return $codes_in_effect$char + return [punk::ansi::codetype::sgr_merge_list {*}$codestack]$char } else { return "" } @@ -2964,6 +3454,7 @@ namespace eval punk::ansi::ansistring { #return empty string for each index that is out of range #review - this is possibly too slow to be very useful as is. # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string + #see also punk::list_index_resolve / punk::list_index_get for ways to handle tcl list/string indices without parsing them. proc INDEXABSOLUTE {string args} { set payload_len -1 ;# -1 as token to indicate we haven't calculated it yet (only want to call it once at most) set testindices [list] @@ -3036,7 +3527,7 @@ namespace eval punk::ansi::ansistring { } } } - #assert - we made exactly one append to testindices if there was no error + #assertion - we made exactly one append to testindices if there was no error } #we now have numeric or empty string indices - but haven't fully checked they are within the underlying payload length @@ -3063,7 +3554,10 @@ namespace eval punk::ansi::ansistring { } - #Todo - rows! + #Todo - rows! Note that a 'row' doesn't represent an output row if the ANSI string we are working with contains movement/cursor restores etc. + #The column/row concept works for an ansistring that has been 'rendered' to some defined area. + #row for arbitrary ANSI input only tells us which line of input we are in - e.g a single massive line of ANSI input would appear to have one row but could result in many. + #return pair of column extents occupied by the character index supplied. #single-width grapheme will return pair of integers of equal value #doulbe-width grapheme will return a pair of consecutive indices @@ -3167,7 +3661,7 @@ namespace eval punk::ansi::ansistring { return $index } } - error "ansistring COLUMNINDEX '$string' $col not found" ;#assert - shouldn't happen + error "ansistring COLUMNINDEX '$string' $col not found" ;#assertion - shouldn't happen } } else { error "ansistring COLUMNINDEX multiline not implemented" diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 5e1f799a..8df558cf 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -391,7 +391,7 @@ namespace eval punk::args { } } set opts [dict merge $defaults_dict_opts $checked_args] - #assert - checked_args keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + #assertion - checked_args keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options set values [dict merge $defaults_dict_values $values_dict] diff --git a/src/modules/punk/assertion-999999.0a1.0.tm b/src/modules/punk/assertion-999999.0a1.0.tm new file mode 100644 index 00000000..5fa52779 --- /dev/null +++ b/src/modules/punk/assertion-999999.0a1.0.tm @@ -0,0 +1,412 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::assertion 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::assertion 0 999999.0a1.0] +#[copyright "2024"] +#[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] +#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] +#[require punk::assertion] +#[keywords module assertion assert debug] +#[description] +#[para] The punk::assertion library has the same semantics as Tcllib's control::assert library for the assert command itself. +#[para] The main difference is the way in which assert is enabled/disabled in namespaces. +#[para] Due to commands such as 'namespace path' - the assert command could be available in arbitrary namespaces unrelated by tree structure to namespaces where assert has been directly imported. +#[para] punk::assertion::active 0|1 allows activating and deactivating assertions in any namespace where the assert command is available - but only affecting the activations state of the namespace in which it is called. +#[para] If such a non-primary assertion namespace never had active set to 0 or 1 - then it will activate/deactivate when the namespace corresponding to the found assert command (primary) is activated/deactivated. +#[para] Once marked active or inactive - such a non-primary namespace will no longer follow the primary + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::assertion +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::assertion +#[list_begin itemized] + +package require Tcl 8.6 +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::assertion::class { + #*** !doctools + #[subsection {Namespace punk::assertion::class}] + #[para] class definitions + if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin +namespace eval punk::assertion::primary { + + namespace export * + proc assertActive {expr args} { + + set code [catch {uplevel 1 [list expr $expr]} res] + if {$code} { + return -code $code $res + } + if {![string is boolean -strict $res]} { + return -code error "invalid boolean expression: $expr" + } + + if {$res} {return} + + if {[llength $args]} { + #set msg "[join $args]" + set msg "$args punk::assertion failed expr $expr" + } else { + set msg "punk::assertion failed expr $expr" ;#give a clue in the default msg about which assert lib is in use + } + + upvar ::punk::assertion::CallbackCmd CallbackCmd + # Might want to catch this + namespace eval :: $CallbackCmd [list $msg] + } + proc assertInactive args {} + +} +namespace eval punk::assertion::secondary { + namespace export * + #we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want. + proc assertActive {expr args} [info body ::punk::assertion::primary::assertActive] + proc assertInactive args {} +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::assertion { + variable CallbackCmd [list return -code error] + namespace import ::punk::assertion::primary::assertActive + rename assertActive assert + + namespace export * + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::assertion}] + #[para] Core API functions for punk::assertion + #[list_begin definitions] + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + #like tcllib's control::assert - we are limited to the same callback for all namespaces. + #review - a per namespace - or per assert command callback may be tricky to do performantly. + #Would probably involve rewriting the proc body - otherwise we have a runtime penalty in the assert of looking it up. + proc callback {args} { + #set nscaller [uplevel 1 [list namespace current]] + #set which_assert [namespace eval $nscaller {namespace which assert}] + + upvar ::punk::assertion::CallbackCmd cb + set n [llength $args] + if {$n > 1} { + return -code error "wrong # args: should be\ + \"[lindex [info level 0] 0] ?command?\"" + } + if {$n} { + set cb [lindex $args 0] + return + } + return $cb + } + + proc active {{on_off ""}} { + set nscaller [uplevel 1 [list namespace current]] + set which_assert [namespace eval $nscaller {namespace which assert}] + #puts "nscaller:'$nscaller'" + #puts "which_assert: $which_assert" + + if {$on_off eq ""} { + if {$which_assert eq ""} {return 0} + set assertorigin [namespace origin $which_assert] + #puts "ns which assert: $which_assert" + #puts "ns origin assert: $assertorigin" + return [expr {"assertActive" eq [namespace tail $assertorigin]}] + } + if {![string is boolean -strict $on_off]} { + error "invalid boolean value : $on_off" + } else { + set info_command [namespace eval $nscaller {info commands assert}] + if {$on_off} { + #Enable it in calling namespace + if {"assert" eq $info_command} { + #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) + if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { + namespace eval $nscaller { + set assertorigin [namespace origin assert] + set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] + switch -- $assertorigin_ns { + ::punk::assertion { + #original import - switch to primary origin + rename assert {} + namespace import ::punk::assertion::primary::assertActive + rename assertActive assert + } + ::punk::assertion::primary - ::punk::assertion::secondary { + #keep using from same origin ns + rename assert {} + namespace import ${assertorigin_ns}::assertActive + rename assertActive assert + } + default { + error "The assert command in this namespace is not from punk::assertion package. Use the enable mechanism from the package associated with $assertorigin or remove the existing assert command and namespace import punk::assertion::assert" + } + } + } + return 1 + } else { + #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace + namespace eval $nscaller { + set assertorigin [namespace origin assert] + if {[string match ::punk::assertion::* $assertorigin]} { + namespace import ::punk::assertion::secondary::assertActive + rename assertActive assert + } else { + error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin" + } + } + return 1 + } + + } else { + #no assert command reachable + puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" + return 0 + } + } else { + #Disable + if {"assert" eq $info_command} { + if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { + #assert is present in callers NS + namespace eval $nscaller { + set assertorigin [namespace origin assert] + set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] + switch -glob -- $assertorigin_ns { + ::punk::assertion { + #original import + rename assert {} + namespace import punk::assertion::primary::assertInactive + rename assertInactive assert + } + ::punk::assertion::primary - ::punk::assertion::secondary { + #keep using from same origin ns + rename assert {} + namespace import ${assertorigin_ns}::assertInactive + rename assertInactive assert + } + default { + error "The assert command in this namespace is not from punk::assertion package. Use the disable mechanism from the package associated with $assertorigin or remove the existing assert command and namespace import punk::assertion::assert" + } + } + } + return 0 + } else { + #assert not present in callers NS - first install of secondary (if assert is from punk::assertion::*) + namespace eval $nscaller { + set assertorigin [namespace origin assert] + set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] + if {[string match ::punk::assertion::* $assertorigin]} { + namespace import ::punk::assertion::secondary::assertInactive + rename assertInactive assert + } else { + error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin" + } + } + return 0 + } + } else { + #no assert command reachable + #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path + puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" + return 0 + } + } + } + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::assertion ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::assertion::lib { + namespace export * + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::assertion::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::assertion::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::assertion::system { + #*** !doctools + #[subsection {Namespace punk::assertion::system}] + #[para] Internal functions that are not part of the API + + #Maintenance - snarfed from punk::ns to reduce dependencies - punk::ns::nsprefix is the master version + #nsprefix/nstail are string functions - they do not concern themselves with what namespaces are present in the system + proc nsprefix {{nspath {}}} { + #normalize the common case of :::: + set nspath [string map [list :::: ::] $nspath] + set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]] + if {$rawprefix eq "::"} { + return $rawprefix + } else { + if {[string match *:: $rawprefix]} { + return [string range $rawprefix 0 end-2] + } else { + return $rawprefix + } + #return [string trimright $rawprefix :] + } + } + #see also punk::ns - keep in sync + proc nstail {nspath args} { + #normalize the common case of :::: + set nspath [string map [list :::: ::] $nspath] + set mapped [string map [list :: \u0FFF] $nspath] + set parts [split $mapped \u0FFF] + + set defaults [list -strict 0] + set opts [dict merge $defaults $args] + set strict [dict get $opts -strict] + + if {$strict} { + foreach p $parts { + if {[string match :* $p]} { + error "nstail unpaired colon ':' in $nspath" + } + } + } + #e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. + return [lindex $parts end] + } + proc nsjoin {prefix name} { + if {[string match ::* $name]} { + if {"$prefix" ne ""} { + error "nsjoin: won't join non-empty prefix to absolute namespace path '$name'" + } + return $name + } + if {"$prefix" eq "::"} { + return ::$name + } + #if {"$name" eq ""} { + # return $prefix + #} + #nsjoin ::x::y "" should return ::x::y:: - this is the correct fully qualified form used to call a command that is the empty string + return ${prefix}::$name + } + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::assertion [namespace eval punk::assertion { + variable pkg punk::assertion + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/assertion-buildversion.txt b/src/modules/punk/assertion-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/assertion-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punk/cap-999999.0a1.0.tm b/src/modules/punk/cap-999999.0a1.0.tm index 80d6912d..9d62ac1d 100644 --- a/src/modules/punk/cap-999999.0a1.0.tm +++ b/src/modules/punk/cap-999999.0a1.0.tm @@ -249,7 +249,7 @@ namespace eval punk::cap { puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" return } - #assert: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. + #assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. dict set caps $capname handler $capnamespace if {![dict exists $caps $capname providers]} { dict set caps $capname providers [list] diff --git a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm index de0e396d..1b4509a4 100644 --- a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm +++ b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm @@ -698,8 +698,8 @@ namespace eval punk::cap::handlers::templates { } } - #assert path is first key of itemdict {callers are allowed to rely on it being first} - #assert itemdict has keys path,basefolder,sourceinfo + #assertion path is first key of itemdict {callers are allowed to rely on it being first} + #assertion itemdict has keys path,basefolder,sourceinfo set result [dict create] set keys [lreverse [dict keys $itemdict]] foreach k $keys { diff --git a/src/modules/punk/char-999999.0a1.0.tm b/src/modules/punk/char-999999.0a1.0.tm index 36408345..25f729ed 100644 --- a/src/modules/punk/char-999999.0a1.0.tm +++ b/src/modules/punk/char-999999.0a1.0.tm @@ -57,6 +57,7 @@ package require Tcl 8.6- #dependency on tcllib not ideal for bootstrapping as punk::char is core to many features.. (textutil::wcswidth is therefore included in bootsupport/include_modules.config) review +package require textutil package require textutil::wcswidth #*** !doctools @@ -921,7 +922,7 @@ namespace eval punk::char { set start [dict get [lindex $ranges 0] start] set end [dict get [lindex $ranges 0] end] if {![dict exists $charset_extents_startpoints $start] || $end ni [dict get $charset_extents_startpoints $start]} { - #assert if end wasn't in startpoits list - then start won't be in endpoints list + #assertion if end wasn't in startpoits list - then start won't be in endpoints list dict lappend charset_extents_startpoints $start $end dict lappend charset_extents_endpoints $end $start } @@ -934,7 +935,7 @@ namespace eval punk::char { set start [dict get $range start] set end [dict get $range end] if {![dict exists $charset_extents_startpoints $start] || $end ni [dict get $charset_extents_startpoints $start]} { - #assert if end wasn't in startpoits list - then start won't be in endpoints list + #assertion if end wasn't in startpoits list - then start won't be in endpoints list dict lappend charset_extents_startpoints $start $end dict lappend charset_extents_endpoints $end $start } diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 67af5480..32c630a5 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -981,6 +981,22 @@ namespace eval punk::console { lassign [split $payload {;}] rows cols return [list columns $cols rows $rows] } + proc get_mode_line_wrap {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[\?7;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[?7\$p" + set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + return $payload + } + + #Terminals generally default to LNM being reset (off) ie enter key sends a lone + #Terminals tested on windows either don't respond to this query, or respond with 0 (meaning mode not understood) + #I presume from this that almost nobody is using LNM 1 (which sends both and ) + proc get_mode_LNM {{inoutchannels {stdin stdout}}} { + set capturingregex {(.*)(\x1b\[\?20;([0-9]+)\$y)$} ;#must capture prefix,entire-response,response-payload + set request "\x1b\[?20\$p" + set payload [punk::console::internal::get_ansi_response_payload $request $capturingregex $inoutchannels] + return $payload + } #terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate. #todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position. diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index 0e7d5562..5d336881 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -745,7 +745,7 @@ namespace eval punk::fileline::class { lassign [my numeric_linerange $startidx $endidx] startidx endidx set chunkstart [dict get $o_linemap $startidx start] set chunkend [dict get $o_linemap $endidx end] - set line_list [my chunkrange_to_lineinfolist $chunkstart $chunkend] ;# assert - no need to view truncations as we've picked start and end of complete lines + set line_list [my chunkrange_to_lineinfolist $chunkstart $chunkend] ;# assertion - no need to view truncations as we've picked start and end of complete lines #verify sanity set l_start [lindex $line_list 0] if {[set idx_start [dict get $l_start lineindex]] ne $startidx} { @@ -983,9 +983,9 @@ namespace eval punk::fileline::class { lappend infolist $last } ########################### - #assert all records have is_truncated key. - #assert if is_truncated == 1 truncatedside should contain a list of either left, right or both left and right - #assert If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. + #assertion all records have is_truncated key. + #assertion if is_truncated == 1 truncatedside should contain a list of either left, right or both left and right + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. return $infolist } diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index fcec9db1..9549d163 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -1270,7 +1270,7 @@ namespace eval punk::lib { } } set opts [dict merge $defaults_dict_opts $checked_args] - #assert - checked_args keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + #assertion - checked_args keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options set values [dict merge $defaults_dict_values $values_dict] diff --git a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm index 3afe3d28..c80fb452 100644 --- a/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/scriptwrap-999999.0a1.0.tm @@ -892,7 +892,7 @@ namespace eval punk::mix::commandset::scriptwrap { return false } } - #assert - customwrapper_folder var exists - but might be empty + #assertion - customwrapper_folder var exists - but might be empty if {[string length $ext]} { diff --git a/src/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/templates/layouts/project/src/make.tcl index 10d8e7ed..1bb0a460 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/make.tcl +++ b/src/modules/punk/mix/templates/layouts/project/src/make.tcl @@ -777,7 +777,7 @@ foreach vfs $vfs_folders { } } } - #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config + #assertion $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config #todo - non kit based - zipkit? diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 080f3448..783f116d 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -215,7 +215,7 @@ namespace eval punk::ns { } proc nschildren {fqns} { if {![string match ::* $fqns]} { - error "nschildren only accespts a fully qualified namespace" + error "nschildren only accepts a fully qualified namespace" } set parent [nsprefix $fqns] set tail [nstail $fqns] @@ -225,6 +225,9 @@ namespace eval punk::ns { return [lsort $nslist] } + #Note nsjoin,nsjoinall,nsprefix,nstail are string functions that don't care about namespaces in existence. + #Some functions in punk::ns are + proc nsjoin {prefix name} { if {[string match ::* $name]} { if {"$prefix" ne ""} { @@ -265,6 +268,17 @@ namespace eval punk::ns { } return [join $nonempty_segments ::] } + + + #REVIEW - the combination of nsprefix & nstail are designed to *almost* always be able to reassemble the input, and to be independent of what namespaces actually exist + #The main difference being collapsing (or ignoring) repeated double-colons + #we need to distinguish unprefixed from prefixed ie ::x vs x + #There is an apparent inconsistency with nstail ::a:::x being able to return :x + #whereas nsprefix :::a will return just a + #This is because :x (or even just : ) can in theory be the name of a command and we may need to see it (although it is not a good idea) + #and a namespace can exist with leading colon - but is even worse - as default Tcl commands will misreport e.g namespace current within namespace eval + #The view is taken that a namespace with leading/trailing colons is so error-prone that even introspection is unreliable so we will rule that out. + # proc nsprefix {{nspath ""}} { #normalize the common case of :::: set nspath [string map [list :::: ::] $nspath] @@ -281,8 +295,8 @@ namespace eval punk::ns { } } - #namespace tail which handles :::cmd ::x:::y ::x:::/y etc - #todo - raise error for unexpected sequences such as :::: or more than 2 colons together. + #namespace tail which handles :::cmd ::x:::y ::x:::/y etc in a specific manner for string processing + #review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together. proc nstail {nspath args} { #normalize the common case of :::: set nspath [string map [list :::: ::] $nspath] @@ -301,7 +315,7 @@ namespace eval punk::ns { } } - #e.g ::x::y:::z should return ":z" + #e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. return [lindex $parts end] } @@ -792,7 +806,7 @@ namespace eval punk::ns { } if {$cmd in $aliases && $cmd in $seencmds} { #masked commandless-alias - #assert member of masked - but we use seencmds instead to detect. + #assertion member of masked - but we use seencmds instead to detect. set c [a+ yellow bold] set prefix "${a}als " set prefix [overtype::right $prefix "-R"] diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 7f7c4671..9b74eb6f 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -1383,7 +1383,8 @@ namespace eval punk::repl::class { set prefix [string repeat " " [expr {$col0 -1}]] set linecols [punk::ansi::printing_length $cursorline] set suffix [string repeat " " [expr {$linecols -$col1}]] - set char_at_cursor [ansistring index $cursorline $charindex_at_cursor] ;#this is the char with appropriate ansireset codes + #capitalised INDEX - for grapheme/control-char index e.g a with diacritic a\u0300 has a single index + set char_at_cursor [ansistring INDEX $cursorline $charindex_at_cursor] ;#this is the char with appropriate ansireset codes set rawchar [punk::ansi::stripansi $char_at_cursor] if {$rawchar eq " "} { set charhighlight "[punk::ansi::a+ White]_[a]" @@ -1633,6 +1634,7 @@ proc repl::repl_handler {inputchan prompt_config} { uplevel #0 [list repl::repl_process_data $inputchan raw-waiting $ch [list] $prompt_config] } else { + repl_handler_checkchannel $inputchan if {[dict get $original_input_conf -blocking] ne "0" || [dict get $original_input_conf -translation] ne "lf"} { chan configure $inputchan -blocking 0 @@ -1752,7 +1754,11 @@ proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} { #punk::console::move_emitblock_return 20 120 $chunklen-->[chan conf stdin]<-- if {$chunklen > 0} { set info1 "read $chunklen bytes->[ansistring VIEW -lf 1 -vt 1 $chunk]" - #it's strange - but apparently terminals use a lone cr to represent enter + #consider also the terminal linefeed mode. + #https://vt100.net/docs/vt510-rm/LNM.html + # terminals (by default) generally use a lone cr to represent enter (LNM reset ie CSI 20l) + #(as per above doc: "For compatibility with Digital's software you should keep LNM reset (line feed)") + #You can insert an lf using ctrl-j - and of course stdin could have crlf or lf #pasting from notepad++ with mixed line endings seems to paste everything ok #we don't really know the source of input keyboard vs paste vs pipe - and whether a read has potentially chopped a crl in half.. @@ -2242,7 +2248,7 @@ proc repl::repl_process_data {inputchan type chunk stdinlines prompt_config} { foreach cinfo $::repl::screen_last_char_list { lassign $cinfo c whatinfo whyinfo set cdisplay [punk::ansi::ansistring::VIEW -lf 1 -vt 1 $c] - #assert cdisplay has no raw newlines + #assertion cdisplay has no raw newlines if {[punk::char::ansifreestring_width $cdisplay] == 1} { set cdisplay "$cdisplay " ;#make 2 wide } diff --git a/src/modules/punk/winrun-999999.0a1.0.tm b/src/modules/punk/winrun-999999.0a1.0.tm index 9acea356..9fb636e8 100644 --- a/src/modules/punk/winrun-999999.0a1.0.tm +++ b/src/modules/punk/winrun-999999.0a1.0.tm @@ -153,7 +153,7 @@ namespace eval punk::winrun { } # ----------------- #tw_run $cmdline - #assert - can be treated as tcl list ? + #assertion - can be treated as tcl list ? return $cmdline } interp alias "" [namespace current]::quote_wintcl "" ::punk::winrun::quote_win ;#just for symmetry with unquote_wintcl diff --git a/src/testansi/belinda.ans b/src/testansi/belinda.ans new file mode 100644 index 00000000..13fcfa8a --- /dev/null +++ b/src/testansi/belinda.ans @@ -0,0 +1,100 @@ +Û ²²±±°°°°°ÚÁÄÙÂÄÚ +ÀÂÂÂÂÂÄÂÅÅÅÅÂÁÄÄÄ +¿ÄÅÅÂÄÄßß¿ÛÛÛÛÛ +ÛÛÛÛÛÛ ÞÝÒÄ· ²²±±±°°°°° +ÄÁÃÙÁÅÂÁÅÄÃÅÂÄÅÄÁÅÅ´ +ÜÜÜÛÛÜÁÁÂÅÅÅÄÚ¿À +´ÛÛÛÛÛÛÛÛÛÛÛ ÞÝÇÄз + ²²±±°°°°°°° Å ÚÂÙÅ +ÚÅÁÛÜÜÜÜÜÛÛÛÛÛÛÛÛÛÛ³ÀÅ +Þ¿ÃÅÂÅ¿ÛÛÛÛÛÛÛÛÛÛ ÞÝ +ÐÄĽ ²²±±°°°°°°°³³ ¿Ù +ÀÂÄÙÃÅÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ +Û ÀÅÞ³³³À´¿ÛÛÛÛÛÛÛÛÛ  +ÞÝÒÄÄ· ²²±±°°°°°°°ÚÅ´ +Ä´³³³ÄÂÅÅßßÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÝ +ÄÅÞÀÙÿ³ÀÄ¿ÛÛÛÛÛÛÛ + ÞÝÇÄ ²²±±°°°°°°°³Ã´ +Ä´³³³ÄÂÅÅÜÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ  +ÅÞÀÙÿ³ ³ ÛÛÛÛÛÛÛ  +ÞÝÐÄĽ ²²±±°°°°°°°°Ú +ٳٳÿÚÙ³³ÛÛÛÛÛÛÛÛÛÛ +ÛßßÜÜÜÜßÛÛÝÁ¿ÚÄÞ³ +³¿³À¿ÛÛÛÛÛÛ ÞÝÒ + ²²±±°°°°°°°ÚÅÁ´³ÚÅÙ  +³³ÀÀÙßßÛÛÛÛÜßÜ Ü + ÜßÛÛÛÛ ³³³Þ +Ä¿À¿ ÿÛÛÛÛÛ Þݺ + ²²±±°°°°° Ä¿´ÃÅ´³³³Ã +ÙôÞÜÜ Ü ßÛÛÛÛÜÜÜÛÛ +ÛÛÛÛÛ ôÿÞÁ¿À¿³ +³ÛÛÛÛÛ ÞÝÐÄĽ²²±±°°°°°°° +ÚÅÂÅÁ´ô³³³³³ +³³ÛÛÛÛ ÛÛÛÛÛÛÛÛÛÛÛÛÛÛ ´ +Þ³³Þ³À¿À¿³ +ÛÛÛÛÛ ÞÝÄÒÄIJ²±±°°°°ÚÂÄ´ +³Ã´ÚÅÁ´ÚÅÂÁÅÁ +À Ûß ÛÛÛÛßßÛÛÛÛÛÛÛÝ Þ +³À´ÚÙ³ÀÄ¿ÛÛÛ Þ +ݺ²²±±°°°°³³Ú´ Å +Å´ÃÄÀ´³³ÄÁij³  +ßÛÜÛÛÛÜÜßÛÛÛÛÛÝ +ÃÙÞ´³³³À¿ÿ  +³ÛÛÛ ÞÝÄÐÄIJ±±°°°° +ÄÙÚÙ ÅÅÅÅÅÂÂÙÅÙÄÂÂÅ +Ù ÛÜßßßÛßßÜÞÜÛÛÛß +ÚÁ¿ÃÞÃÙÿ³³³Ã¿ +³¿ÛÛ ÞÝÒÄ··²±±°°°°° +Ú´´Åų³³³Å +´À¿³Ã´ ± ßßßß +ßÜÛÛÛÛÛÛßÚij³ôÞ +À¿ÃÅÞÀ¿³³³³ÛÛ Þ +ݺ ºº²±±°°°°°ÃųŠ+ÅÂÙÃÅÙ³³³ÿÀ´ +³ ÜÜÜÜÛÛÛÛÛÛßÚÄÙ +ÚÙ³³³ÃÄÁÙ³ +ÞÄÅÄ¿³ÛÛ ÞÝ +Ð Ó½²±±°°°°Ú´³ÙÅÁÅ +ÂÅÄÂÅÁÅÅÅ¿³³  +ÛÛßÛÛÛÛÛß¿Ú´ ÂÁÞ +ÄÙ³ÃÂijÃÞÄ +ÅÂÙÄÂÛÛ ÞÝÒÄÄ· +²±±°°°°³³ÃÅٳô +³³³³ÃÙ³³ÀÅ +¿ß Üßß Ú´ÃÅÅ +´ÅÅ¿³ÄÁÀÁÂÁ +ÙÚ¿ÀÁÄ¿ÿÛ ÞÝ +º º²±°°°°³ÃÅÅ ÄÁ´ +ô³Ã´³Úà +¿³ÀÅ¿ÀÙ´ÃÅÅÁ +´³Ã¿³À +Ä¿ÞÁÂÞÃÅÄÁÛ  +ÞÝÐÄĽ±±°°ÚÂÁÁ +ÅÅÅÄÚ´³³ÃÅ´ +³ÃÅôÃÄÅ´Ä  +ßÚÄÙ³³Ãô³ +³³ÀÁÅ¿ÚÅÞ´Þ +ÁÁÄ¿ÝÖÄÄ·±±° +ڴóÃÚijÁÄÙ +³ÃÄÁÁÙ³ÿÀ´ +³À¿±  ¿ÃÅ´³ +ÀÄÙ³Ãij޳ÃÞÅ +ÂÄÄ¿ ÃÁÁÁ¿ÇÄĶ±°°³Ú´ +³ÁÂÅÙ³³ÀÄÂÄÙÃÄ +ÂÅ´³ÄÅÅ¿À¿ +ñ ³³ÃÁÅÁÄÂij³ +ÚÙÞÅÅ ÀÁ¿ ³ +ÛÛÛÛ À¿Ð±° +Ú´ÅÄ´³Á¿³ÚÂÂÁÅÄÅ +ÂÁÅÙÃÅÅÂÁÅ +Å¿ÀÅÅ´ ÀÙ³À¿³ +ÚÅ¿ÃÂÂÞÅ +ÛÛ À¿ÛÛÛÛÛÛ À´ +Michael±°À´ÙÄ´ ± +ÃÂÅÙÅÂÅÂÀÙÃÅÄ +ÙÀÁÅÂÅÅٴô ²  +ÄÁÂÅ´ô³À´À +Ù À¿ÛÛ ³ÛÛÛÛÛ +ÛÛ ³Arnett + + diff --git a/src/testansi/timebend.ans b/src/testansi/timebend.ans new file mode 100644 index 00000000..9e2101da --- /dev/null +++ b/src/testansi/timebend.ans @@ -0,0 +1,62 @@ +ÛÛÛÛÛÛÛÛÛÛÛÛÛßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßß +ßßßßßßßßßßßßßßßßÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ Û Û Û ÛÛ ÛÛ +ÛßÛ ÛßÛßÛ ÛßÛÛßÛ ÛßÛßÛ ÛÛßÛ ÛßÛ ÛÛ ÛÛ Û Û Û ÛÛÛÛÛÛÛÛÛÛ +ÛÛÛÛÛÛÛÛÛÛÛÛÛÜÜÜ ÜÜÜÜÜÜÜ ÜÜÜÜÜÜÜÜÜ ÜÜÜÜÜÜÜÜÜÜ ÜÜÜ +ÜÜÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ Û Û  +Ü ÛÛÛÛÛÛÛÛ ²ÜÛÛÛÛÛÛÛÛÛ Û ÛÛÛÛÛÛ +ÛÛÛÛÛ Û Û Û ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ + Û ÛÜ ßÛÛÛÛÛÛÛÛÛß²ÛÛÛÛÛÛÛÛÛ  + Û ÛÛÛÛÛÛÛÛÛÛßÜßÜÛ Û ÛÛSc +reen ByÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ Û ÛÛÜßÜß +ÜÛÛÛÛÛÛ ²ßÛÛÛÛÛßÛßÛ Û ÛÛÛÛÛÛÛÛÛßÜß +ÜÛÛ Û ÛÛPretty ÛÛÛÛÛÛÛÛÛÛÛÛÛ +ÛÛÛÛ Û ÛÛÛÜ ÜßÛÛÛÛÛÛ ²ßßß ß + Ü ÛÜ Û ÛÛÛÛÛÛÛÛßÜßÜÛÛÛ Û ÛÛ +Please ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ Û ÛÛÛÛÛÜ  +ßÛÛßßßÜ ßÛÜ Û ßÜÛßÛÛßÜß +ÜÛÛÛÛÛ Û ÛÛ(c) 1991 ÛÛÛÛÛÛÛÛÛÛ +ÛÛÛÛÛÛÛ Û ÛÛÛÛÛÛÛÜß Üß Üß ßÜß Û  +ßÜÜßÛÜßÜÛÛÛÛÛÛÛ Û ÛÛ"Accept  +ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ Û ÛÛÛÛÛÛÛÛÛÜÜßßÜ +Ü Ü Üß ßÜÛ Û ÛÜßßÜÜÛÛÛÛÛÛÛÛÛ Û ÛÛ + No ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ Û ÛÛÛÛÛÛÛ +ÛÛÛÛÛÛ ßßÜÜ Û ßÜß Û ÜÜÛÛÛÛÛÛÛÛÛÛÛÛÛ Û  +ÛÛ Substi- ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ Û  +ÛÛÛÛÛÛÛÛÛÛÛÛÛ Û ÜßÛÜ ßÛ Û ÛÛÛÛÛÛÛÛÛ +ÛÛÛÛÛÛ Û ÛÛ tutes!" ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ +Û Û ÛÛÛÛÛÛÛÛÛÛÛÛÛ Û ÛÛ Û ÜÛ Û + ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ Û ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ +TimeÛÛÛÛÛÛÛÛÛ Û ÛÛÛÛÛÛÛÛÛÛÛÛÛ Û  +ÛßÜ Û ßÜ Û ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ Û  +ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛBender-LongÛÛ Û  +ÛÛÛÛÛÛÛÛÛÛÛÛÛ ß ÜßÜÛÜ ÛÜ Û ÛÛÛÛÛÛÛÛÛ +ÛÛÛÛÛÛ Û ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ916-342-9 +239Û Û ÛÛÛÛÛÛÛÛÛÛÛßßܲ +ÛÛÛÛÛÜßÛÛ Û ÜÜßßÛÛÛÛÛÛÛÛÛÛ +Û Û ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ  +Û ÛÛÛÛÛÛÛÛßÜ ÛÜܲÛÛÛÛÛÜÛßÛ  +Û ÛÜÛßÜÜßÛÛÛÛÛÛÛÛ Û ÛÛÛÛÛÛÛÛÛÛÛÛÛ +ÛÛScreen ByÛÛÛÛ Û ÛÛÛÛÛÛßÜßÜÛÛÛ  +²ßÛ_ÛÛÛÛßÛÛ Û ÛÛÛÛÛÜßÜßÛÛÛÛÛ +Û Û ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛPretty ÛÛÛÛ  +Û ÛÛÛÛß ÜÛÛÛÛÛܲÛÛÛÛßÛßÛß  +Û ÛÛÛÛÛÛÛÜßÜßÛÛÛÛ Û ÛÛÛÛÛÛÛÛÛÛÛÛÛ +ÛÛPlease ÛÛÛÛ Û ÛÛÛ Ü ÛÛÛÛÛÛÛ  +²Ûß ßÜ ÜßÜß Û ÛÛÛÛÛÛÛÛÛ Û  +ÛÛÛ Û ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ(c) 1991 + ÛÛÛÛ Û ÛÛ Ü ßÜÛÛÛÛÛÛ ² +ß Ü ßÜÜßÜ Û ÜßÛÛÛÛÛÛÛÛ Û ÛÛ  +Û ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ"Accept ÛÛÛÛ  +Û Û Ü ßÛßÛÛßß Ü ß ßÜ ÜßÜÛß Û ÛÛÜÜ +ßÛÛÛÛÛÛ Û Û Û ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ + No ÛÛÛÛ Û ßÜß ß Üßß Üß ÛÛ +Üß Û ÜÛÛÜÛßÜÛÛÛÛÜßÜß Û ÛÛÛ +Screen:ÛÛÛÛÛ Substi- ÛÛßß  +ß ß ßß ßß ß ß ß ß ßßß ß  +ßß ß ß ßßÛPrettyÛÛÛÛÛÛ + tutes!" Û Û Û Û ÛÛ ÛÛ ÛßÛ ÛßÛßÛ ÛÛßÛßÛ ÛßÛßÛ ÛÛß +Û ÛßÛ ÛÛ ÛÛ Û Û Û Please ÛÛÛÛÛÛÛÛÛÛÛÛÛÛ +ÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜ + (c) 1991Û + +Downloaded From P-80 International Information Systems 304-744-2253 diff --git a/src/vendormodules/overtype-1.6.0.tm b/src/vendormodules/overtype-1.6.0.tm index 027a6f69..57923538 100644 --- a/src/vendormodules/overtype-1.6.0.tm +++ b/src/vendormodules/overtype-1.6.0.tm @@ -49,6 +49,7 @@ 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] @@ -81,6 +82,9 @@ package require punk::char ;#box drawing - and also unicode character width det # - need to extract and replace ansi codes? namespace eval overtype { + namespace import ::punk::assertion::assert + punk::assertion::active true + namespace export * variable default_ellipsis_horizontal "..." ;#fallback variable default_ellipsis_vertical "..." @@ -258,12 +262,13 @@ proc overtype::left {args} { -exposed1 \uFFFD\ -exposed2 \uFFFD\ -experimental 0\ + -looplimit 15000\ ] #-ellipsis args not used if -wrap is true set argsflags [lrange $args 0 end-2] dict for {k v} $argsflags { switch -- $k { - -width - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental {} + -looplimit - -width - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental {} default { set known_opts [dict keys $defaults] error "overtype::left unknown option '$k'. Known options: $known_opts" @@ -287,20 +292,29 @@ proc overtype::left {args} { set opt_exposed2 [dict get $opts -exposed2] ;#widechar_exposed_right - todo # -- --- --- --- --- --- + #a hack until we work out how to avoid infinite loops... + # + set looplimit [dict get $opts -looplimit] + # ---------------------------- # -experimental dev flag to set flags etc # ---------------------------- set data_mode 0 set test_mode 0 + set info_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 } data_mode { set data_mode 1 } + info_mode { + set info_mode 1 + } } } # ---------------------------- @@ -330,33 +344,38 @@ proc overtype::left {args} { set underlines [lines_as_list -ansiresets 1 $underblock] } - set overlines [split $overblock \n] + #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. + #This works - but doesn't seem efficient. + set inputchunks [split $overblock \n] if {$test_mode} { set lflines [list] - foreach ln $overlines { + foreach ln $inputchunks { append ln \n lappend lflines $ln } - lset lflines end [string range [lindex $lflines end] 0 end-1] - set overlines $lflines[unset lflines] + 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 "" + #lappend replay_codes_overlay "" + set replay_codes_overlay "" set unapplied "" set cursor_saved_position [dict create] set cursor_saved_attributes "" set outputlines $underlines - set underlay_resets [list] set overidx 0 #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set prevrow 1 set row 1 if {$data_mode} { set col [_get_row_append_column $row] @@ -364,25 +383,29 @@ proc overtype::left {args} { set col 1 } - while {$overidx < [llength $overlines]} { - flush stdout + set instruction_stats [dict create] + + set loop 0 + #while {$overidx < [llength $inputchunks]} { } - set overtext [lindex $overlines $overidx]; lset overlines $overidx "" + while {[llength $inputchunks]} { + #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" + set overtext [lpop inputchunks 0] 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 [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] - lappend underlay_resets [list $row [dict get $replay_codes_underlay $row]] } #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 -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] ;# @@ -399,7 +422,8 @@ proc overtype::left {args} { 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] + #lset replay_codes_overlay [expr $overidx+1] [dict get $rinfo replay_codes_overlay] + set replay_codes_overlay [dict get $rinfo replay_codes_overlay] @@ -449,16 +473,6 @@ proc overtype::left {args} { } } - if {$renderedrow <= [llength $outputlines]} { - lset outputlines [expr {$renderedrow-1}] $rendered - } else { - if {$opt_appendlines} { - lappend outputlines $rendered - } else { - #? - lset outputlines [expr {$renderedrow-1}] $rendered - } - } set nextprefix "" @@ -466,6 +480,7 @@ proc overtype::left {args} { #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} { @@ -481,15 +496,12 @@ proc overtype::left {args} { } else { #lf included in data set row $post_render_row - if {$post_render_row != $renderedrow} { - if {$data_mode} { - set col [_get_row_append_column $row] - } else { - set col 1 - } - } else { - set col $post_render_col - } + set col 1 + #if {$post_render_row != $renderedrow} { + # set col 1 + #} else { + # set col $post_render_col + #} } } up { @@ -571,7 +583,9 @@ proc overtype::left {args} { 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 + #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 { @@ -589,6 +603,8 @@ proc overtype::left {args} { #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.. @@ -619,27 +635,164 @@ proc overtype::left {args} { 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 1 { + #rendered + append rendered $overflow_right + #set replay_codes_overlay "" + set overflow_right "" + + + 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 + } else { + + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + set overflow_right "" + set unapplied "" + set row $renderedrow + set col $post_render_col + 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 $insert_lines_above ;#we should end up on the same line of text (at a different index), with new empties inserted 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 { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - 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 + #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 { @@ -666,14 +819,47 @@ proc overtype::left {args} { } 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 incr row set col 1 ;#whether wrap or not - next data is at column 1 if {!$autowrap_mode} { @@ -705,31 +891,54 @@ proc overtype::left {args} { } + 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 $overlines]} { - lappend overlines $nextprefix + if {$nextoveridx >= [llength $inputchunks]} { + lappend inputchunks $nextprefix } else { #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - set overlines [linsert $overlines $nextoveridx $nextprefix] + set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] } } + } + if {$nextprefix ne ""} { + set inputchunks [linsert $inputchunks 0 $nextprefix] + } - #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 prevrow $renderedrow incr overidx + incr loop + if {$loop >= $looplimit} { + puts stderr "overtype::left looplimit reached" + lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" + break + } } - #puts stdout $underlay_resets - return [join $outputlines \n] + + set result [join $outputlines \n] + if {$info_mode} { + append result \n$instruction_stats\n + } + return $result } namespace eval overtype::piper { @@ -1123,7 +1332,11 @@ proc overtype::renderline {args} { -info 0\ -exposed1 \uFFFD\ -exposed2 \uFFFD\ + -cursor_restore_attributes ""\ + -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 @@ -1133,7 +1346,7 @@ proc overtype::renderline {args} { set argsflags [lrange $args 0 end-2] dict for {k v} $argsflags { switch -- $k { - -width - -overflow - -transparent - -startcolumn - -cursor_column - -cursor_row - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 {} + -experimental - -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" @@ -1161,8 +1374,26 @@ proc overtype::renderline {args} { 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 0 + foreach e [dict get $opts -experimental] { + switch -- $e { + test_mode { + set test_mode 1 + set cp437_glyphs 1 + } + } + } + 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"} { @@ -1196,15 +1427,19 @@ proc overtype::renderline {args} { } else { set tw 8 } - if {!$opt_etabs} { - if {[string first \t $under] >= 0} { - #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] - } - set overdata $over - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] + + 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] + } } } #------- @@ -1228,11 +1463,14 @@ proc overtype::renderline {args} { 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 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 + #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. @@ -1243,7 +1481,24 @@ proc overtype::renderline {args} { set width 1 } default { - set width [grapheme_width_cached $grapheme] + 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 + if {[$width == 0]} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] + set grapheme $gvis + set width 1 + } + } + } } } #set width [grapheme_width_cached $grapheme] @@ -1291,53 +1546,84 @@ proc overtype::renderline {args} { #consider also if there are other codes that should be stacked..? } - - #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 {!$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] + } + } } - 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] } - #trailing codes in effect for underlay + 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]} { - #dict set understacks [expr {$i_u + 1}] $u_codestack ;#This is one column higher than our input lappend understacks $u_codestack - #set replay_codes_underlay [join $u_codestack ""] - set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] - - # For gx we need the column after the data too ? - #dict set understacks_gx [expr {$i_u +1}] $u_gx_stack lappend understacks_gx $u_gx_stack } else { - set replay_codes_underlay "" #in case overlay onto emptystring as underlay - #dict set understacks 0 [list] lappend understacks [list] - #dict set understacks_gx 0 [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 really) padding on the left of the right number of columns. + #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 @@ -1346,11 +1632,14 @@ proc overtype::renderline {args} { #??? 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] @@ -1359,14 +1648,20 @@ proc overtype::renderline {args} { 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 { + 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 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 @@ -1374,6 +1669,7 @@ proc overtype::renderline {args} { # 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] @@ -1387,6 +1683,16 @@ proc overtype::renderline {args} { 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. + 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"] @@ -1487,212 +1793,220 @@ proc overtype::renderline {args} { incr idx [grapheme_width_cached $ch] continue } - - - set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width - - - 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 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. + + 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 "---b at column 1" + #leave the overflow_idx + set instruction lf_start ;#specific instruction for newline at column 1 + #idx_over already incremented + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { + puts "---c at overflow_idx=$overflow_idx" + + # - review special treatment? + incr cursor_row + #override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 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? + #set insert_lines_below 1 + #set instruction newlines_below + set instruction lf_overflow + #idx_over already incremented + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" + #linefeed occurred in middle or at end of text + incr cursor_row + #override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 + set overflow_idx $idx + #set insert_lines_below 1 + #set instruction newlines_below + set instruction lf_mid + #idx_over already incremented + priv::render_unapplied $overlay_grapheme_control_list $gci + break } - } elseif {$idx == $overflow_idx} { - #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 - set instruction overflow + + } + "" { + #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 } - } 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) - - } - - + 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])} { - #todo - move this branch of the if - #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} { + 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 - } - } 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 + } 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 - } else { - if {[regexp $opt_transparent $next_pt_overchar]} { - 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 { - #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 + #? 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 { - #? 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 chtest [string map [list \n \b \r \v \x7f ] $ch] - #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached - switch -- $chtest { - "" { - if 1 { - - - if {$idx == 0} { - #leave the overflow_idx - set insert_lines_above 1 ;#keep for consistency with ansi sequence that requests insertion of line(s)? - set instruction newlines_above - #idx_over already incremented - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } elseif {$idx > $overflow_idx} { - incr cursor_row - #todo - - } else { - #linefeed occurred in middle or at end of text - incr cursor_row - #override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set overflow_idx $idx - set insert_lines_below 1 - set instruction newlines_below - #idx_over already incremented - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } - - - } else { - #v1 - incr cursor_row - - #override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set overflow_idx $idx - #idx_over already incremented - priv::render_unapplied $overlay_grapheme_control_list $gci + } else { - if {$idx == 0} { - set insert_lines_above 1 ;#keep for consistency with ansi sequence that requests insertion of line(s)? - set instruction newlines_above - } else { - set insert_lines_below 1 - set instruction newlines_below - } - break - } - } - "" { - #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 + 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 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 - } + set uwidth [grapheme_width_cached $idxchar] } - } - "" { - #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. - 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 { - - #non-transparent char in overlay - set uwidth [grapheme_width_cached [lindex $outcols $idx]] if {$within_undercols} { - if {[lindex $outcols $idx] eq ""} { + 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 @@ -1726,8 +2040,12 @@ proc overtype::renderline {args} { 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 @@ -1738,6 +2056,7 @@ proc overtype::renderline {args} { 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 @@ -1795,8 +2114,8 @@ proc overtype::renderline {args} { } } } - } ;# end switch - } + } + } ;# end switch } @@ -1823,12 +2142,33 @@ proc overtype::renderline {args} { #cursor back #left-arrow/move-back when ltr mode if {$num eq ""} {set num 1} - 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 + + 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 { @@ -1855,7 +2195,8 @@ proc overtype::renderline {args} { incr idx $num incr cursor_column $num } else { - if {$opt_autowrap_mode} { + if {$autowrap_mode} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] if {$idx == $overflow_idx} { incr num } @@ -1939,6 +2280,7 @@ proc overtype::renderline {args} { lassign $matchinfo _match num type switch -- $type { A { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] #move up if {$num eq ""} {set num 1} incr cursor_row -$num @@ -1955,6 +2297,7 @@ proc overtype::renderline {args} { break } B { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] set row_before_move $cursor_row #move down if {$num eq ""} {set num 1} @@ -1970,6 +2313,7 @@ proc overtype::renderline {args} { } }\ $re_both_move { + 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} @@ -2063,7 +2407,16 @@ proc overtype::renderline {args} { }\ $re_cursor_save - $re_cursor_save_dec { - set cursor_saved_position [list row $cursor_row column $cursor_column] + #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 @@ -2126,11 +2479,19 @@ proc overtype::renderline {args} { #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 - #lset overstacks $idx_over [list] - set replay_codes_overlay "" set unapplied "" foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { @@ -2200,19 +2561,18 @@ proc overtype::renderline {args} { } } - #-------------- - - + #-------- 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 + #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 @@ -2231,69 +2591,90 @@ proc overtype::renderline {args} { 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]} { + append sgrleader \033\[m + } + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + } + set prevstack $cstack + } else { + set prevstack [list] + } + + + if {$in_overflow} { - #ch could be a control-sequence or a grapheme once in overflow if {$i == $overflow_idx} { - #only run when we exactly hit overflow_idx - if {$i < [llength $understacks_gx]} { - #set g0 [dict get $understacks_gx $i] - set g0 [lindex $understacks_gx $i] - if {[llength $g0]} { - append outstring "\x1b(B" - } + 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" } - #add first codestack only - if {$i < [llength $understacks]} { - set cstack [lindex $understacks $i] - #append overflow_right [join $cstack ""] - append overflow_right [punk::ansi::codetype::sgr_merge_list {*}$cstack] + 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 } - 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 } } - - 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"]} { - append outstring "\x1b(0" - } else { - append outstring "\x1b(B" - } - } - set prev_g0 $g0 - } else { - set prev_g0 [list] - } - #code replay when not in overflow - if {$i < [llength $understacks]} { - #set cstack [dict get $understacks $i] - set cstack [lindex $understacks $i] - if {$cstack ne $prevstack} { - if {[llength $prevstack]} { - append outstring \033\[m - } - append outstring [punk::ansi::codetype::sgr_merge_list {*}$cstack] - } - set prevstack $cstack + append outstring $gxleader + append outstring $sgrleader + if {$idx+1 < $cursor_column} { + append outstring [string map [list "\u0000" " "] $ch] } else { - set prevstack [list] + append outstring $ch } - 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} { @@ -2321,10 +2702,15 @@ proc overtype::renderline {args} { #pdict $understacks if {[punk::ansi::ta::detect_sgr $outstring]} { append outstring [punk::ansi::a] + #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 @@ -2334,7 +2720,7 @@ proc overtype::renderline {args} { } else { set overflow_right_column [expr {$overflow_idx+1}] } - return [list\ + set result [dict create\ result $outstring\ visualwidth [punk::ansi::printing_length $outstring]\ instruction $instruction\ @@ -2355,6 +2741,29 @@ proc overtype::renderline {args} { 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 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 } @@ -2419,11 +2828,13 @@ namespace eval overtype::priv { upvar unapplied unapplied 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 "" #append unapplied [join [lindex $overstacks $idx_over] ""] - append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] + #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] + append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] switch -- [lindex $overstacks_gx $idx_over] { "gx0_on" { append unapplied "\x1b(0" @@ -2447,6 +2858,41 @@ namespace eval overtype::priv { } } } + + #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 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 "" + append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + append unapplied "\x1b(0" + } + "gx0_off" { + append unapplied "\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"} { + append unapplied "\x1b(0" + } elseif {$item eq "gx0_off"} { + append unapplied "\x1b(B" + } + } else { + append unapplied $item + } + } + } proc render_delchar {i} { upvar outcols o upvar understacks ustacks @@ -2466,15 +2912,28 @@ namespace eval overtype::priv { 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 o $c lappend ustacks $sgrstack lappend gxstacks $gx0stack } @@ -2482,10 +2941,13 @@ namespace eval overtype::priv { #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 o $c lappend ustacks $sgrstack lappend gxstacks $gx0stack }