From bdef7af0bbfd0ba3d6d0fbff07d0015f99dd292c Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 28 Aug 2025 21:24:34 +1000 Subject: [PATCH] bootsupport and vendormodule minor tidy/update --- src/bootsupport/modules/oolib-0.1.tm | 195 - src/bootsupport/modules/punk-0.1.tm | 44 +- src/bootsupport/modules/punk/char-0.1.0.tm | 63 + src/bootsupport/modules/punk/mix/cli-0.3.1.tm | 7 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 29 +- src/bootsupport/modules/shellfilter-0.1.9.tm | 3209 ----------- src/bootsupport/modules/textblock-0.1.3.tm | 107 +- .../modules/uuid-1.0.9.tm} | 6 +- src/bootsupport/modules/zipper-0.12.tm | Bin 9842 -> 9848 bytes .../zipper-999999.0a1.0.tm | 3 +- src/modules/punk/mix-0.1.tm | 87 - src/modules/punk/mix/cli-999999.0a1.0.tm | 7 +- .../src/bootsupport/modules/punk-0.1.tm | 44 +- .../bootsupport/modules/punk/char-0.1.0.tm | 63 + .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 7 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 29 +- .../bootsupport/modules/textblock-0.1.3.tm | 107 +- .../src/bootsupport/modules/uuid-1.0.9.tm} | 6 +- .../src/bootsupport/modules/zipper-0.12.tm | Bin 9842 -> 9848 bytes .../src/bootsupport/modules/punk-0.1.tm | 44 +- .../bootsupport/modules/punk/char-0.1.0.tm | 63 + .../bootsupport/modules/punk/mix/cli-0.3.1.tm | 7 +- .../punk/mix/commandset/scriptwrap-0.1.0.tm | 29 +- .../bootsupport/modules/textblock-0.1.3.tm | 107 +- .../src/bootsupport/modules/uuid-1.0.9.tm} | 5 +- .../src/bootsupport/modules/zipper-0.12.tm | Bin 9842 -> 9848 bytes src/vendormodules/modpod-0.1.2.tm | 702 --- src/vendormodules/overtype-1.6.5.tm | 4773 ----------------- src/vendormodules/packagetrace-0.8.tm | 643 --- src/vendormodules/uuid-1.0.9.tm | 245 + .../modules/modpodtest-0.1.0.tm | Bin 9333 -> 9348 bytes .../_vfscommon.vfs/modules/punk/char-0.1.0.tm | 2 +- .../modules/punk/mix/cli-0.3.1.tm | 7 +- src/vfs/_vfscommon.vfs/modules/uuid-1.0.9.tm | 245 + src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm | Bin 9842 -> 9848 bytes 35 files changed, 1166 insertions(+), 9719 deletions(-) delete mode 100644 src/bootsupport/modules/oolib-0.1.tm delete mode 100644 src/bootsupport/modules/shellfilter-0.1.9.tm rename src/{vendormodules/uuid-1.0.7.tm => bootsupport/modules/uuid-1.0.9.tm} (98%) delete mode 100644 src/modules/punk/mix-0.1.tm rename src/{bootsupport/modules/uuid-1.0.7.tm => project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.9.tm} (98%) rename src/{bootsupport/modules/uuid-1.0.8.tm => project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.9.tm} (98%) delete mode 100644 src/vendormodules/modpod-0.1.2.tm delete mode 100644 src/vendormodules/overtype-1.6.5.tm delete mode 100644 src/vendormodules/packagetrace-0.8.tm create mode 100644 src/vendormodules/uuid-1.0.9.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/uuid-1.0.9.tm diff --git a/src/bootsupport/modules/oolib-0.1.tm b/src/bootsupport/modules/oolib-0.1.tm deleted file mode 100644 index 3756fceb..00000000 --- a/src/bootsupport/modules/oolib-0.1.tm +++ /dev/null @@ -1,195 +0,0 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key > 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - method alias {newAlias existingKeyOrAlias} { - if {[string is integer -strict $newAlias]} { - error "[self object] collection key alias cannot be integer" - } - if {[string length $existingKeyOrAlias]} { - set o_alias($newAlias) $existingKeyOrAlias - } else { - unset o_alias($newAlias) - } - } - method aliases {{key ""}} { - if {[string length $key]} { - set result [list] - foreach {n v} [array get o_alias] { - if {$v eq $key} { - lappend result $n $v - } - } - return $result - } else { - return [array get o_alias] - } - } - #if the supplied index is an alias, return the underlying key; else return the index supplied. - method realKey {idx} { - if {[catch {set o_alias($idx)} key]} { - return $idx - } else { - return $key - } - } - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse {} { - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index f6b5aa6a..1e09252d 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/modules/punk-0.1.tm @@ -8259,9 +8259,29 @@ namespace eval punk { interp alias {} d/~ {} punk::nav::fs::d/~ interp alias "" x/ "" punk::nav::fs::x/ + variable pshell_path "" + # ---------------------------------------- + set pshell_path [auto_execok pwsh] ;#Still not installed by default on win10 11? + if {$pshell_path eq ""} { + #fallback to powershell 5 + #set pshell_path [auto_execok powershell] + set pshell_path powershell ;#temp + } else { + set pshell_path pwsh ;#temp + } + #todo - review run commands and handling of paths with spaces + # ---------------------------------------- - if {$::tcl_platform(platform) eq "windows"} { + + + if {$pshell_path eq ""} { + set has_powershell 0 + } else { + #todo - review powershell detection on non-windows platforms set has_powershell 1 + } + + if {$::tcl_platform(platform) eq "windows"} { interp alias {} dl {} dir /q interp alias {} dw {} dir /W/D } else { @@ -8269,8 +8289,6 @@ namespace eval punk { #interp alias {} dl {} interp alias {} dl {} puts stderr "not implemented" interp alias {} dw {} puts stderr "not implemented" - #todo - powershell detection on other platforms - set has_powershell 0 } #todo - distinguish non-preinstalled pwsh (powershell core) from powershell which is available by default @@ -8279,13 +8297,19 @@ namespace eval punk { # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() # $ps = [Powershell]::Create() - interp alias {} pse {} exec >@stdout pwsh -nolo -nop -c - interp alias {} psx {} runx -n pwsh -nop -nolo -c - interp alias {} psr {} run -n pwsh -nop -nolo -c - interp alias {} psout {} runout -n pwsh -nop -nolo -c - interp alias {} pserr {} runerr -n pwsh -nop -nolo -c - interp alias {} psls {} shellrun::runconsole pwsh -nop -nolo -c ls - interp alias {} psps {} shellrun::runconsole pwsh -nop -nolo -c ps + interp alias {} pse {} exec >@stdout {*}$pshell_path -nolo -nop -c + interp alias {} psx {} runx -n {*}$pshell_path -nop -nolo -c + interp alias {} psr {} run -n {*}$pshell_path -nop -nolo -c + interp alias {} psout {} runout -n {*}$pshell_path -nop -nolo -c + interp alias {} pserr {} runerr -n {*}$pshell_path -nop -nolo -c + #interp alias {} psls {} shellrun::runconsole $pshell_path -nop -nolo -c ls + #interp alias {} psls {} shellrun::runconsole {*}$pshell_path -nop -nolo -c {ls | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table} + proc psls args { + variable pshell_path + shellrun::runconsole {*}$pshell_path -nop -nolo -c {*}[string map [list %a% $args] {{ls %a% | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table}}] + } + interp alias {} psls {} punk::psls + interp alias {} psps {} shellrun::runconsole {*}$pshell_path -nop -nolo -c ps } else { set ps_missing "powershell missing (powershell is MIT licensed open source and can be installed on windows and most unix-like platforms)" interp alias {} pse {} puts stderr $ps_missing diff --git a/src/bootsupport/modules/punk/char-0.1.0.tm b/src/bootsupport/modules/punk/char-0.1.0.tm index 69df08b9..c8195b6e 100644 --- a/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/bootsupport/modules/punk/char-0.1.0.tm @@ -2761,6 +2761,69 @@ tcl::namespace::eval punk::char { } +tcl::namespace::eval punk::char::lib { + variable num_superscript + #digits and a small set of related symbols + set num_superscript [list\ + i \u2071\ + 0 \u2070\ + 1 \u00B9\ + 2 \u00B2\ + 3 \u00B3\ + 4 \u2074\ + 5 \u2075\ + 6 \u2076\ + 7 \u2077\ + 8 \u2078\ + 9 \u2079\ + + \u207A\ + - \u207B\ + = \u207C\ + ( \u207D\ + ) \u207E\ + n \u207F\ + ] + variable num_supersub_re + set num_supersub_re {^[0-9in+\-\(\)\=]+$} + proc superscript_number {n} { + if {$n eq ""} {return ""} + variable num_superscript + variable num_supersub_re + if {![regexp $num_supersub_re $n]} { + error "Cannot convert string '$n' to superscript. valid chars: [dict keys $num_superscript]" + } + return [string map $num_superscript $n] + } + set num_subscript [list\ + i \u1D62\ + 0 \u2080\ + 1 \u2081\ + 2 \u2082\ + 3 \u2083\ + 4 \u2084\ + 5 \u2085\ + 6 \u2086\ + 7 \u2087\ + 8 \u2088\ + 9 \u2089\ + + \u208A\ + - \u208B\ + = \u208C\ + ( \u208D\ + ) \u208E\ + n \u2099\ + ] + proc subscript_number {n} { + if {$n eq ""} {return ""} + variable num_subscript + variable num_supersub_re + if {![regexp $num_supersub_re $n]} { + error "Cannot convert string '$n' to subcript. valid chars: [dict keys $num_subscript]" + } + return [string map $num_subscript $n] + } +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index afd06d2a..17c9918b 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -759,7 +759,7 @@ namespace eval punk::mix::cli { } } else { - puts -nonewline stderr "P" + puts -nonewline stderr "Z" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $build_event targetset_end SKIPPED @@ -791,7 +791,7 @@ namespace eval punk::mix::cli { $event targetset_end OK -note "zip modpod" } } else { - puts -nonewline stderr "p" + puts -nonewline stderr "z" set did_skip 1 if {$is_interesting} { puts stderr "$modulefile [$event targetset_source_changes]" @@ -802,7 +802,8 @@ namespace eval punk::mix::cli { } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar ? + } file { set m $modpath diff --git a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index ef3e2a2f..85ef0692 100644 --- a/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -257,6 +257,24 @@ namespace eval punk::mix::commandset::scriptwrap { set target_labels_found [dict create] set possible_target_labels_found [dict create] set warning_target_labels_found [dict create] + + #todo - allow analysis of colon-less call. May need to check list of internal commands - but what about external ones? + #set searchregexex [list {(.*\s+|^)(@*call\s*:*)(\S.*)} {(.*\s+|^)(@*CALL\s*:*)(\S.*)} {(.*\s+|^)(@*goto\s*:*)(\S.*)} {(.*\s+|^)(@*GOTO\s*:*)(\S.*)}] + + #order of regex testing is important - test more specific entries with colon/comment before we test whitespace only version of goto/call + set searchregexes [list {(.*\s+|^)(@*call\s*:)(\S.*)} {(.*\s+|^)(@*CALL\s*:)(\S.*)} {(.*\s+|^)(@*goto\s*:)(\S.*)} {(.*\s*|.*\s+|^)(@*GOTO\s*:)(\S.*)}] + lappend searchregexes {(.*\|\|.*)(@*GOTO\s*:)(\S.*)} ;#review + lappend searchregexes {(.*\s+|^)(@*goto\s+%=.*=%\s*:)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*goto\s+%=.*=%\s+)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*goto\s+)(\S.*)} + + lappend searchregexes {(.*\s+|^)(@*GOTO\s+%=.*=%\s*:)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*GOTO\s+%=.*=%\s+)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*GOTO\s+)(\S.*)} + #review + #todo - better callsite analysis. There can be data between @GOTO or @CALL and : other than just whitespace + #e.g for @goto %= possible comment=% :mylabe%%l etc + for {set callingline_index 0} {$callingline_index < $line_count} {incr callingline_index} { set callingline_info [$objFile lineinfo $callingline_index] set callingline_payload [dict get $callingline_info payload] @@ -273,18 +291,15 @@ namespace eval punk::mix::commandset::scriptwrap { } default { - #todo - better callsite analysis. There can be data between @GOTO or @CALL and : other than just whitespace! - #todo - allow analysis of colon-less call. May need to check list of internal commands - but what about external ones? - #foreach search_regex [list {(.*\s+|^)(@*call\s*:*)(\S.*)} {(.*\s+|^)(@*CALL\s*:*)(\S.*)} {(.*\s+|^)(@*goto\s*:*)(\S.*)} {(.*\s+|^)(@*GOTO\s*:*)(\S.*)}] {} - foreach search_regex [list {(.*\s+|^)(@*call\s*:)(\S.*)} {(.*\s+|^)(@*CALL\s*:)(\S.*)} {(.*\s+|^)(@*goto\s*:)(\S.*)} {(.*\s*|.*\s+|^)(@*GOTO\s*:)(\S.*)} {(.*\|\|.*)(@*GOTO\s*:)(\S.*)}] { + foreach search_regex $searchregexes { if {[regexp $search_regex $callingline_payload _m precall call labelplus]} { #todo further checks to see if it's actually a batch script line # - - - - work out what cmd.exe considers start of 512B boundaries when scanning from a callsite #callposn affected by newlines? #set callposn [expr {$file_offset + [string length $callingline_payload]}] ;#take callposn as end of line .. review - multiline statements? - set callposn [expr {$file_offset + $callingline_len}] - + set callposn [expr {$file_offset + $callingline_len -1}] + #Note there are anomalies around target labels in bracketed sections such as IF blocks #this is bad practice - as it can lead to unbalanced braces - but batch files can still work under cmd.exe with them in some cases #e.g unbalanced trailing bracket may be ignored. @@ -1741,7 +1756,7 @@ namespace eval punk::mix::commandset::scriptwrap { #note that: #@REM ----- #@goto ^ - #:label + #:label #@REM----- # is a valid callsite - but doesn't appear to be found by the label scanner as it's own target label even though :label is on it's own line from non-batch perspective # so the caller will have to do some batch-style line processing to find all call sites diff --git a/src/bootsupport/modules/shellfilter-0.1.9.tm b/src/bootsupport/modules/shellfilter-0.1.9.tm deleted file mode 100644 index 73ea752c..00000000 --- a/src/bootsupport/modules/shellfilter-0.1.9.tm +++ /dev/null @@ -1,3209 +0,0 @@ -#copyright 2023 Julian Marcel Noble -#license: BSD (revised 3-clause) -# -#Note shellfilter is currently only directly useful for unidirectional channels e.g stdin,stderr,stdout, or for example fifo2 where only one direction is being used. -#To generalize this to bidrectional channels would require shifting around read & write methods on transform objects in a very complicated manner. -#e.g each transform would probably be a generic transform container which holds sub-objects to which read & write are indirected. -#This is left as a future exercise...possibly it's best left as a concept for uni-directional channels anyway -# - as presumably the reads/writes from a bidirectional channel could be diverted off to unidirectional pipelines for processing with less work -# (and maybe even better speed/efficiency if the data volume is asymmetrical and there is significant processing on one direction) -# - - -tcl::namespace::eval shellfilter::log { - variable allow_adhoc_tags 1 - variable open_logs [tcl::dict::create] - variable is_enabled 0 - - proc disable {} { - variable is_enabled - set is_enabled 0 - proc ::shellfilter::log::open {tag settingsdict} {} - proc ::shellfilter::log::write {tag msg} {} - proc ::shellfilter::log::write_sync {tag msg} {} - proc ::shellfilter::log::close {tag} {} - } - - proc enable {} { - variable is_enabled - set is_enabled 1 - #'tag' is an identifier for the log source. - # each tag will use it's own thread to write to the configured log target - proc ::shellfilter::log::open {tag {settingsdict {}}} { - upvar ::shellfilter::sources sourcelist - if {![dict exists $settingsdict -tag]} { - tcl::dict::set settingsdict -tag $tag - } else { - #review - if {$tag ne [tcl::dict::get $settingsdict -tag]} { - error "shellfilter::log::open first argument tag: '$tag' does not match -tag '[tcl::dict::get $settingsdict -tag]' omit -tag, or supply same value" - } - } - if {$tag ni $sourcelist} { - lappend sourcelist $tag - } - - #note new_worker - set worker_tid [shellthread::manager::new_worker $tag $settingsdict] - #puts stderr "shellfilter::log::open this_threadid: [thread::id] tag: $tag worker_tid: $worker_tid" - return $worker_tid - } - proc ::shellfilter::log::write {tag msg} { - upvar ::shellfilter::sources sourcelist - variable allow_adhoc_tags - if {!$allow_adhoc_tags} { - if {$tag ni $sourcelist} { - error "shellfilter::log::write tag '$tag' hasn't been initialised with a call to shellfilter::log::open $tag , and allow_adhoc_tags has been set false. use shellfilter::log::require_open false to allow adhoc tags" - } - } - shellthread::manager::write_log $tag $msg - } - #write_sync - synchronous processing with logging thread, slower but potentially useful for debugging/testing or forcing delay til log written - proc ::shellfilter::log::write_sync {tag msg} { - shellthread::manager::write_log $tag $msg -async 0 - } - proc ::shellfilter::log::close {tag} { - #shellthread::manager::close_worker $tag - shellthread::manager::unsubscribe [list $tag]; #workertid will be added back to free list if no tags remain subscribed - } - - } - - #review - #configure whether we can call shellfilter::log::write without having called open first - proc require_open {{is_open_required {}}} { - variable allow_adhoc_tags - if {![string length $is_open_required]} { - return $allow_adhoc_tags - } else { - set truevalues [list y yes true 1] - set falsevalues [list n no false 0] - if {[string tolower $is_open_required] in $truevalues} { - set allow_adhoc_tags 1 - } elseif {[string tolower $is_open_required] in $falsevalues} { - set allow_adhoc_tags 0 - } else { - error "shellfilter::log::require_open unrecognised value '$is_open_required' try one of $truevalues or $falsevalues" - } - } - } - if {[catch {package require shellthread}]} { - shellfilter::log::disable - } else { - shellfilter::log::enable - } - -} -namespace eval shellfilter::pipe { - #write channel for program. workerthread reads other end of fifo2 and writes data somewhere - proc open_out {tag_pipename {pipesettingsdict {}}} { - set defaultsettings {-buffering full} - set settingsdict [dict merge $defaultsettings $pipesettingsdict] - package require shellthread - #we are only using the fifo in a single direction to pipe to another thread - # - so whilst wchan and rchan could theoretically each be both read & write we're only using them for one operation each - if {![catch {package require Memchan}]} { - lassign [fifo2] wchan rchan - } else { - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - } - #default -translation for both types of fifo on windows is {auto crlf} - # -encoding is as per '[encoding system]' on the platform - e.g utf-8 (e.g windows when beta-utf8 enabled) - chan configure $wchan -buffering [dict get $settingsdict -buffering] ;# - #application end must not be binary for our filters to operate on it - - - #chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation binary ;#works reasonably.. - chan configure $rchan -buffering [dict get $settingsdict -buffering] -translation lf - - set worker_tid [shellthread::manager::new_pipe_worker $tag_pipename $settingsdict] - #puts stderr "worker_tid: $worker_tid" - - #set_read_pipe does the thread::transfer of the rchan end. -buffering setting is maintained during thread transfer - shellthread::manager::set_pipe_read_from_client $tag_pipename $worker_tid $rchan - - set pipeinfo [list localchan $wchan remotechan $rchan workertid $worker_tid direction out] - return $pipeinfo - } - - #read channel for program. workerthread writes to other end of fifo2 from whereever it's reading (stdin, file?) - proc open_in {tag_pipename {settingsdict {} }} { - package require shellthread - package require tcl::chan::fifo2 - lassign [tcl::chan::fifo2] wchan rchan - set program_chan $rchan - set worker_chan $wchan - chan configure $worker_chan -buffering [dict get $settingsdict -buffering] - chan configure $program_chan -buffering [dict get $settingsdict -buffering] - - chan configure $program_chan -blocking 0 - chan configure $worker_chan -blocking 0 - set worker_tid [shellthread::manager::new_worker $tag_pipename $settingsdict] - - shellthread::manager::set_pipe_write_to_client $tag_pipename $worker_tid $worker_chan - - set pipeinfo [list localchan $program_chan remotechan $worker_chan workertid $worker_tid direction in] - puts stderr "|jn>pipe::open_in returning $pipeinfo" - puts stderr "program_chan: [chan conf $program_chan]" - return $pipeinfo - } - -} - - - -namespace eval shellfilter::ansi { - #maint warning - - #ansistrip from punk::ansi is better/more comprehensive - proc stripcodes {text} { - #obsolete? - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. - #line endings can theoretically occur within an ansi escape sequence (review e.g title?) - set inputlist [split $text ""] - set outputlist [list] - - #self-contained 2 byte ansi escape sequences - review more? - set 2bytecodes_dict [dict create\ - "reset_terminal" "\033c"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - ] - set 2bytecodes [dict values $2bytecodes_dict] - - set in_escapesequence 0 - #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls - set i 0 - foreach u $inputlist { - set v [lindex $inputlist $i+1] - set uv ${u}${v} - if {$in_escapesequence eq "2b"} { - #2nd byte - done. - set in_escapesequence 0 - } elseif {$in_escapesequence != 0} { - set escseq [dict get $escape_terminals $in_escapesequence] - if {$u in $escseq} { - set in_escapesequence 0 - } elseif {$uv in $escseq} { - set in_escapseequence 2b ;#flag next byte as last in sequence - } - } else { - #handle both 7-bit and 8-bit CSI and OSC - if {[regexp {^(?:\033\[|\u009b)} $uv]} { - set in_escapesequence CSI - } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { - set in_escapesequence OSC - } elseif {$uv in $2bytecodes} { - #self-contained e.g terminal reset - don't pass through. - set in_escapesequence 2b - } else { - lappend outputlist $u - } - } - incr i - } - return [join $outputlist ""] - } - -} -namespace eval shellfilter::chan { - set testobj ::shellfilter::chan::var - if {$testobj ni [info commands $testobj]} { - - oo::class create var { - variable o_datavar - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - set varname [dict get $settingsdict -varname] - set o_datavar $varname - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 1 ;# as a var is diversionary - default it to be a jucntion - } - } - method initialize {ch mode} { - return [list initialize finalize write] - } - method finalize {ch} { - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method write {ch bytes} { - set stringdata [encoding convertfrom $o_enc $bytes] - append $o_datavar $stringdata - return "" - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line full none] - } - } - - #todo - something similar for multiple grep specs each with own -pre & -post .. store to dict? - oo::class create tee_grep_to_var { - variable o_datavar - variable o_lastxlines - variable o_trecord - variable o_grepfor - variable o_prelines - variable o_postlines - variable o_postcountdown - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set o_lastxlines [list] - set o_postcountdown 0 - set defaults [tcl::dict::create -pre 1 -post 1] - set settingsdict [tcl::dict::get $tf -settings] - set settings [tcl::dict::merge $defaults $settingsdict] - set o_datavar [tcl::dict::get $settings -varname] - set o_grepfor [tcl::dict::get $settings -grep] - set o_prelines [tcl::dict::get $settings -pre] - set o_postlines [tcl::dict::get $settings -post] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize finalize write] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - set lastx $o_lastxlines - lappend o_lastxlines $logdata - - if {$o_postcountdown > 0} { - append $o_datavar $logdata - if {[regexp $o_grepfor $logdata]} { - #another match in postlines - set o_postcountdown $o_postlines - } else { - incr o_postcountdown -1 - } - } else { - if {[regexp $o_grepfor $logdata]} { - append $o_datavar [join $lastx] - append $o_datavar $logdata - set o_postcountdown $o_postlines - } - } - - if {[llength $o_lastxlines] > $o_prelines} { - set o_lastxlines [lrange $o_lastxlines 1 end] - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - method meta_buffering_supported {} { - return [list line] - } - } - - oo::class create tee_to_var { - variable o_datavars - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - set varname [tcl::dict::get $settingsdict -varname] - set o_datavars $varname - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize finalize write flush clear] - } - method finalize {ch} { - my destroy - } - method clear {ch} { - return - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {ch count} { - # return ? - #} - method flush {ch} { - return "" - } - method write {ch bytes} { - set stringdata [tcl::encoding::convertfrom $o_enc $bytes] - foreach v $o_datavars { - append $v $stringdata - } - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - oo::class create tee_to_pipe { - variable o_logsource - variable o_localchan - variable o_enc - variable o_trecord - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "tee_to_pipe constructor settingsdict missing -tag" - } - set o_localchan [tcl::dict::get $settingsdict -pipechan] - set o_logsource [tcl::dict::get $settingsdict -tag] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize read drain write flush clear finalize] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - method clear {transform_handle} { - return - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - #::shellfilter::log::write $o_logsource $logdata - puts -nonewline $o_localchan $logdata - return $bytes - } - #a tee is not a redirection - because data still flows along the main path - method meta_is_redirection {} { - return $o_is_junction - } - - } - oo::class create tee_to_log { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {![tcl::dict::exists $settingsdict -tag]} { - error "tee_to_log constructor settingsdict missing -tag" - } - set o_logsource [tcl::dict::get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {ch mode} { - return [list initialize read write finalize] - } - method finalize {ch} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {ch events} { - # must be present but we ignore it because we do not - # post any events - } - method read {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method write {ch bytes} { - set logdata [tcl::encoding::convertfrom $o_enc $bytes] - ::shellfilter::log::write $o_logsource $logdata - return $bytes - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - - oo::class create logonly { - variable o_tid - variable o_logsource - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {![dict exists $settingsdict -tag]} { - error "logonly constructor settingsdict missing -tag" - } - set o_logsource [dict get $settingsdict -tag] - set o_tid [::shellfilter::log::open $o_logsource $settingsdict] - } - method initialize {transform_handle mode} { - return [list initialize finalize write] - } - method finalize {transform_handle} { - ::shellfilter::log::close $o_logsource - my destroy - } - method watch {transform_handle events} { - # must be present but we ignore it because we do not - # post any events - } - #method read {transform_handle count} { - # return ? - #} - method write {transform_handle bytes} { - set logdata [encoding convertfrom $o_enc $bytes] - if 0 { - if {"utf-16le" in [encoding names]} { - set logdata [encoding convertfrom utf-16le $bytes] - } else { - set logdata [encoding convertto utf-8 $bytes] - #set logdata [encoding convertfrom unicode $bytes] - #set logdata $bytes - } - } - #set logdata $bytes - #set logdata [string map [list \r -r- \n -n-] $logdata] - #if {[string equal [string range $logdata end-1 end] "\r\n"]} { - # set logdata [string range $logdata 0 end-2] - #} - #::shellfilter::log::write_sync $o_logsource $logdata - ::shellfilter::log::write $o_logsource $logdata - #return $bytes - return - } - method meta_is_redirection {} { - return 1 - } - } - - #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) - # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) - #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion - #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! - oo::class create ansistrip { - variable o_trecord - variable o_enc - variable o_is_junction - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [dict get $tf -encoding] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - } - method initialize {transform_handle mode} { - return [list initialize read write clear flush drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method clear {transform_handle} { - return - } - method watch {transform_handle events} { - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method flush {transform_handle} { - return "" - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::ansistrip $instring] - return [encoding convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - - #a test - oo::class create reconvert { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - } - oo::define reconvert { - method meta_is_redirection {} { - return 0 - } - } - - - #this isn't a particularly nice thing to do to a stream - especially if someone isn't expecting ansi codes sprinkled through it. - #It can be useful for test/debugging - #Due to chunking at random breaks - we have to check if an ansi code in the underlying stream has been split - otherwise our wrapping will break the existing ansi - # - set sixelstart_re {\x1bP([;0-9]*)q} ;#7-bit - todo 8bit - #todo kitty graphics \x1b_G... - #todo iterm graphics - - oo::class create ansiwrap { - variable o_trecord - variable o_enc - variable o_colour - variable o_do_colour - variable o_do_normal - variable o_is_junction - variable o_codestack - variable o_gx_state ;#on/off alt graphics - variable o_buffered - constructor {tf} { - package require punk::ansi - set o_trecord $tf - set o_enc [tcl::dict::get $tf -encoding] - set settingsdict [tcl::dict::get $tf -settings] - if {[tcl::dict::exists $settingsdict -colour]} { - set o_colour [tcl::dict::get $settingsdict -colour] - set o_do_colour [punk::ansi::a+ {*}$o_colour] - set o_do_normal [punk::ansi::a] - } else { - set o_colour {} - set o_do_colour "" - set o_do_normal "" - } - set o_codestack [list] - set o_gx_state [expr {off}] - set o_buffered "" ;#hold back data that potentially contains partial ansi codes - if {[tcl::dict::exists $tf -junction]} { - set o_is_junction [tcl::dict::get $tf -junction] - } else { - set o_is_junction 0 - } - } - - - #todo - track when in sixel,iterm,kitty graphics data - can be very large - method Trackcodes {chunk} { - #note - caller can use 2 resets in a single unit to temporarily reset to no sgr (override ansiwrap filter) - #e.g [a+ reset reset] (0;0m vs 0;m) - - #puts stdout "===[ansistring VIEW -lf 1 $o_buffered]" - set buf $o_buffered$chunk - set emit "" - if {[string last \x1b $buf] >= 0} { - #detect will detect ansi SGR and gron groff and other codes - if {[punk::ansi::ta::detect $buf]} { - #split_codes_single regex faster than split_codes - but more resulting parts - #'single' refers to number of escapes - but can still contain e.g multiple SGR codes (or mode set operations etc) - set parts [punk::ansi::ta::split_codes_single $buf] - #process all pt/code pairs except for trailing pt - foreach {pt code} [lrange $parts 0 end-1] { - #puts "<==[ansistring VIEW -lf 1 $pt]==>" - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$pt - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # append emit $o_do_colour$pt$o_do_normal - # #append emit $pt - #} else { - # append emit $pt - #} - - set c1c2 [tcl::string::range $code 0 1] - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] - switch -- $leadernorm { - 7CSI - 8CSI { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - } elseif {[punk::ansi::codetype::is_sgr $code]} { - #todo - make caching is_sgr method - set dup_posns [lsearch -all -exact $o_codestack $code] - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - } else { - - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set o_gx_state on - } - "B" { - set o_gx_state off - } - } - } - default { - #other ansi codes - } - } - append emit $code - } - - - set trailing_pt [lindex $parts end] - if {[string first \x1b $trailing_pt] >= 0} { - #puts stdout "...[ansistring VIEW -lf 1 $trailing_pt]...buffered:<[ansistring VIEW $o_buffered]> '[ansistring VIEW -lf 1 $emit]'" - #may not be plaintext after all - set o_buffered $trailing_pt - #puts stdout "=-=[ansistring VIEWCODES $o_buffered]" - } else { - #puts [a+ yellow]???[ansistring VIEW "'$o_buffered'<+>'$trailing_pt'"]???[a] - switch -- [llength $o_codestack] { - 0 { - append emit $o_do_colour$trailing_pt$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - append emit $o_do_colour$trailing_pt$o_do_normal - set o_codestack [list] - } else { - #append emit [lindex $o_codestack 0]$trailing_pt - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - default { - append emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$trailing_pt - } - } - #if {![llength $o_codestack] || ([llength $o_codestack] ==1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]])} { - # append emit $o_do_colour$trailing_pt$o_do_normal - #} else { - # append emit $trailing_pt - #} - #the previous o_buffered formed the data we emitted - nothing new to buffer because we emitted all parts including the trailing plaintext - set o_buffered "" - } - - - } else { - #REVIEW - this holding a buffer without emitting as we go is ugly. - # - we may do better to detect and retain the opener, then use that opener to avoid false splits within the sequence. - # - we'd then need to detect the appropriate close to restart splitting and codestacking - # - we may still need to retain and append the data to the opener (in some cases?) - which is a slight memory issue - but at least we would emit everything immediately. - - - #puts "-->esc but no detect" - #no complete ansi codes - but at least one esc is present - if {[string index $buf end] eq "\x1b" && [string first \x1b $buf] == [string length $buf]-1} { - #string index in first part of && clause to avoid some unneeded scans of whole string for this test - #we can't use 'string last' - as we need to know only esc is last char in buf - #puts ">>trailing-esc<<" - set o_buffered \x1b - set emit $o_do_colour[string range $buf 0 end-1]$o_do_normal - #set emit [string range $buf 0 end-1] - set buf "" - } else { - set emit_anyway 0 - #todo - ensure non-ansi escapes in middle of chunks don't lead to ever growing buffer - if {[punk::ansi::ta::detect_st_open $buf]} { - #no detect - but we have an ST open (privacy msg etc) - allow a larger chunk before we give up - could include newlines (and even nested codes - although not widely interpreted that way in terms) - set st_partial_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of unclosed ST code - #todo - configurable ST max - use 1k for now - if {$st_partial_len < 1001} { - append o_buffered $chunk - set emit "" - set buf "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } else { - set possible_code_len [expr {[string length $buf] - [string last \x1b $buf]}] ;#length of possible code - #most opening sequences are 1,2 or 3 chars - review? - set open_sequence_detected [punk::ansi::ta::detect_open $buf] - if {$possible_code_len > 10 && !$open_sequence_detected} { - set emit_anyway 1 - set o_buffered "" - } else { - #could be composite sequence with params - allow some reasonable max sequence length - #todo - configurable max sequence length - #len 40-50 quite possible for SGR sequence using coloured underlines etc, even without redundancies - # - allow some headroom for redundant codes when the caller didn't merge. - if {$possible_code_len < 101} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - #allow a little more grace if we at least have an opening ansi sequence of any type.. - if {$open_sequence_detected && $possible_code_len < 151} { - append o_buffered $chunk - set buf "" - set emit "" - } else { - set emit_anyway 1 - set o_buffered "" - } - } - } - } - if {$emit_anyway} { - #assert: any time emit_anyway == 1 buf already contains all of previous o_buffered and o_buffered has been cleared. - - #looked ansi-like - but we've given enough length without detecting close.. - #treat as possible plain text with some esc or unrecognised ansi sequence - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - #if {( ![llength $o_codestack] || ([llength $o_codestack] == 1 && [punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]))} { - # set emit $o_do_colour$buf$o_do_normal - #} else { - # set emit $buf - #} - } - } - } - } else { - #no esc - #puts stdout [a+ yellow]...[a] - #test! - switch -- [llength $o_codestack] { - 0 { - set emit $o_do_colour$buf$o_do_normal - } - 1 { - if {[punk::ansi::codetype::is_sgr_reset [lindex $o_codestack 0]]} { - set emit $o_do_colour$buf$o_do_normal - set o_codestack [list] - } else { - #set emit [lindex $o_codestack 0]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - default { - #set emit [punk::ansi::codetype::sgr_merge_singles $o_codestack]$buf - set emit [punk::ansi::codetype::sgr_merge_singles [list $o_do_colour {*}$o_codestack]]$buf - } - } - set o_buffered "" - } - return [dict create emit $emit stacksize [llength $o_codestack]] - } - method initialize {transform_handle mode} { - #clear undesirable in terminal output channels (review) - return [list initialize write flush read drain finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method clear {transform_handle} { - #In the context of stderr/stdout - we probably don't want clear to run. - #Terminals might call it in the middle of a split ansi code - resulting in broken output. - #Leave clear of it the init call - puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - } - method flush {transform_handle} { - #puts stdout "" - set emit [tcl::encoding::convertto $o_enc $o_buffered] - set o_buffered "" - return $emit - return - } - method write {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set streaminfo [my Trackcodes $instring] - set emit [dict get $streaminfo emit] - - #review - wrapping already done in Trackcodes - #if {[dict get $streaminfo stacksize] == 0} { - # #no ansi on the stack - we can wrap - # #review - # set outstring "$o_do_colour$emit$o_do_normal" - #} else { - #} - #if {[llength $o_codestack]} { - # set outstring [punk::ansi::codetype::sgr_merge_singles $o_codestack]$emit - #} else { - # set outstring $emit - #} - - set outstring $emit - - #puts stdout "decoded >>>[ansistring VIEWCODES $outstring]<<<" - #puts stdout "re-encoded>>>[ansistring VIEW [tcl::encoding::convertto $o_enc $outstring]]<<<" - return [tcl::encoding::convertto $o_enc $outstring] - } - method Write_naive {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - #set outstring ">>>$instring" - return [tcl::encoding::convertto $o_enc $outstring] - } - method drain {transform_handle} { - return "" - } - method read {transform_handle bytes} { - set instring [tcl::encoding::convertfrom $o_enc $bytes] - set outstring "$o_do_colour$instring$o_do_normal" - return [tcl::encoding::convertto $o_enc $outstring] - } - method meta_is_redirection {} { - return $o_is_junction - } - } - #todo - something - oo::class create rebuffer { - variable o_trecord - variable o_enc - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - } - method initialize {transform_handle mode} { - return [list initialize read write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - #set outstring [string map [list \n ] $instring] - set outstring $instring - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define rebuffer { - method meta_is_redirection {} { - return 0 - } - } - - #has slight buffering/withholding of lone training cr - we can't be sure that a cr at end of chunk is part of \r\n sequence - oo::class create tounix { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \n} $instring] - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define tounix { - method meta_is_redirection {} { - return $o_is_junction - } - } - #write to handle case where line-endings already \r\n too - oo::class create towindows { - variable o_trecord - variable o_enc - variable o_last_char_was_cr - variable o_is_junction - constructor {tf} { - set o_trecord $tf - set o_enc [dict get $tf -encoding] - set settingsdict [dict get $tf -settings] - if {[dict exists $tf -junction]} { - set o_is_junction [dict get $tf -junction] - } else { - set o_is_junction 0 - } - set o_last_char_was_cr 0 - } - method initialize {transform_handle mode} { - return [list initialize write finalize] - } - method finalize {transform_handle} { - my destroy - } - method watch {transform_handle events} { - } - #don't use read - method read {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - - set outstring $instring - - return [encoding convertto $o_enc $outstring] - } - method write {transform_handle bytes} { - set instring [encoding convertfrom $o_enc $bytes] - #set outstring [string map [list \n ] $instring] - - if {$o_last_char_was_cr} { - set instring "\r$instring" - } - - set outstring [string map {\r\n \uFFFF} $instring] - set outstring [string map {\n \r\n} $outstring] - set outstring [string map {\uFFFF \r\n} $outstring] - - set lastchar [string range $outstring end end] - if {$lastchar eq "\r"} { - set o_last_char_was_cr 1 - set outstring [string range $outstring 0 end-1] - } else { - set o_last_char_was_cr 0 - } - #review! can we detect eof here on the transform_handle? - #if eof, we don't want to strip a trailing \r - - return [encoding convertto $o_enc $outstring] - #return [encoding convertto utf-16le $outstring] - } - } - oo::define towindows { - method meta_is_redirection {} { - return $o_is_junction - } - } - - } -} - -# ---------------------------------------------------------------------------- -#review float/sink metaphor. -#perhaps something with the concept of upstream and downstream? -#need concepts for push towards data, sit in middle where placed, and lag at tail of data stream. -## upstream for stdin is at the bottom of the stack and for stdout is the top of the stack. -#upstream,neutral-upstream,downstream,downstream-aside,downstream-replace (default neutral-upstream - require action 'stack' to use standard channel stacking concept and ignore other actions) -#This is is a bit different from the float/sink metaphor which refers to the channel stacking order as opposed to the data-flow direction. -#The idea would be that whether input or output -# upstream additions go to the side closest to the datasource -# downstream additions go furthest from the datasource -# - all new additions go ahead of any diversions as the most upstream diversion is the current end of the stream in a way. -# - this needs review regarding subsequent removal of the diversion and whether filters re-order in response.. -# or if downstream & neutral additions are reclassified upon insertion if they land among existing upstreams(?) -# neutral-upstream goes to the datasource side of the neutral-upstream list. -# No 'neutral' option provided so that we avoid the need to think forwards or backwards when adding stdin vs stdout shellfilter does the necessary pop/push reordering. -# No 'neutral-downstream' to reduce complexity. -# downstream-replace & downstream-aside head downstream to the first diversion they encounter. ie these actions are no longer referring to the stack direction but only the dataflow direction. -# -# ---------------------------------------------------------------------------- -# -# 'filters' are transforms that don't redirect -# - limited range of actions to reduce complexity. -# - any requirement not fulfilled by float,sink,sink-replace,sink-sideline should be done by multiple pops and pushes -# -#actions can float to top of filters or sink to bottom of filters -#when action is of type sink, it can optionally replace or sideline the first non-filter it encounters (highest redirection on the stack.. any lower are starved of the stream anyway) -# - sideline means to temporarily replace the item and keep a record, restoring if/when we are removed from the transform stack -# -##when action is of type float it can't replace or sideline anything. A float is added above any existing floats and they stay in the same order relative to each other, -#but non-floats added later will sit below all floats. -#(review - float/sink initially designed around output channels. For stdin the dataflow is reversed. implement float-aside etc?) -# -# -#action: float sink sink-replace,sink-sideline -# -# -## note - whether stack is for input or output we maintain it in the same direction - which is in sync with the tcl chan pop chan push concept. -## -namespace eval shellfilter::stack { - namespace export {[a-z]*} - namespace ensemble create - #todo - implement as oo ? - variable pipelines [list] - - proc items {} { - #review - stdin,stdout,stderr act as pre-existing pipelines, and we can't create a new one with these names - so they should probably be autoconfigured and listed.. - # - but in what contexts? only when we find them in [chan names]? - variable pipelines - return [dict keys $pipelines] - } - proc item {pipename} { - variable pipelines - return [dict get $pipelines $pipename] - } - proc item_tophandle {pipename} { - variable pipelines - set handle "" - if {[dict exists $pipelines $pipename stack]} { - set stack [dict get $pipelines $pipename stack] - set topstack [lindex $stack end] ;#last item in stack is top (for output channels anyway) review comment. input chans? - if {$topstack ne ""} { - if {[dict exists $topstack -handle]} { - set handle [dict get $topstack -handle] - } - } - } - return $handle - } - proc status {{pipename *} args} { - variable pipelines - set pipecount [dict size $pipelines] - set tabletitle "$pipecount pipelines active" - set t [textblock::class::table new $tabletitle] - $t add_column -headers [list channel-ident] - $t add_column -headers [list device-info localchan] - $t configure_column 1 -header_colspans {3} - $t add_column -headers [list "" remotechan] - $t add_column -headers [list "" tid] - $t add_column -headers [list stack-info] - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - set rc [dict get $pipelines $k device remotechan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "-" - } - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set stackinfo "" - } else { - set tbl_inner [textblock::class::table new] - $tbl_inner configure -show_edge 0 - foreach rec $stack { - set handle [punk::lib::dict_getdef $rec -handle ""] - set id [punk::lib::dict_getdef $rec -id ""] - set transform [namespace tail [punk::lib::dict_getdef $rec -transform ""]] - set settings [punk::lib::dict_getdef $rec -settings ""] - $tbl_inner add_row [list $id $transform $handle $settings] - } - set stackinfo [$tbl_inner print] - $tbl_inner destroy - } - $t add_row [list $k $lc $rc $tid $stackinfo] - } - set result [$t print] - $t destroy - return $result - } - proc status1 {{pipename *} args} { - variable pipelines - - set pipecount [dict size $pipelines] - set tableprefix "$pipecount pipelines active\n" - foreach p [dict keys $pipelines] { - append tableprefix " " $p \n - } - package require overtype - #todo -verbose - set table "" - set ac1 [string repeat " " 15] - set ac2 [string repeat " " 42] - set ac3 [string repeat " " 70] - append table "[overtype::left $ac1 channel-ident] " - append table "[overtype::left $ac2 device-info] " - append table "[overtype::left $ac3 stack-info]" - append table \n - - - set bc1 [string repeat " " 5] ;#stack id - set bc2 [string repeat " " 25] ;#transform - set bc3 [string repeat " " 50] ;#settings - - foreach k [dict keys $pipelines $pipename] { - set lc [dict get $pipelines $k device localchan] - if {[dict exists $k device workertid]} { - set tid [dict get $pipelines $k device workertid] - } else { - set tid "" - } - - - set col1 [overtype::left $ac1 $k] - set col2 [overtype::left $ac2 "localchan: $lc tid:$tid"] - - set stack [dict get $pipelines $k stack] - if {![llength $stack]} { - set col3 $ac3 - } else { - set rec [lindex $stack 0] - set bcol1 [overtype::left $bc1 [dict get $rec -id]] - set bcol2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bcol3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bcol1 $bcol2 $bcol3" - set col3 [overtype::left $ac3 $stackrow] - } - - append table "$col1 $col2 $col3\n" - - - foreach rec [lrange $stack 1 end] { - set col1 $ac1 - set col2 $ac2 - if {[llength $rec]} { - set bc1 [overtype::left $bc1 [dict get $rec -id]] - set bc2 [overtype::left $bc2 [namespace tail [dict get $rec -transform]]] - set bc3 [overtype::left $bc3 [dict get $rec -settings]] - set stackrow "$bc1 $bc2 $bc3" - set col3 [overtype::left $ac3 $stackrow] - } else { - set col3 $ac3 - } - append table "$col1 $col2 $col3\n" - } - - } - return $tableprefix$table - } - #used for output channels - we usually want to sink redirections below the floaters and down to topmost existing redir - proc _get_stack_floaters {stack} { - set floaters [list] - foreach t [lreverse $stack] { - switch -- [dict get $t -action] { - float { - lappend floaters $t - } - default { - break - } - } - } - return [lreverse $floaters] - } - - - - #for output-channel sinking - proc _get_stack_top_redirection {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - incr r - } - #not found - return [list index -1 record {}] - } - #exclude float-locked, locked, sink-locked - proc _get_stack_top_redirection_replaceable {stack} { - set r 0 ;#reverse index - foreach t [lreverse $stack] { - set action [dict get $t -action] - if {![string match "*locked*" $action]} { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - set idx [expr {[llength $stack] - ($r + 1) }] ;#forward index - return [list index $idx record $t] - } - } - incr r - } - #not found - return [list index -1 record {}] - } - - - #for input-channels ? - proc _get_stack_bottom_redirection {stack} { - set i 0 - foreach t $stack { - set obj [dict get $t -obj] - if {[$obj meta_is_redirection]} { - return [linst index $i record $t] - } - incr i - } - #not found - return [list index -1 record {}] - } - - - proc get_next_counter {pipename} { - variable pipelines - #use dictn incr ? - set counter [dict get $pipelines $pipename counter] - incr counter - dict set pipelines $pipename counter $counter - return $counter - } - - proc unwind {pipename} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - foreach tf [lreverse $stack] { - chan pop $localchan - } - dict set pipelines $pipename [list] - } - #todo - proc delete {pipename {wait 0}} { - variable pipelines - set pipeinfo [dict get $pipelines $pipename] - set deviceinfo [dict get $pipeinfo device] - set localchan [dict get $deviceinfo localchan] - unwind $pipename - - #release associated thread - set tid [dict get $deviceinfo workertid] - if {$wait} { - thread::release -wait $tid - } else { - thread::release $tid - } - - #Memchan closes without error - tcl::chan::fifo2 raises something like 'can not find channel named "rc977"' - REVIEW. why? - catch {chan close $localchan} - } - #review - proc name clarity is questionable. remove_stackitem? - proc remove {pipename remove_id} { - variable pipelines - if {![dict exists $pipelines $pipename]} { - puts stderr "WARNING: shellfilter::stack::remove pipename '$pipename' not found in pipelines dict: '$pipelines' [info level -1]" - return - } - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $pipelines $pipename device localchan] - set posn 0 - set idposn -1 - set asideposn -1 - foreach t $stack { - set id [dict get $t -id] - if {$id eq $remove_id} { - set idposn $posn - break - } - #look into asides (only can be one for now) - if {[llength [dict get $t -aside]]} { - set a [dict get $t -aside] - if {[dict get $a -id] eq $remove_id} { - set asideposn $posn - break - } - } - incr posn - } - - if {$asideposn > 0} { - #id wasn't found directly in stack, but in an -aside. we don't need to pop anything - just clear this aside record - set container [lindex $stack $asideposn] - dict set container -aside {} - lset stack $asideposn $container - dict set pipelines $pipename stack $stack - } else { - if {$idposn < 0} { - ::shellfilter::log::write shellfilter "ERROR shellfilter::stack::remove $pipename id '$remove_id' not found" - puts stderr "|WARNING>shellfilter::stack::remove $pipename id '$remove_id' not found" - return 0 - } - set removed_item [lindex $stack $idposn] - - #include idposn in poplist - set poplist [lrange $stack $idposn end] - set stack [lreplace $stack $idposn end] - #pop all chans before adding anything back in! - foreach p $poplist { - chan pop $localchan - } - - if {[llength [dict get $removed_item -aside]]} { - set restore [dict get $removed_item -aside] - set t [dict get $restore -transform] - set tsettings [dict get $restore -settings] - set obj [$t new $restore] - set h [chan push $localchan $obj] - dict set restore -handle $h - dict set restore -obj $obj - lappend stack $restore - } - - #put popped back except for the first one, which we want to remove - foreach p [lrange $poplist 1 end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - dict set p -handle $h - dict set p -obj $obj - lappend stack $p - } - dict set pipelines $pipename stack $stack - } - #JMNJMN 2025 review! - #show_pipeline $pipename -note "after_remove $remove_id" - return 1 - } - - #pop a number of items of the top of the stack, add our transform record, and add back all (or the tail of poplist if pushstartindex > 0) - proc insert_transform {pipename stack transformrecord poplist {pushstartindex 0}} { - variable pipelines - set bottom_pop_posn [expr {[llength $stack] - [llength $poplist]}] - set poplist [lrange $stack $bottom_pop_posn end] - set stack [lreplace $stack $bottom_pop_posn end] - - set localchan [dict get $pipelines $pipename device localchan] - foreach p [lreverse $poplist] { - chan pop $localchan - } - set transformname [dict get $transformrecord -transform] - set transformsettings [dict get $transformrecord -settings] - set obj [$transformname new $transformrecord] - set h [chan push $localchan $obj] - dict set transformrecord -handle $h - dict set transformrecord -obj $obj - dict set transformrecord -note "insert_transform" - lappend stack $transformrecord - foreach p [lrange $poplist $pushstartindex end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added" - - lappend stack $p - } - return $stack - } - - #fifo2 - proc new {pipename args} { - variable pipelines - if {($pipename in [dict keys $pipelines]) || ($pipename in [chan names])} { - error "shellfilter::stack::new error: pipename '$pipename' already exists" - } - - set opts [dict merge {-settings {}} $args] - set defaultsettings [dict create -raw 1 -buffering line -direction out] - set targetsettings [dict merge $defaultsettings [dict get $opts -settings]] - - set direction [dict get $targetsettings -direction] - - #pipename is the source/facility-name ? - if {$direction eq "out"} { - set pipeinfo [shellfilter::pipe::open_out $pipename $targetsettings] - } else { - puts stderr "|jn> pipe::open_in $pipename $targetsettings" - set pipeinfo [shellfilter::pipe::open_in $pipename $targetsettings] - } - #open_out/open_in will configure buffering based on targetsettings - - set program_chan [dict get $pipeinfo localchan] - set worker_chan [dict get $pipeinfo remotechan] - set workertid [dict get $pipeinfo workertid] - - - set deviceinfo [dict create pipename $pipename localchan $program_chan remotechan $worker_chan workertid $workertid direction $direction] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - - return $deviceinfo - } - #we 'add' rather than 'push' because transforms can float,sink and replace/sideline so they don't necessarily go to the top of the transform stack - proc add {pipename transformname args} { - variable pipelines - #chan names doesn't reflect available channels when transforms are in place - #e.g stdout may exist but show as something like file191f5b0dd80 - if {($pipename ni [dict keys $pipelines])} { - if {[catch {eof $pipename} is_eof]} { - error "shellfilter::stack::add no existing chan or pipename matching '$pipename' in channels:[chan names] or pipelines:$pipelines use stdin/stderr/stdout or shellfilter::stack::new " - } - } - set args [dict merge {-action "" -settings {}} $args] - set action [dict get $args -action] - set transformsettings [dict get $args -settings] - if {[string first "::" $transformname] < 0} { - set transformname ::shellfilter::chan::$transformname - } - if {![llength [info commands $transformname]]} { - error "shellfilter::stack::push unknown transform '$transformname'" - } - - - if {![dict exists $pipelines $pipename]} { - #pipename must be in chan names - existing device/chan - #record a -read and -write end even if the device is only being used as one or the other - set deviceinfo [dict create pipename $pipename localchan $pipename remotechan {}] - dict set pipelines $pipename [list counter 0 device $deviceinfo stack [list]] - } else { - set deviceinfo [dict get $pipelines $pipename device] - } - - set id [get_next_counter $pipename] - set stack [dict get $pipelines $pipename stack] - set localchan [dict get $deviceinfo localchan] - - #we redundantly store chan in each transform - makes debugging clearer - # -encoding similarly could be stored only at the pipeline level (or even queried directly each filter-read/write), - # but here it may help detect unexpected changes during lifetime of the stack and avoids the chance of callers incorrectly using the transform handle?) - # jn - set transform_record [list -id $id -chan $pipename -encoding [chan configure $localchan -encoding] -transform $transformname -aside {} {*}$args] - switch -glob -- $action { - float - float-locked { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } - "" - locked { - set floaters [_get_stack_floaters $stack] - if {![llength $floaters]} { - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - lappend stack $transform_record - } else { - set poplist $floaters - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - "sink*" { - set redirinfo [_get_stack_top_redirection $stack] - set idx_existing_redir [dict get $redirinfo index] - if {$idx_existing_redir == -1} { - #no existing redirection transform on the stack - #pop everything.. add this record as the first redirection on the stack - set poplist $stack - set stack [insert_transform $pipename $stack $transform_record $poplist] - } else { - switch -glob -- $action { - "sink-replace" { - #include that index in the poplist - set poplist [lrange $stack $idx_existing_redir end] - #pop all from idx_existing_redir to end, but put back 'lrange $poplist 1 end' - set stack [insert_transform $pipename $stack $transform_record $poplist 1] - } - "sink-aside*" { - set existing_redir_record [lindex $stack $idx_existing_redir] - if {[string match "*locked*" [dict get $existing_redir_record -action]]} { - set put_aside 0 - #we can't aside this one - sit above it instead. - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [lrange $stack 0 $idx_existing_redir] - } else { - set put_aside 1 - dict set transform_record -aside [lindex $stack $idx_existing_redir] - set poplist [lrange $stack $idx_existing_redir end] - set stack [lrange $stack 0 $idx_existing_redir-1] - } - foreach p $poplist { - chan pop $localchan - } - set transformname [dict get $transform_record -transform] - set transform_settings [dict get $transform_record -settings] - set obj [$transformname new $transform_record] - set h [chan push $localchan $obj] - dict set transform_record -handle $h - dict set transform_record -obj $obj - dict set transform_record -note "insert_transform-with-aside" - lappend stack $transform_record - #add back poplist *except* the one we transferred into -aside (if we were able) - foreach p [lrange $poplist $put_aside end] { - set t [dict get $p -transform] - set tsettings [dict get $p -settings] - set obj [$t new $p] - set h [chan push $localchan $obj] - #retain previous -id - code that added it may have kept reference and not expecting it to change - dict set p -handle $h - dict set p -obj $obj - dict set p -note "re-added-after-sink-aside" - lappend stack $p - } - } - default { - #plain "sink" - #we only sink to the topmost redirecting filter - which makes sense for an output channel - #For stdin.. this is more problematic as we're more likely to want to intercept the bottom most redirection. - #todo - review. Consider making default insert position for input channels to be at the source... and float/sink from there. - # - we don't currently know from the stack api if adding input vs output channel - so this needs work to make intuitive. - # consider splitting stack::add to stack::addinput stack::addoutput to split the different behaviour - set poplist [lrange $stack $idx_existing_redir+1 end] - set stack [insert_transform $pipename $stack $transform_record $poplist] - } - } - } - } - default { - error "shellfilter::stack::add unimplemented action '$action'" - } - } - - dict set pipelines $pipename stack $stack - #puts stdout "==" - #puts stdout "==>stack: $stack" - #puts stdout "==" - - #JMNJMN - #show_pipeline $pipename -note "after_add $transformname $args" - return $id - } - proc show_pipeline {pipename args} { - variable pipelines - set stack [dict get $pipelines $pipename stack] - set tag "SHELLFILTER::STACK" - #JMN - load from config - #::shellfilter::log::open $tag {-syslog 127.0.0.1:514} - if {[catch { - ::shellfilter::log::open $tag {-syslog ""} - } err]} { - #e.g safebase interp can't load required modules such as shellthread (or Thread) - puts stderr "shellfilter::show_pipeline cannot open log" - return - } - ::shellfilter::log::write $tag "transform stack for $pipename $args" - foreach tf $stack { - ::shellfilter::log::write $tag " $tf" - } - - } -} - - -namespace eval shellfilter { - variable sources [list] - variable stacks [dict create] - - proc ::shellfilter::redir_channel_to_log {chan args} { - variable sources - set default_logsettings [dict create \ - -tag redirected_$chan -syslog "" -file ""\ - ] - if {[dict exists $args -action]} { - set action [dict get $args -action] - } else { - # action "sink" is a somewhat reasonable default for an output redirection transform - # but it can make it harder to configure a plain ordered stack if the user is not expecting it, so we'll default to stack - # also.. for stdin transform sink makes less sense.. - #todo - default "stack" instead of empty string - set action "" - } - if {[dict exists $args -settings]} { - set logsettings [dict get $args -settings] - } else { - set logsettings {} - } - - set logsettings [dict merge $default_logsettings $logsettings] - set tag [dict get $logsettings -tag] - if {$tag ni $sources} { - lappend sources $tag - } - - set id [shellfilter::stack::add $chan logonly -action $action -settings $logsettings] - return $id - } - - proc ::shellfilter::redir_output_to_log {tagprefix args} { - variable sources - - set default_settings [list -tag ${tagprefix} -syslog "" -file ""] - - set opts [dict create -action "" -settings {}] - set opts [dict merge $opts $args] - set optsettings [dict get $opts -settings] - set settings [dict merge $default_settings $optsettings] - - set tag [dict get $settings -tag] - if {$tag ne $tagprefix} { - error "shellfilter::redir_output_to_log -tag value must match supplied tagprefix:'$tagprefix'. Omit -tag, or make it the same. It will automatically be suffixed with stderr and stdout. Use redir_channel_to_log if you want to separately configure each channel" - } - lappend sources ${tagprefix}stdout ${tagprefix}stderr - - set stdoutsettings $settings - dict set stdoutsettings -tag ${tagprefix}stdout - set stderrsettings $settings - dict set stderrsettings -tag ${tagprefix}stderr - - set idout [redir_channel_to_log stdout -action [dict get $opts -action] -settings $stdoutsettings] - set iderr [redir_channel_to_log stderr -action [dict get $opts -action] -settings $stderrsettings] - - return [list $idout $iderr] - } - - #eg try: set v [list #a b c] - #vs set v {#a b c} - proc list_is_canonical l { - #courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl - if {[catch {llength $l}]} {return 0} - string equal $l [list {*}$l] - } - - #return a dict keyed on numerical list index showing info about each element - # - particularly - # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list - # 'head_tail_chars' to show current first and last character (in case it's wrapped e.g in double or single quotes or an existing set of braces) - proc list_element_info {inputlist} { - set i 0 - set info [dict create] - set testlist [list] - foreach original_item $inputlist { - #--- - # avoid sharing internal rep with original items in the list (avoids shimmering of rep in original list for certain items such as paths) - unset -nocomplain item - append item $original_item {} - #--- - - set iteminfo [dict create] - set itemlen [string length $item] - lappend testlist $item - set tcl_len [string length $testlist] - set diff [expr {$tcl_len - $itemlen}] - if {$diff == 0} { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 0 - } else { - #test for escaping vs bracing! - set testlistchars [split $testlist ""] - if {([lindex $testlistchars 0] eq "\{") && ([lindex $testlistchars end] eq "\}")} { - dict set iteminfo wouldbrace 1 - dict set iteminfo wouldescape 0 - } else { - dict set iteminfo wouldbrace 0 - dict set iteminfo wouldescape 1 - } - } - set testlist [list] - set charlist [split $item ""] - set char_a [lindex $charlist 0] - set char_b [lindex $charlist 1] - set char_ab ${char_a}${char_b} - set char_y [lindex $charlist end-1] - set char_z [lindex $charlist end] - set char_yz ${char_y}${char_z} - - if { ("{" in $charlist) || ("}" in $charlist) } { - dict set iteminfo has_braces 1 - set innerchars [lrange $charlist 1 end-1] - if {("{" in $innerchars) || ("}" in $innerchars)} { - dict set iteminfo has_inner_braces 1 - } else { - dict set iteminfo has_inner_braces 0 - } - } else { - dict set iteminfo has_braces 0 - dict set iteminfo has_inner_braces 0 - } - - #todo - brace/char counting to determine if actually 'wrapped' - #e.g we could have list element {((abc)} - which appears wrapped if only looking at first and last chars. - #also {(x) (y)} as a list member.. how to treat? - if {$itemlen <= 1} { - dict set iteminfo apparentwrap "not" - } else { - #todo - switch on $char_a$char_z - if {($char_a eq {"}) && ($char_z eq {"})} { - dict set iteminfo apparentwrap "doublequotes" - } elseif {($char_a eq "'") && ($char_z eq "'")} { - dict set iteminfo apparentwrap "singlequotes" - } elseif {($char_a eq "(") && ($char_z eq ")")} { - dict set iteminfo apparentwrap "brackets" - } elseif {($char_a eq "\{") && ($char_z eq "\}")} { - dict set iteminfo apparentwrap "braces" - } elseif {($char_a eq "^") && ($char_z eq "^")} { - dict set iteminfo apparentwrap "carets" - } elseif {($char_a eq "\[") && ($char_z eq "\]")} { - dict set iteminfo apparentwrap "squarebrackets" - } elseif {($char_a eq "`") && ($char_z eq "`")} { - dict set iteminfo apparentwrap "backquotes" - } elseif {($char_a eq "\n") && ($char_z eq "\n")} { - dict set iteminfo apparentwrap "lf-newline" - } elseif {($char_ab eq "\r\n") && ($char_yz eq "\r\n")} { - dict set iteminfo apparentwrap "crlf-newline" - } else { - dict set iteminfo apparentwrap "not-determined" - } - - } - dict set iteminfo wrapbalance "unknown" ;#a hint to caller that apparentwrap is only a guide. todo - possibly make wrapbalance indicate 0 for unbalanced.. and positive numbers for outer-count of wrappings. - #e.g {((x)} == 0 {((x))} == 1 {(x) (y (z))} == 2 - dict set iteminfo head_tail_chars [list $char_a $char_z] - set namemap [list \ - \r cr\ - \n lf\ - {"} doublequote\ - {'} singlequote\ - "`" backquote\ - "^" caret\ - \t tab\ - " " sp\ - "\[" lsquare\ - "\]" rsquare\ - "(" lbracket\ - ")" rbracket\ - "\{" lbrace\ - "\}" rbrace\ - \\ backslash\ - / forwardslash\ - ] - if {[string length $char_a]} { - set char_a_name [string map $namemap $char_a] - } else { - set char_a_name "emptystring" - } - if {[string length $char_z]} { - set char_z_name [string map $namemap $char_z] - } else { - set char_z_name "emptystring" - } - - dict set iteminfo head_tail_names [list $char_a_name $char_z_name] - dict set iteminfo len $itemlen - dict set iteminfo difflen $diff ;#2 for braces, 1 for quoting?, or 0. - dict set info $i $iteminfo - incr i - } - return $info - } - - - #parse bracketed expression (e.g produced by vim "shellxquote=(" ) into a tcl (nested) list - #e.g {(^c:/my spacey/path^ >^somewhere^)} - #e.g {(blah (etc))}" - #Result is always a list - even if only one toplevel set of brackets - so it may need [lindex $result 0] if input is the usual case of {( ...)} - # - because it also supports the perhaps less likely case of: {( ...) unbraced (...)} etc - # Note that - #maintenance warning - duplication in branches for bracketed vs unbracketed! - proc parse_cmd_brackets {str} { - #wordwrappers currently best suited to non-bracket entities - no bracket matching within - anything goes until end-token reached. - # - but.. they only take effect where a word can begin. so a[x y] may be split at the space unless it's within some other wraper e.g " a[x y]" will not break at the space - # todo - consider extending the in-word handling of word_bdepth which is currently only applied to () i.e aaa(x y) is supported but aaa[x y] is not as the space breaks the word up. - set wordwrappers [list \ - "\"" [list "\"" "\"" "\""]\ - {^} [list "\"" "\"" "^"]\ - "'" [list "'" "'" "'"]\ - "\{" [list "\{" "\}" "\}"]\ - {[} [list {[} {]} {]}]\ - ] ;#dict mapping start_character to {replacehead replacetail expectedtail} - set shell_specials [list "|" "|&" "<" "<@" "<<" ">" "2>" ">&" ">>" "2>>" ">>&" ">@" "2>@" "2>@1" ">&@" "&" "&&" ] ;#words/chars that may precede an opening bracket but don't merge with the bracket to form a word. - #puts "pb:$str" - set in_bracket 0 - set in_word 0 - set word "" - set result {} - set word_bdepth 0 - set word_bstack [list] - set wordwrap "" ;#only one active at a time - set bracketed_elements [dict create] - foreach char [split $str ""] { - #puts "c:$char bracketed:$bracketed_elements" - if {$in_bracket > 0} { - if {$in_word} { - if {[string length $wordwrap]} { - #anything goes until end-char - #todo - lookahead and only treat as closing if before a space or ")" ? - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - if {$word_bdepth == 0} { - #can potentially close off a word - or start a new one if word-so-far is a shell-special - if {$word in $shell_specials} { - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - } else { - - if {$char eq ")"} { - dict lappend bracketed_elements $in_bracket $word - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - set word "" - set in_word 0 - } elseif {[regexp {[\s]} $char]} { - dict lappend bracketed_elements $in_bracket $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - #ordinary word up-against and opening bracket - brackets are part of word. - incr word_bdepth - append word "(" - } else { - append word $char - } - } - } else { - #currently only () are used for word_bdepth - todo add all or some wordwrappers chars so that the word_bstack can have multiple active. - switch -- $char { - "(" { - incr word_bdepth - lappend word_bstack $char - append word $char - } - ")" { - incr word_bdepth -1 - set word_bstack [lrange $word_bstack 0 end-1] - append word $char - } - default { - #spaces and chars added to word as it's still in a bracketed section - append word $char - } - } - } - } - } else { - - if {$char eq "("} { - incr in_bracket - - } elseif {$char eq ")"} { - set subresult [dict get $bracketed_elements $in_bracket] - dict set bracketed_elements $in_bracket [list] - incr in_bracket -1 - if {$in_bracket == 0} { - lappend result $subresult - } else { - dict lappend bracketed_elements $in_bracket $subresult - } - } elseif {[regexp {[\s]} $char]} { - # - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } else { - if {$in_word} { - if {[string length $wordwrap]} { - lassign [dict get $wordwrappers $wordwrap] _open closing endmark - if {$char eq $endmark} { - set wordwrap "" - append word $closing - lappend result $word - set word "" - set in_word 0 - } else { - append word $char - } - } else { - - if {$word_bdepth == 0} { - if {$word in $shell_specials} { - if {[regexp {[\s]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - lappend result $word - set word "" - set in_word 0 - incr in_bracket - } else { - #at end of shell-specials is another point to look for word started by a wordwrapper char - #- expect common case of things like >^/my/path^ - if {$char in [dict keys $wordwrappers]} { - lappend result $word - set word "" - set in_word 1 ;#just for explicitness.. we're straight into the next word. - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - #something unusual.. keep going with word! - append word $char - } - } - - } else { - if {[regexp {[\s)]} $char]} { - lappend result $word - set word "" - set in_word 0 - } elseif {$char eq "("} { - incr word_bdepth - append word $char - } else { - append word $char - } - } - } else { - switch -- $char { - "(" { - incr word_bdepth - append word $char - } - ")" { - incr word_bdepth -1 - append word $char - } - default { - append word $char - } - } - } - } - } else { - if {[regexp {[\s]} $char]} { - #insig whitespace(?) - } elseif {$char eq "("} { - incr in_bracket - dict set bracketed_elements $in_bracket [list] - } elseif {$char eq ")"} { - error "unbalanced bracket - unable to proceed result so far: $result bracketed_elements:$bracketed_elements" - } else { - #first char of word - look for word-wrappers - if {$char in [dict keys $wordwrappers]} { - set wordwrap $char - set word [lindex [dict get $wordwrappers $char] 0] ;#replace trigger char with the start value it maps to. - } else { - set word $char - } - set in_word 1 - } - } - } - #puts "----$bracketed_elements" - } - if {$in_bracket > 0} { - error "shellfilter::parse_cmd_brackets missing close bracket. input was '$str'" - } - if {[dict exists $bracketed_elements 0]} { - #lappend result [lindex [dict get $bracketed_elements 0] 0] - lappend result [dict get $bracketed_elements 0] - } - if {$in_word} { - lappend result $word - } - return $result - } - - #only double quote if argument not quoted with single or double quotes - proc dquote_if_not_quoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} - {''} { - return $a - } - default { - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - - #proc dquote_if_not_bracketed/braced? - - #wrap in double quotes if not double-quoted - proc dquote_if_not_dquoted {a} { - set wrapchars [string cat [string range $a 0 0] [string range $a end end]] - switch -- $wrapchars { - {""} { - return $a - } - default { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - } - } - proc dquote {a} { - #escape any inner quotes.. - set newinner [string map [list {"} "\\\""] $a] - return "\"$newinner\"" - } - proc get_scriptrun_from_cmdlist_dquote_if_not {cmdlist {shellcmdflag ""}} { - set scr [auto_execok "script"] - if {[string length $scr]} { - #set scriptrun "( $c1 [lrange $cmdlist 1 end] )" - set arg1 [lindex $cmdlist 0] - if {[string first " " $arg1]>0} { - set c1 [dquote_if_not_quoted $arg1] - #set c1 "\"$arg1\"" - } else { - set c1 $arg1 - } - - if {[string length $shellcmdflag]} { - set scriptrun "$shellcmdflag \$($c1 " - } else { - set scriptrun "\$($c1 " - } - #set scriptrun "$c1 " - foreach a [lrange $cmdlist 1 end] { - #set a [string map [list "/" "//"] $a] - #set a [string map [list "\"" "\\\""] $a] - if {[string first " " $a] > 0} { - append scriptrun [dquote_if_not_quoted $a] - } else { - append scriptrun $a - } - append scriptrun " " - } - set scriptrun [string trim $scriptrun] - append scriptrun ")" - #return [list $scr -q -e -c $scriptrun /dev/null] - return [list $scr -e -c $scriptrun /dev/null] - } else { - return $cmdlist - } - } - - proc ::shellfilter::trun {commandlist args} { - #jmn - } - - - # run a command (or tcl script) with tees applied to stdout/stderr/stdin (or whatever channels are being used) - # By the point run is called - any transforms should already be in place on the channels if they're needed. - # The tees will be inline with none,some or all of those transforms depending on how the stack was configured - # (upstream,downstream configured via -float,-sink etc) - proc ::shellfilter::run {commandlist args} { - #must be a list. If it was a shell commandline string. convert it elsewhere first. - - variable sources - set runtag "shellfilter-run" - #set tid [::shellfilter::log::open $runtag [list -syslog 127.0.0.1:514]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - if {[catch {llength $commandlist} listlen]} { - set listlen "" - } - ::shellfilter::log::write $runtag " commandlist:'$commandlist' listlen:$listlen strlen:[string length $commandlist]" - - #flush stdout - #flush stderr - - #adding filters with sink-aside will temporarily disable the existing redirection - #All stderr/stdout from the shellcommand will now tee to the underlying stderr/stdout as well as the configured syslog - - set defaults [dict create \ - -teehandle command \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -tclscript 0 \ - ] - set opts [dict merge $defaults $args] - - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set outchan [dict get $opts -outchan] - set errchan [dict get $opts -errchan] - set inchan [dict get $opts -inchan] - set teehandle [dict get $opts -teehandle] - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set is_script [dict get $opts -tclscript] - dict unset opts -tclscript ;#don't pass it any further - # -- --- --- --- --- --- --- --- --- --- --- --- --- --- - set teehandle_out ${teehandle}out ;#default commandout - set teehandle_err ${teehandle}err - set teehandle_in ${teehandle}in - - - #puts stdout "shellfilter initialising tee_to_pipe transforms for in/out/err" - - # sources should be added when stack::new called instead(?) - foreach source [list $teehandle_out $teehandle_err] { - if {$source ni $sources} { - lappend sources $source - } - } - set outdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_out device] - set outpipechan [dict get $outdeviceinfo localchan] - set errdeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_err device] - set errpipechan [dict get $errdeviceinfo localchan] - - #set indeviceinfo [dict get $::shellfilter::stack::pipelines $teehandle_in device] - #set inpipechan [dict get $indeviceinfo localchan] - - #NOTE:These transforms are not necessarily at the top of each stack! - #The float/sink mechanism, along with whether existing transforms are diversionary decides where they sit. - set id_out [shellfilter::stack::add $outchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_out -pipechan $outpipechan]] - set id_err [shellfilter::stack::add $errchan tee_to_pipe -action sink-aside -settings [list -tag $teehandle_err -pipechan $errpipechan]] - - # need to use os level channel handle for stdin - try named pipes (or even sockets) instead of fifo2 for this - # If non os-level channel - the command can't be run with the redirection - # stderr/stdout can be run with non-os handles in the call - - # but then it does introduce issues with terminal-detection and behaviour for stdout at least - # - # input is also a tee - we never want to change the source at this point - just log/process a side-channel of it. - # - #set id_in [shellfilter::stack::add $inchan tee_to_pipe -action sink-aside -settings [list -tag commandin -pipechan $inpipechan]] - - - #set id_out [shellfilter::stack::add stdout tee_to_log -action sink-aside -settings [list -tag shellstdout -syslog 127.0.0.1:514 -file ""]] - #set id_err [shellfilter::stack::add stderr tee_to_log -action sink-aside -settings [list -tag shellstderr -syslog 127.0.0.1:514 -file "stderr.txt"]] - - #we need to catch errors - and ensure stack::remove calls occur. - #An error can be raised if the command couldn't even launch, as opposed to a non-zero exitcode and stderr output from the command itself. - # - if {!$is_script} { - set experiment 0 - if {$experiment} { - try { - set results [exec {*}$commandlist] - set exitinfo [list exitcode 0] - } trap CHILDSTATUS {results options} { - set exitcode [lindex [dict get $options -errorcode] 2] - set exitinfo [list exitcode $exitcode] - } - } else { - if {[catch { - #run process with stdout/stderr/stdin or with configured channels - #set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan $inpipechan {*}$opts] - set exitinfo [shellcommand_stdout_stderr $commandlist $outchan $errchan stdin {*}$opts] - #puts stderr "---->exitinfo $exitinfo" - - #subprocess result should usually have an "exitcode" key - #but for background execution we will get a "pids" key of process ids. - } errMsg]} { - set exitinfo [list error "$errMsg" source shellcommand_stdout_stderr] - } - } - } else { - if {[catch { - #script result - set exitinfo [list result [uplevel #0 [list eval $commandlist]]] - } errMsg]} { - set exitinfo [list error "$errMsg" errorCode $::errorCode errorInfo "$::errorInfo"] - } - } - - - #the previous redirections on the underlying inchan/outchan/errchan items will be restored from the -aside setting during removal - #Remove execution-time Tees from stack - shellfilter::stack::remove stdout $id_out - shellfilter::stack::remove stderr $id_err - #shellfilter::stack::remove stderr $id_in - - - #chan configure stderr -buffering line - #flush stdout - - - ::shellfilter::log::write $runtag " return '$exitinfo'" - ::shellfilter::log::close $runtag - return $exitinfo - } - proc ::shellfilter::logtidyup { {tags {}} } { - variable sources - set worker_errorlist [list] - set tidied_sources [list] - set tidytag "logtidy" - - - # opening a thread or writing to a log/syslog close to possible process exit is probably not a great idea. - # we should ensure the thread already exists early on if we really need logging here. - # - #set tid [::shellfilter::log::open $tidytag {-syslog 127.0.0.1:514}] - #::shellfilter::log::write $tidytag " logtidyuptags '$tags'" - - foreach s $sources { - if {$s eq $tidytag} { - continue - } - #puts "logtidyup source $s" - set close 1 - if {[llength $tags]} { - if {$s ni $tags} { - set close 0 - } - } - if {$close} { - lappend tidied_sources $s - shellfilter::log::close $s - lappend worker_errorlist {*}[shellthread::manager::get_and_clear_errors $s] - } - } - set remaining_sources [list] - foreach s $sources { - if {$s ni $tidied_sources} { - lappend remaining_sources $s - } - } - - #set sources [concat $remaining_sources $tidytag] - set sources $remaining_sources - - #shellfilter::stack::unwind stdout - #shellfilter::stack::unwind stderr - return [list tidied $tidied_sources errors $worker_errorlist] - } - - #package require tcl::chan::null - # e.g set errchan [tcl::chan::null] - # e.g chan push stdout [shellfilter::chan::var new ::some_var] - proc ::shellfilter::shellcommand_stdout_stderr {commandlist outchan errchan inchan args} { - set valid_flags [list \ - -timeout \ - -outprefix \ - -errprefix \ - -debug \ - -copytempfile \ - -outbuffering \ - -errbuffering \ - -inbuffering \ - -readprocesstranslation \ - -outtranslation \ - -stdinhandler \ - -outchan \ - -errchan \ - -inchan \ - -teehandle\ - ] - - set runtag shellfilter-run2 - #JMN - load from config - #set tid [::shellfilter::log::open $runtag [list -syslog "127.0.0.1:514"]] - set tid [::shellfilter::log::open $runtag [list -syslog ""]] - - if {[llength $args] % 2} { - error "Trailing arguments after any positional arguments must be in pairs of the form -argname argvalue. Valid flags are:'$valid_flags'" - } - set invalid_flags [list] - foreach {k -} $args { - switch -- $k { - -timeout - - -outprefix - - -errprefix - - -debug - - -copytempfile - - -outbuffering - - -errbuffering - - -inbuffering - - -readprocesstranslation - - -outtranslation - - -stdinhandler - - -outchan - - -errchan - - -inchan - - -teehandle { - } - default { - lappend invalid_flags $k - } - } - } - if {[llength $invalid_flags]} { - error "Unknown option(s)'$invalid_flags': must be one of '$valid_flags'" - } - #line buffering generally best for output channels.. keeps relative output order of stdout/stdin closer to source order - #there may be data where line buffering is inappropriate, so it's configurable per std channel - #reading inputs with line buffering can result in extraneous newlines as we can't detect trailing data with no newline before eof. - set defaults [dict create \ - -outchan stdout \ - -errchan stderr \ - -inchan stdin \ - -outbuffering none \ - -errbuffering none \ - -readprocesstranslation auto \ - -outtranslation lf \ - -inbuffering none \ - -timeout 900000\ - -outprefix ""\ - -errprefix ""\ - -debug 0\ - -copytempfile 0\ - -stdinhandler ""\ - ] - - - - set args [dict merge $defaults $args] - set outbuffering [dict get $args -outbuffering] - set errbuffering [dict get $args -errbuffering] - set inbuffering [dict get $args -inbuffering] - set readprocesstranslation [dict get $args -readprocesstranslation] - set outtranslation [dict get $args -outtranslation] - set timeout [dict get $args -timeout] - set outprefix [dict get $args -outprefix] - set errprefix [dict get $args -errprefix] - set debug [dict get $args -debug] - set copytempfile [dict get $args -copytempfile] - set stdinhandler [dict get $args -stdinhandler] - - set debugname "shellfilter-debug" - - if {$debug} { - set tid [::shellfilter::log::open $debugname [list -syslog "127.0.0.1:514"]] - ::shellfilter::log::write $debugname " commandlist '$commandlist'" - } - #'clock micros' good enough id for shellcommand calls unless one day they can somehow be called concurrently or sequentially within a microsecond and within the same interp. - # a simple counter would probably work too - #consider other options if an alternative to the single vwait in this function is used. - set call_id [tcl::clock::microseconds] ; - set ::shellfilter::shellcommandvars($call_id,exitcode) "" - set waitvar ::shellfilter::shellcommandvars($call_id,waitvar) - if {$debug} { - ::shellfilter::log::write $debugname " waitvar '$waitvar'" - } - lassign [chan pipe] rderr wrerr - chan configure $wrerr -blocking 0 - - set custom_stderr "" - set lastitem [lindex $commandlist end] - #todo - ensure we can handle 2> file (space after >) - - #review - reconsider the handling of redirections such that tcl-style are handled totally separately to other shell syntaxes! - # - #note 2>@1 must ocur as last word for tcl - but 2@stdout can occur elsewhere - #(2>@stdout echoes to main stdout - not into pipeline) - #To properly do pipelines it looks like we will have to split on | and call this proc multiple times and wire it up accordingly (presumably in separate threads) - - switch -- [string trim $lastitem] { - {&} { - set name [lindex $commandlist 0] - #background execution - stdout and stderr from child still comes here - but process is backgrounded - #FIX! - this is broken for paths with backslashes for example - #set pidlist [exec {*}[concat $name [lrange $commandlist 1 end]]] - set pidlist [exec {*}$commandlist] - return [list pids $pidlist] - } - {2>&1} - {2>@1} { - set custom_stderr {2>@1} ;#use the tcl style - set commandlist [lrange $commandlist 0 end-1] - } - default { - # 2> filename - # 2>> filename - # 2>@ openfileid - set redir2test [string range $lastitem 0 1] - if {$redir2test eq "2>"} { - set custom_stderr $lastitem - set commandlist [lrange $commandlist 0 end-1] - } - } - } - set lastitem [lindex $commandlist end] - - set teefile "" ;#empty string, write, append - #an ugly hack.. because redirections seem to arrive wrapped - review! - #There be dragons here.. - #Be very careful with list manipulation of the commandlist string.. backslashes cause havoc. commandlist must always be a well-formed list. generally avoid string manipulations on entire list or accidentally breaking a list element into parts if it shouldn't be.. - #The problem here - is that we can't always know what was intended on the commandline regarding quoting - - ::shellfilter::log::write $runtag "checking for redirections in $commandlist" - #sometimes we see a redirection without a following space e.g >C:/somewhere - #normalize - switch -regexp -- $lastitem\ - {^>[/[:alpha:]]+} { - set lastitem "> [string range $lastitem 1 end]" - }\ - {^>>[/[:alpha:]]+} { - set lastitem ">> [string range $lastitem 2 end]" - } - - - #for a redirection, we assume either a 2-element list at tail of form {> {some path maybe with spaces}} - #or that the tail redirection is not wrapped.. x y z > {some path maybe with spaces} - #we can't use list methods such as llenth on a member of commandlist - set wordlike_parts [regexp -inline -all {\S+} $lastitem] - - if {([llength $wordlike_parts] >= 2) && ([lindex $wordlike_parts 0] in [list ">>" ">"])} { - #wrapped redirection - but maybe not 'well' wrapped (unquoted filename) - set lastitem [string trim $lastitem] ;#we often see { > something} - - #don't use lassign or lrange on the element itself without checking first - #we can treat the commandlist as a whole as a well formed list but not neccessarily each element within. - #lassign $lastitem redir redirtarget - #set commandlist [lrange $commandlist 0 end-1] - # - set itemchars [split $lastitem ""] - set firstchar [lindex $itemchars 0] - set lastchar [lindex $itemchars end] - - #NAIVE test for double quoted only! - #consider for example {"a" x="b"} - #testing first and last is not decisive - #We need to decide what level of drilling down is even appropriate here.. - #if something was double wrapped - it was perhaps deliberate so we don't interpret it as something(?) - set head_tail_chars [list $firstchar $lastchar] - set doublequoted [expr {[llength [lsearch -all $head_tail_chars "\""]] == 2}] - if {[string equal "\{" $firstchar] && [string equal "\}" $lastchar]} { - set curlyquoted 1 - } else { - set curlyquoted 0 - } - - if {$curlyquoted} { - #these are not the tcl protection brackets but ones supplied in the argument - #it's still not valid to use list operations on a member of the commandlist - set inner [string range $lastitem 1 end-1] - #todo - fix! we still must assume there could be list-breaking data! - set innerwords [regexp -inline -all {\S+} $inner] ;#better than [split $inner] because we don't get extra empty elements for each whitespace char - set redir [lindex $innerwords 0] ;#a *potential* redir - to be tested below - set redirtarget [lrange $innerwords 1 end] ;#all the rest - } elseif {$doublequoted} { - ::shellfilter::log::write $debugname "doublequoting at tail of command '$commandlist'" - set inner [string range $lastitem 1 end-1] - set innerwords [regexp -inline -all {\S+} $inner] - set redir [lindex $innerwords 0] - set redirtarget [lrange $innerwords 1 end] - } else { - set itemwords [regexp -inline -all {\S+} $lastitem] - # e.g > c:\test becomes > {c:\test} - # but > c/mnt/c/test/temp.txt stays as > /mnt/c/test/temp.txt - set redir [lindex $itemwords 0] - set redirtarget [lrange $itemwords 1 end] - } - set commandlist [lrange $commandlist 0 end-1] - - } elseif {[lindex $commandlist end-1] in [list ">>" ">"]} { - #unwrapped redirection - #we should be able to use list operations like lindex and lrange here as the command itself is hopefully still a well formed list - set redir [lindex $commandlist end-1] - set redirtarget [lindex $commandlist end] - set commandlist [lrange $commandlist 0 end-2] - } else { - #no redirection - set redir "" - set redirtarget "" - #no change to command list - } - - - switch -- $redir { - ">>" - ">" { - set redirtarget [string trim $redirtarget "\""] - ::shellfilter::log::write $runtag " have redirection '$redir' to '$redirtarget'" - - set winfile $redirtarget ;#default assumption - switch -glob -- $redirtarget { - "/c/*" { - set winfile "c:/[string range $redirtarget 3 end]" - } - "/mnt/c/*" { - set winfile "c:/[string range $redirtarget 7 end]" - } - } - - if {[file exists [file dirname $winfile]]} { - #containing folder for target exists - if {$redir eq ">"} { - set teefile "write" - } else { - set teefile "append" - } - ::shellfilter::log::write $runtag "Directory exists '[file dirname $winfile]' operation:$teefile" - } else { - #we should be writing to a file.. but can't - ::shellfilter::log::write $runtag "cannot verify directory exists '[file dirname $winfile]'" - } - } - default { - ::shellfilter::log::write $runtag "No redir found!!" - } - } - - #often first element of command list is wrapped and cannot be run directly - #e.g {{ls -l} {> {temp.tmp}}} - #we will assume that if there is a single element which is a pathname containing a space - it is doubly wrapped. - # this may not be true - and the command may fail if it's just {c:\program files\etc} but it is the less common case and we currently have no way to detect. - #unwrap first element.. will not affect if not wrapped anyway (subject to comment above re spaces) - set commandlist [concat [lindex $commandlist 0] [lrange $commandlist 1 end]] - - #todo? - #child process environment. - # - to pass a different environment to the child - we would need to save the env array, modify as required, and then restore the env array. - - #to restore buffering states after run - set remember_in_out_err_buffering [list \ - [chan configure $inchan -buffering] \ - [chan configure $outchan -buffering] \ - [chan configure $errchan -buffering] \ - ] - - set remember_in_out_err_translation [list \ - [chan configure $inchan -translation] \ - [chan configure $outchan -translation] \ - [chan configure $errchan -translation] \ - ] - - - - - - chan configure $inchan -buffering $inbuffering -blocking 0 ;#we are setting up a readable handler for this - so non-blocking ok - chan configure $errchan -buffering $errbuffering - #chan configure $outchan -blocking 0 - chan configure $outchan -buffering $outbuffering ;#don't configure non-blocking. weird duplicate of *second* line occurs if you do. - # - - #-------------------------------------------- - #Tested on windows. Works to stop in output when buffering is none, reading from channel with -translation auto - #cmd, pwsh, tcl - #chan configure $outchan -translation lf - #chan configure $errchan -translation lf - #-------------------------------------------- - chan configure $outchan -translation $outtranslation - chan configure $errchan -translation $outtranslation - - #puts stderr "chan configure $wrerr [chan configure $wrerr]" - if {$debug} { - ::shellfilter::log::write $debugname "COMMAND [list $commandlist] strlen:[string length $commandlist] llen:[llength $commandlist]" - } - #todo - handle custom redirection of stderr to a file? - if {[string length $custom_stderr]} { - #::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist $custom_stderr] a+" - #set rdout [open |[concat $commandlist $custom_stderr] a+] - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list $custom_stderr <@$inchan]] [list RDONLY]" - set rdout [open |[concat $commandlist [list <@$inchan $custom_stderr]] [list RDONLY]] - set rderr "bogus" ;#so we don't wait for it - } else { - ::shellfilter::log::write $runtag "LAUNCH open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]" - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] a+] - #set rdout [open |[concat $commandlist [list 2>@$wrerr]] [list RDWR]] - - # If we don't redirect stderr to our own tcl-based channel - then the transforms don't get applied. - # This is the whole reason we need these file-event loops. - # Ideally we need something like exec,open in tcl that interacts with transformed channels directly and emits as it runs, not only at termination - # - and that at least appears like a terminal to the called command. - #set rdout [open |[concat $commandlist [list 2>@stderr <@$inchan]] [list RDONLY]] - - - set rdout [open |[concat $commandlist [list 2>@$wrerr <@$inchan]] [list RDONLY]] - - chan configure $rderr -buffering $errbuffering -blocking 0 - chan configure $rderr -translation $readprocesstranslation - } - - - - set command_pids [pid $rdout] - #puts stderr "command_pids: $command_pids" - #tcl::process ensemble only available in 8.7+ - and it didn't prove useful here anyway - # the child process generally won't shut down until channels are closed. - # premature EOF on grandchild process launch seems to be due to lack of terminal emulation when redirecting stdin/stdout. - # worked around in punk/repl using 'script' command as a fake tty. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $command_pids 0] ni $subprocesses} { - # puts stderr "pid [lindex $command_pids 0] not running $errMsg" - #} else { - # puts stderr "pid [lindex $command_pids 0] is running" - #} - - - if {$debug} { - ::shellfilter::log::write $debugname "pipeline pids: $command_pids" - } - - #jjj - - - chan configure $rdout -buffering $outbuffering -blocking 0 - chan configure $rdout -translation $readprocesstranslation - - if {![string length $custom_stderr]} { - chan event $rderr readable [list apply {{chan other wrerr outchan errchan waitfor errprefix errbuffering debug debugname pids} { - if {$errbuffering eq "line"} { - set countchunk [chan gets $chan chunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #errprefix only applicable to line buffered output - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $errchan ${errprefix}$chunk - } else { - puts $errchan "${errprefix}$chunk" - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $errchan $chunk - } - } - if {[chan eof $chan]} { - flush $errchan ;#jmn - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stderr reader: pid [lindex $pids 0] no longer running" - #} else { - # puts stderr "stderr reader: pid [lindex $pids 0] still running" - #} - chan close $chan - #catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stderr - } - } - }} $rderr $rdout $wrerr $outchan $errchan $waitvar $errprefix $errbuffering $debug $debugname $command_pids] - } - - #todo - handle case where large amount of stdin coming in faster than rdout can handle - #as is - arbitrary amount of memory could be used because we aren't using a filevent for rdout being writable - # - we're just pumping it in to the non-blocking rdout buffers - # ie there is no backpressure and stdin will suck in as fast as possible. - # for most commandlines this probably isn't too big a deal.. but it could be a problem for multi-GB disk images etc - # - # - - ## Note - detecting trailing missing nl before eof is basically the same here as when reading rdout from executable - # - but there is a slight difference in that with rdout we get an extra blocked state just prior to the final read. - # Not known if that is significant - ## with inchan configured -buffering line - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl -r cat - #warning reading input with -buffering line. Cannot detect missing trailing-newline at eof - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:1 pend:-1 count:3 - #etc - - if 0 { - chan event $inchan readable [list apply {{chan wrchan inbuffering waitfor} { - #chan copy stdin $chan ;#doesn't work in a chan event - if {$inbuffering eq "line"} { - set countchunk [chan gets $chan chunk] - #puts $wrchan "stdinstate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {[chan eof $chan]} { - puts -nonewline $wrchan $chunk - } else { - puts $wrchan $chunk - } - } - } else { - set chunk [chan read $chan] - if {[string length $chunk]} { - puts -nonewline $wrchan $chunk - } - } - if {[chan eof $chan]} { - puts stderr "|stdin_reader>eof [chan configure stdin]" - chan event $chan readable {} - #chan close $chan - chan close $wrchan write ;#half close - #set $waitfor "stdin" - } - }} $inchan $rdout $inbuffering $waitvar] - - if {[string length $stdinhandler]} { - chan configure stdin -buffering line -blocking 0 - chan event stdin readable $stdinhandler - } - } - - set actual_proc_out_buffering [chan configure $rdout -buffering] - set actual_outchan_buffering [chan configure $outchan -buffering] - #despite whatever is configured - we match our reading to how we need to output - set read_proc_out_buffering $actual_outchan_buffering - - - - if {[string length $teefile]} { - set logname "redir_[string map {: _} $winfile]_[tcl::clock::microseconds]" - set tid [::shellfilter::log::open $logname {-syslog 127.0.0.1:514}] - if {$teefile eq "write"} { - ::shellfilter::log::write $logname "opening '$winfile' for write" - set fd [open $winfile w] - } else { - ::shellfilter::log::write $logname "opening '$winfile' for appending" - set fd [open $winfile a] - } - #chan configure $fd -translation lf - chan configure $fd -translation $outtranslation - chan configure $fd -encoding utf-8 - - set tempvar_bytetotal [namespace current]::totalbytes[tcl::clock::microseconds] - set $tempvar_bytetotal 0 - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname writefile writefilefd copytempfile bytevar logtag} { - #review - if we write outprefix to normal stdout.. why not to redirected file? - #usefulness of outprefix is dubious - upvar $bytevar totalbytes - if {$read_proc_out_buffering eq "line"} { - #set outchunk [chan read $chan] - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - if {$countchunk >= 0} { - if {![chan eof $chan]} { - set numbytes [expr {[string length $outchunk] + 1}] ;#we are assuming \n not \r\n - but count won't/can't be completely accurate(?) - review - puts $writefilefd $outchunk - } else { - set numbytes [string length $outchunk] - puts -nonewline $writefilefd $outchunk - } - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - #puts $outchan "${outprefix} wrote $numbytes bytes to $writefile" - } - } else { - set outchunk [chan read $chan] - if {[string length $outchunk]} { - puts -nonewline $writefilefd $outchunk - set numbytes [string length $outchunk] - incr totalbytes $numbytes - ::shellfilter::log::write $logtag "${outprefix} wrote $numbytes bytes to $writefile" - } - } - if {[chan eof $chan]} { - flush $writefilefd ;#jmn - #set blocking so we can get exit code - chan configure $chan -blocking 1 - catch {::shellfilter::log::write $logtag "${outprefix} total bytes $totalbytes written to $writefile"} - #puts $outchan "${outprefix} total bytes $totalbytes written to $writefile" - catch {close $writefilefd} - if {$copytempfile} { - catch {file copy $writefile "[file rootname $writefile]_copy[file extension $writefile]"} - } - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {$debug} { - ::shellfilter::log::write $debugname "(teefile) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $winfile $fd $copytempfile $tempvar_bytetotal $logname] - - } else { - - # This occurs when we have outbuffering set to 'line' - as the 'input' from rdout which comes from the executable is also configured to 'line' - # where b:0|1 is whether chan blocked $chan returns 0 or 1 - # pend is the result of chan pending $chan - # eof is the resot of chan eof $chan - - - ##------------------------- - ##If we still read with gets,to retrieve line by line for output to line-buffered output - but the input channel is configured with -buffering none - ## then we can detect the difference - # there is an extra blocking read - but we can stil use eof with data to detect the absent newline and avoid passing an extra one on. - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /u/c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:1 eof:0 pend:-1 count:-1 - #instate b:0 eof:1 pend:-1 count:3 - #etc - ##------------------------ - - - #this should only occur if upstream is coming from stdin reader that has line buffering and hasn't handled the difference properly.. - ###reading with gets from line buffered input with trailing newline - #c:\repo\jn\punk\test>printf "test\netc\n" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - - ###reading with gets from line buffered input with trailing newline - ##No detectable difference! - #c:\repo\jn\punk\test>printf "test\netc" | tclsh punk.vfs/main.tcl /c cat - #instate b:0 eof:0 pend:-1 count:4 - #test - #instate b:0 eof:0 pend:-1 count:3 - #etc - #instate b:0 eof:1 pend:-1 count:-1 - ##------------------------- - - #Note that reading from -buffering none and writing straight out gives no problem because we pass the newlines through as is - - - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($rdout) 0 ;#a very specific case of readblocked prior to eof.. possibly not important - #this detection is disabled for now - but left for debugging in case it means something.. or changes - chan event $rdout readable [list apply {{chan other wrerr outchan errchan read_proc_out_buffering waitfor outprefix call_id debug debugname pids} { - #set outchunk [chan read $chan] - - if {$read_proc_out_buffering eq "line"} { - set countchunk [chan gets $chan outchunk] ;#only get one line so that order between stderr and stdout is more likely to be preserved - #countchunk can be -1 before eof e.g when blocked - #debugging output inline with data - don't leave enabled - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - if {$countchunk >= 0} { - if {![chan eof $chan]} { - puts $outchan ${outprefix}$outchunk - } else { - puts -nonewline $outchan ${outprefix}$outchunk - #if {$::shellfilter::chan::lastreadblocked_nodata_noeof($chan)} { - # seems to be the usual case - #} else { - # #false alarm, or ? we've reached eof with data but didn't get an empty blocking read just prior - # #Not known if this occurs - # #debugging output inline with data - don't leave enabled - # puts $outchan "!!!prev read didn't block: instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:$countchunk" - #} - } - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) 0 - } else { - #set ::shellfilter::chan::lastreadblocked_nodata_noeof($chan) [expr {[chan blocked $chan] && ![chan eof $chan]}] - } - } else { - #puts $outchan "read CHANNEL $chan [chan configure $chan]" - #puts $outchan "write CHANNEL $outchan b:[chan configure $outchan -buffering] t:[chan configure $outchan -translation] e:[chan configure $outchan -encoding]" - set outchunk [chan read $chan] - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan] count:[string length $outchunk]" - if {[string length $outchunk]} { - #set stringrep [encoding convertfrom utf-8 $outchunk] - #set newbytes [encoding convertto utf-16 $stringrep] - #puts -nonewline $outchan $newbytes - puts -nonewline $outchan $outchunk - } - } - - if {[chan eof $chan]} { - flush $outchan ;#jmn - #for now just look for first element in the pid list.. - #set subprocesses [tcl::process::list] - #puts stderr "subprocesses: $subprocesses" - #if {[lindex $pids 0] ni $subprocesses} { - # puts stderr "stdout reader pid: [lindex $pids 0] no longer running" - #} else { - # puts stderr "stdout reader pid: [lindex $pids 0] still running" - #} - - #puts $outchan "instate b:[chan blocked $chan] eof:[chan eof $chan] pend:[chan pending output $chan]" - chan configure $chan -blocking 1 ;#so we can get exit code - try { - chan close $chan - set ::shellfilter::shellcommandvars($call_id,exitcode) 0 - if {$debug} { - ::shellfilter::log::write $debugname " -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - set ::shellfilter::shellcommandvars($call_id,exitcode) $code - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with code: $code" - } - } trap CHILDKILLED {result options} { - #set code [lindex [dict get $options -errorcode] 2] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled" - if {$debug} { - ::shellfilter::log::write $debugname " CHILD PROCESS EXITED with result:'$result' options:'$options'" - } - - } finally { - #puts stdout "HERE" - #flush stdout - - } - catch {chan close $wrerr} - if {$other ni [chan names]} { - set $waitfor stdout - } - - } - }} $rdout $rderr $wrerr $outchan $errchan $read_proc_out_buffering $waitvar $outprefix $call_id $debug $debugname $command_pids] - } - - #todo - add ability to detect activity/data-flow and change timeout to only apply for period with zero data - #e.g x hrs with no data(?) - #reset timeout when data detected. - after $timeout [string map [list %w% $waitvar %id% $call_id %wrerr% $wrerr %rdout% $rdout %rderr% $rderr %debug% $debug %debugname% $debugname] { - if {[info exists ::shellfilter::shellcommandvars(%id%,exitcode)]} { - if {[set ::shellfilter::shellcommandvars(%id%,exitcode)] ne ""} { - catch { chan close %wrerr% } - catch { chan close %rdout%} - catch { chan close %rderr%} - } else { - chan configure %rdout% -blocking 1 - try { - chan close %rdout% - set ::shellfilter::shellcommandvars(%id%,exitcode) 0 - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) -- child process returned no error. (exit code 0) --" - } - } trap CHILDSTATUS {result options} { - set code [lindex [dict get $options -errorcode] 2] - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILD PROCESS EXITED with code: $code" - } - set ::shellfilter::shellcommandvars(%id%,exitcode) $code - } trap CHILDKILLED {result options} { - set code [lindex [dict get $options -errorcode] 2] - #set code [dict get $options -code] - #set ::shellfilter::shellcommandvars(%id%,exitcode) $code - #set ::shellfilter::shellcommandvars($call_id,exitcode) "childkilled-timeout" - set ::shellfilter::shellcommandvars(%id%,exitcode) "childkilled-timeout" - if {%debug%} { - ::shellfilter::log::write %debugname% "(timeout) CHILDKILLED with code: $code" - ::shellfilter::log::write %debugname% "(timeout) result:$result options:$options" - } - - } - catch { chan close %wrerr% } - catch { chan close %rderr%} - } - set %w% "timeout" - } - }] - - - vwait $waitvar - - set exitcode [set ::shellfilter::shellcommandvars($call_id,exitcode)] - if {![string is digit -strict $exitcode]} { - puts stderr "Process exited with non-numeric code: $exitcode" - flush stderr - } - if {[string length $teefile]} { - #cannot be called from within an event handler above.. vwait reentrancy etc - catch {::shellfilter::log::close $logname} - } - - if {$debug} { - ::shellfilter::log::write $debugname " closed by: [set $waitvar] with exitcode: $exitcode" - catch {::shellfilter::log::close $debugname} - } - array unset ::shellfilter::shellcommandvars $call_id,* - - - #restore buffering to pre shellfilter::run state - lassign $remember_in_out_err_buffering bin bout berr - chan configure $inchan -buffering $bin - chan configure $outchan -buffering $bout - chan configure $errchan -buffering $berr - - lassign $remember_in_out_err_translation tin tout terr - chan configure $inchan -translation $tin - chan configure $outchan -translation $tout - chan configure $errchan -translation $terr - - - #in channel probably closed..(? review - should it be?) - catch { - chan configure $inchan -buffering $bin - } - - - return [list exitcode $exitcode] - } - -} - -package provide shellfilter [namespace eval shellfilter { - variable version - set version 0.1.9 -}] diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm index 97969463..43311b9e 100644 --- a/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/bootsupport/modules/textblock-0.1.3.tm @@ -4206,7 +4206,7 @@ tcl::namespace::eval textblock { } #examples ptable.com - set elements [list\ + set elements_layout [list\ 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ @@ -4218,6 +4218,76 @@ tcl::namespace::eval textblock { "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ ] + #generate list of elements ordered by atomic number from the layout table (0 based - so atomic number is +1) + #create a lookup dict from symbol to atomic number at same time + set elements [list] + set e_atomic [dict create] + set e_group [dict create] + set e_period [dict create] + set atomic 0 ;#first, H, will be 1 + set period 0 + set group 0 + foreach e $elements_layout { + if {[string trim $e] eq ""} { + switch -- $period { + 6a { + set period "6c" + set atomic 71 ;#next is Hf=72 + } + 7a { + set period "7c" + set atomic 103 ;#next is Rf=104 + } + } + if {$group == 18} { + #handle rows of blanks + set group 0 + } else { + incr group + } + continue + } + if {[string is digit -strict $e]} { + if {$period in {0 1 2 3 4}} { + set period $e + } else { + switch -- $period { + 5 { + set period 6a + } + 6c { + set period 7a + } + 6b { + set period 7b + set atomic 88 ;#next is Ac=89 + } + 7c { + set period 6b + set atomic 56 ;#next is La=57 + } + } + } + incr group + continue + } + + incr atomic + lappend elements $e + dict set e_atomic $e $atomic + dict set e_group $e $group + dict set e_period $e [string index $period 0] + if {$group == 18} { + set group 0 ;#false group 0 for first column of period numbers + } else { + incr group + } + } + #test no screwup above + if {[dict get $e_atomic Og] ne "118" || [dict get $e_atomic Lr] ne "103"} { + error "textblock::periodic programming error Og->[dict get $e_atomic Og] Lr->[dict get $e_atomic Lr] should be Og->118 Lr->103" + } + set type_colours [list] @@ -4297,20 +4367,35 @@ tcl::namespace::eval textblock { tcl::dict::set ecat $e $val } - set elements1 [list] + set elements_layout_coloured [list] set RST [a+] - foreach e $elements { - if {[tcl::dict::exists $ecat $e]} { - set ansi [tcl::dict::get $ecat $e ansi] - #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] - #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway - lappend elements1 $ansi$e - } else { - lappend elements1 $e + if {[tcl::dict::get $opts -compact]} { + foreach e $elements_layout { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #lappend elements_layout_coloured [textblock::pad $ansi$e -width 2 -which right] + #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway + lappend elements_layout_coloured $ansi$e + } else { + lappend elements_layout_coloured $e + } + } + } else { + foreach e $elements_layout { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #the atomic number should be a superscript as is the norm + #use subscript on line above + set a [punk::char::lib::subscript_number [tcl::dict::get $e_atomic $e]] + lappend elements_layout_coloured "$ansi$a\n $e " + } else { + lappend elements_layout_coloured $e + } } + } - set t [list_as_table -columns 19 -return tableobject $elements1] + set t [list_as_table -columns 19 -return tableobject $elements_layout_coloured] #(defaults to show_hseps 0) #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options diff --git a/src/vendormodules/uuid-1.0.7.tm b/src/bootsupport/modules/uuid-1.0.9.tm similarity index 98% rename from src/vendormodules/uuid-1.0.7.tm rename to src/bootsupport/modules/uuid-1.0.9.tm index fbd43f3d..dd6d3cd5 100644 --- a/src/vendormodules/uuid-1.0.7.tm +++ b/src/bootsupport/modules/uuid-1.0.9.tm @@ -11,7 +11,7 @@ # Usage: uuid::uuid generate # uuid::uuid equal $idA $idB -package require Tcl 8.5 +package require Tcl 8.5 9 namespace eval uuid { variable accel @@ -47,7 +47,7 @@ proc ::uuid::generate_tcl_machinfo {} { # If we have /dev/urandom just stream 128 bits from that ### if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] + set fin [open /dev/urandom rb] binary scan [read $fin 128] H* machinfo close $fin } elseif {[catch {package require nettool}]} { @@ -236,7 +236,7 @@ namespace eval ::uuid { unset e } -package provide uuid 1.0.7 +package provide uuid 1.0.9 # ------------------------------------------------------------------------- # Local variables: diff --git a/src/bootsupport/modules/zipper-0.12.tm b/src/bootsupport/modules/zipper-0.12.tm index 1983211c4274a86b312dfaeee4ea996e1b9ac7e1..99a566c7b8c867e67a04e4b22e3ace38a2be6d18 100644 GIT binary patch delta 217 zcmez5^TTJu6-faO4hHL$GST~t)8iL&GB9Lrej=I9S#Qhy&u#OAS5u|;NH{y~R{Vd{ zx$PF8ll7F_%Z0So25x;>QTu1|;?t)88Fp0q3M*HaMwF*(p7Ykdo~Tzn@7&z%TQ^E$ zw~9K*&Ef8kda9*jA$q}Rn*EwJU82+a=5Af#k$N=lNkctzfHyOX2m=Gq1vVweb(XJc zUwV#_fgy*Pfq_|(fo-ytniAXp|4a-FjGNypUuVQ{>Evsw4vZX=#nluTA5XSWGhzG2 H%>V=dQ<709 delta 220 zcmez2^T}t!6-f~W4u*-!1yP%mB{$FGWMGh$WnfU6{7zMMGq02#XT3Gkx%GEEj=m5O z;{E9_YSdAdb=&b)oZ+G)D{i^$w%c@4@S#;L!-PG2or!y_M0S7Xe;zsQwZU{-|AXh| z=Iq(&cY{lT|J+-*wMC+nCUIp*o|bnGJIdvK{G5Bpl1)kakG|ax@MdNaVPF6{!lvZ7 z&hl05OV2SfFyt^ZFeoyxGAK`WQd404{~su{`K$7EMgerkPQIh+z{oIJR!xEN-efy9 L6SfcBK*JaSk%ds4 diff --git a/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm b/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm index d3138501..f0a11462 100644 --- a/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm +++ b/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm @@ -178,7 +178,8 @@ if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} { if {[file isfile $f]} { regsub {^\./} $f {} f set fd [open $f] - chan configure $fd -translation binary -encoding binary + #chan configure $fd -translation binary -encoding binary + chan configure $fd -translation binary -encoding iso8859-1 zipper::addentry $f [read $fd] [file mtime $f] close $fd } elseif {[file isdir $f]} { diff --git a/src/modules/punk/mix-0.1.tm b/src/modules/punk/mix-0.1.tm deleted file mode 100644 index 1e77b3d4..00000000 --- a/src/modules/punk/mix-0.1.tm +++ /dev/null @@ -1,87 +0,0 @@ - - -namespace eval punk::mix { -package require punk::lib - - -package require punk::mix_custom - proc runcli {args} { - if {![llength $args]} { - tailcall punk::mix::clicommands help - } else { - tailcall punk::mix::clicommands {*}$args - } - } -} - -namespace eval punk::mix::clicommands { - namespace export help new - namespace ensemble create - namespace ensemble configure [namespace current] -unknown punk::mix::clicommands::_unknown - - proc set_alias {cmdname} { - uplevel #0 [list interp alias {} $cmdname {} punk::mix::runcli] - } - proc _unknown {ns args} { - puts stderr "arglen:[llength $args]" - puts stdout "_unknown '$ns' '$args'" - - list punk::mix::clicommands::help {*}$args - } - - - proc new {name} { - set curdir [pwd] - if {[file exists $curdir/$name]} { - error "Unable to create new project at $curdir/$name - file/folder already exists" - } - set base $curdir/$name - file mkdir $base - file mkdir $base/src - file mkdir $base/modules - - - } - -} -punk::ensemble::extend punk::mix::clicommands punk::mix_custom - - -namespace eval punk::mix::clicommands { - proc help {args} { - #' **%ensemblecommand% help** *args* - #' - #' Help for ensemble commands in the command line interface - #' - #' - #' Arguments: - #' - #' * args - first word of args is the helptopic requested - usually a command name - #' - calling help with no arguments will list available commands - #' - #' Returns: help text (text) - #' - #' Examples: - #' - #' ``` - #' %ensemblecommand% help - #' ``` - #' - #' - - - set commands [namespace export] - set helpstr "" - append helpstr "commands:\n" - foreach cmd $commands { - append helpstr " $cmd" - } - return $helpstr - } -} - -package provide punk::mix [namespace eval punk::mix { - variable version - set version 0.1 - -}] \ No newline at end of file diff --git a/src/modules/punk/mix/cli-999999.0a1.0.tm b/src/modules/punk/mix/cli-999999.0a1.0.tm index 655bed96..76ee6f29 100644 --- a/src/modules/punk/mix/cli-999999.0a1.0.tm +++ b/src/modules/punk/mix/cli-999999.0a1.0.tm @@ -759,7 +759,7 @@ namespace eval punk::mix::cli { } } else { - puts -nonewline stderr "P" + puts -nonewline stderr "Z" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $build_event targetset_end SKIPPED @@ -791,7 +791,7 @@ namespace eval punk::mix::cli { $event targetset_end OK -note "zip modpod" } } else { - puts -nonewline stderr "p" + puts -nonewline stderr "z" set did_skip 1 if {$is_interesting} { puts stderr "$modulefile [$event targetset_source_changes]" @@ -802,7 +802,8 @@ namespace eval punk::mix::cli { } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar ? + } file { set m $modpath diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm index f6b5aa6a..1e09252d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -8259,9 +8259,29 @@ namespace eval punk { interp alias {} d/~ {} punk::nav::fs::d/~ interp alias "" x/ "" punk::nav::fs::x/ + variable pshell_path "" + # ---------------------------------------- + set pshell_path [auto_execok pwsh] ;#Still not installed by default on win10 11? + if {$pshell_path eq ""} { + #fallback to powershell 5 + #set pshell_path [auto_execok powershell] + set pshell_path powershell ;#temp + } else { + set pshell_path pwsh ;#temp + } + #todo - review run commands and handling of paths with spaces + # ---------------------------------------- - if {$::tcl_platform(platform) eq "windows"} { + + + if {$pshell_path eq ""} { + set has_powershell 0 + } else { + #todo - review powershell detection on non-windows platforms set has_powershell 1 + } + + if {$::tcl_platform(platform) eq "windows"} { interp alias {} dl {} dir /q interp alias {} dw {} dir /W/D } else { @@ -8269,8 +8289,6 @@ namespace eval punk { #interp alias {} dl {} interp alias {} dl {} puts stderr "not implemented" interp alias {} dw {} puts stderr "not implemented" - #todo - powershell detection on other platforms - set has_powershell 0 } #todo - distinguish non-preinstalled pwsh (powershell core) from powershell which is available by default @@ -8279,13 +8297,19 @@ namespace eval punk { # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() # $ps = [Powershell]::Create() - interp alias {} pse {} exec >@stdout pwsh -nolo -nop -c - interp alias {} psx {} runx -n pwsh -nop -nolo -c - interp alias {} psr {} run -n pwsh -nop -nolo -c - interp alias {} psout {} runout -n pwsh -nop -nolo -c - interp alias {} pserr {} runerr -n pwsh -nop -nolo -c - interp alias {} psls {} shellrun::runconsole pwsh -nop -nolo -c ls - interp alias {} psps {} shellrun::runconsole pwsh -nop -nolo -c ps + interp alias {} pse {} exec >@stdout {*}$pshell_path -nolo -nop -c + interp alias {} psx {} runx -n {*}$pshell_path -nop -nolo -c + interp alias {} psr {} run -n {*}$pshell_path -nop -nolo -c + interp alias {} psout {} runout -n {*}$pshell_path -nop -nolo -c + interp alias {} pserr {} runerr -n {*}$pshell_path -nop -nolo -c + #interp alias {} psls {} shellrun::runconsole $pshell_path -nop -nolo -c ls + #interp alias {} psls {} shellrun::runconsole {*}$pshell_path -nop -nolo -c {ls | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table} + proc psls args { + variable pshell_path + shellrun::runconsole {*}$pshell_path -nop -nolo -c {*}[string map [list %a% $args] {{ls %a% | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table}}] + } + interp alias {} psls {} punk::psls + interp alias {} psps {} shellrun::runconsole {*}$pshell_path -nop -nolo -c ps } else { set ps_missing "powershell missing (powershell is MIT licensed open source and can be installed on windows and most unix-like platforms)" interp alias {} pse {} puts stderr $ps_missing diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index 69df08b9..c8195b6e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -2761,6 +2761,69 @@ tcl::namespace::eval punk::char { } +tcl::namespace::eval punk::char::lib { + variable num_superscript + #digits and a small set of related symbols + set num_superscript [list\ + i \u2071\ + 0 \u2070\ + 1 \u00B9\ + 2 \u00B2\ + 3 \u00B3\ + 4 \u2074\ + 5 \u2075\ + 6 \u2076\ + 7 \u2077\ + 8 \u2078\ + 9 \u2079\ + + \u207A\ + - \u207B\ + = \u207C\ + ( \u207D\ + ) \u207E\ + n \u207F\ + ] + variable num_supersub_re + set num_supersub_re {^[0-9in+\-\(\)\=]+$} + proc superscript_number {n} { + if {$n eq ""} {return ""} + variable num_superscript + variable num_supersub_re + if {![regexp $num_supersub_re $n]} { + error "Cannot convert string '$n' to superscript. valid chars: [dict keys $num_superscript]" + } + return [string map $num_superscript $n] + } + set num_subscript [list\ + i \u1D62\ + 0 \u2080\ + 1 \u2081\ + 2 \u2082\ + 3 \u2083\ + 4 \u2084\ + 5 \u2085\ + 6 \u2086\ + 7 \u2087\ + 8 \u2088\ + 9 \u2089\ + + \u208A\ + - \u208B\ + = \u208C\ + ( \u208D\ + ) \u208E\ + n \u2099\ + ] + proc subscript_number {n} { + if {$n eq ""} {return ""} + variable num_subscript + variable num_supersub_re + if {![regexp $num_supersub_re $n]} { + error "Cannot convert string '$n' to subcript. valid chars: [dict keys $num_subscript]" + } + return [string map $num_subscript $n] + } +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index afd06d2a..17c9918b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -759,7 +759,7 @@ namespace eval punk::mix::cli { } } else { - puts -nonewline stderr "P" + puts -nonewline stderr "Z" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $build_event targetset_end SKIPPED @@ -791,7 +791,7 @@ namespace eval punk::mix::cli { $event targetset_end OK -note "zip modpod" } } else { - puts -nonewline stderr "p" + puts -nonewline stderr "z" set did_skip 1 if {$is_interesting} { puts stderr "$modulefile [$event targetset_source_changes]" @@ -802,7 +802,8 @@ namespace eval punk::mix::cli { } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar ? + } file { set m $modpath diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index ef3e2a2f..85ef0692 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -257,6 +257,24 @@ namespace eval punk::mix::commandset::scriptwrap { set target_labels_found [dict create] set possible_target_labels_found [dict create] set warning_target_labels_found [dict create] + + #todo - allow analysis of colon-less call. May need to check list of internal commands - but what about external ones? + #set searchregexex [list {(.*\s+|^)(@*call\s*:*)(\S.*)} {(.*\s+|^)(@*CALL\s*:*)(\S.*)} {(.*\s+|^)(@*goto\s*:*)(\S.*)} {(.*\s+|^)(@*GOTO\s*:*)(\S.*)}] + + #order of regex testing is important - test more specific entries with colon/comment before we test whitespace only version of goto/call + set searchregexes [list {(.*\s+|^)(@*call\s*:)(\S.*)} {(.*\s+|^)(@*CALL\s*:)(\S.*)} {(.*\s+|^)(@*goto\s*:)(\S.*)} {(.*\s*|.*\s+|^)(@*GOTO\s*:)(\S.*)}] + lappend searchregexes {(.*\|\|.*)(@*GOTO\s*:)(\S.*)} ;#review + lappend searchregexes {(.*\s+|^)(@*goto\s+%=.*=%\s*:)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*goto\s+%=.*=%\s+)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*goto\s+)(\S.*)} + + lappend searchregexes {(.*\s+|^)(@*GOTO\s+%=.*=%\s*:)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*GOTO\s+%=.*=%\s+)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*GOTO\s+)(\S.*)} + #review + #todo - better callsite analysis. There can be data between @GOTO or @CALL and : other than just whitespace + #e.g for @goto %= possible comment=% :mylabe%%l etc + for {set callingline_index 0} {$callingline_index < $line_count} {incr callingline_index} { set callingline_info [$objFile lineinfo $callingline_index] set callingline_payload [dict get $callingline_info payload] @@ -273,18 +291,15 @@ namespace eval punk::mix::commandset::scriptwrap { } default { - #todo - better callsite analysis. There can be data between @GOTO or @CALL and : other than just whitespace! - #todo - allow analysis of colon-less call. May need to check list of internal commands - but what about external ones? - #foreach search_regex [list {(.*\s+|^)(@*call\s*:*)(\S.*)} {(.*\s+|^)(@*CALL\s*:*)(\S.*)} {(.*\s+|^)(@*goto\s*:*)(\S.*)} {(.*\s+|^)(@*GOTO\s*:*)(\S.*)}] {} - foreach search_regex [list {(.*\s+|^)(@*call\s*:)(\S.*)} {(.*\s+|^)(@*CALL\s*:)(\S.*)} {(.*\s+|^)(@*goto\s*:)(\S.*)} {(.*\s*|.*\s+|^)(@*GOTO\s*:)(\S.*)} {(.*\|\|.*)(@*GOTO\s*:)(\S.*)}] { + foreach search_regex $searchregexes { if {[regexp $search_regex $callingline_payload _m precall call labelplus]} { #todo further checks to see if it's actually a batch script line # - - - - work out what cmd.exe considers start of 512B boundaries when scanning from a callsite #callposn affected by newlines? #set callposn [expr {$file_offset + [string length $callingline_payload]}] ;#take callposn as end of line .. review - multiline statements? - set callposn [expr {$file_offset + $callingline_len}] - + set callposn [expr {$file_offset + $callingline_len -1}] + #Note there are anomalies around target labels in bracketed sections such as IF blocks #this is bad practice - as it can lead to unbalanced braces - but batch files can still work under cmd.exe with them in some cases #e.g unbalanced trailing bracket may be ignored. @@ -1741,7 +1756,7 @@ namespace eval punk::mix::commandset::scriptwrap { #note that: #@REM ----- #@goto ^ - #:label + #:label #@REM----- # is a valid callsite - but doesn't appear to be found by the label scanner as it's own target label even though :label is on it's own line from non-batch perspective # so the caller will have to do some batch-style line processing to find all call sites diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 97969463..43311b9e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -4206,7 +4206,7 @@ tcl::namespace::eval textblock { } #examples ptable.com - set elements [list\ + set elements_layout [list\ 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ @@ -4218,6 +4218,76 @@ tcl::namespace::eval textblock { "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ ] + #generate list of elements ordered by atomic number from the layout table (0 based - so atomic number is +1) + #create a lookup dict from symbol to atomic number at same time + set elements [list] + set e_atomic [dict create] + set e_group [dict create] + set e_period [dict create] + set atomic 0 ;#first, H, will be 1 + set period 0 + set group 0 + foreach e $elements_layout { + if {[string trim $e] eq ""} { + switch -- $period { + 6a { + set period "6c" + set atomic 71 ;#next is Hf=72 + } + 7a { + set period "7c" + set atomic 103 ;#next is Rf=104 + } + } + if {$group == 18} { + #handle rows of blanks + set group 0 + } else { + incr group + } + continue + } + if {[string is digit -strict $e]} { + if {$period in {0 1 2 3 4}} { + set period $e + } else { + switch -- $period { + 5 { + set period 6a + } + 6c { + set period 7a + } + 6b { + set period 7b + set atomic 88 ;#next is Ac=89 + } + 7c { + set period 6b + set atomic 56 ;#next is La=57 + } + } + } + incr group + continue + } + + incr atomic + lappend elements $e + dict set e_atomic $e $atomic + dict set e_group $e $group + dict set e_period $e [string index $period 0] + if {$group == 18} { + set group 0 ;#false group 0 for first column of period numbers + } else { + incr group + } + } + #test no screwup above + if {[dict get $e_atomic Og] ne "118" || [dict get $e_atomic Lr] ne "103"} { + error "textblock::periodic programming error Og->[dict get $e_atomic Og] Lr->[dict get $e_atomic Lr] should be Og->118 Lr->103" + } + set type_colours [list] @@ -4297,20 +4367,35 @@ tcl::namespace::eval textblock { tcl::dict::set ecat $e $val } - set elements1 [list] + set elements_layout_coloured [list] set RST [a+] - foreach e $elements { - if {[tcl::dict::exists $ecat $e]} { - set ansi [tcl::dict::get $ecat $e ansi] - #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] - #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway - lappend elements1 $ansi$e - } else { - lappend elements1 $e + if {[tcl::dict::get $opts -compact]} { + foreach e $elements_layout { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #lappend elements_layout_coloured [textblock::pad $ansi$e -width 2 -which right] + #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway + lappend elements_layout_coloured $ansi$e + } else { + lappend elements_layout_coloured $e + } + } + } else { + foreach e $elements_layout { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #the atomic number should be a superscript as is the norm + #use subscript on line above + set a [punk::char::lib::subscript_number [tcl::dict::get $e_atomic $e]] + lappend elements_layout_coloured "$ansi$a\n $e " + } else { + lappend elements_layout_coloured $e + } } + } - set t [list_as_table -columns 19 -return tableobject $elements1] + set t [list_as_table -columns 19 -return tableobject $elements_layout_coloured] #(defaults to show_hseps 0) #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options diff --git a/src/bootsupport/modules/uuid-1.0.7.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.9.tm similarity index 98% rename from src/bootsupport/modules/uuid-1.0.7.tm rename to src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.9.tm index fbd43f3d..dd6d3cd5 100644 --- a/src/bootsupport/modules/uuid-1.0.7.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/uuid-1.0.9.tm @@ -11,7 +11,7 @@ # Usage: uuid::uuid generate # uuid::uuid equal $idA $idB -package require Tcl 8.5 +package require Tcl 8.5 9 namespace eval uuid { variable accel @@ -47,7 +47,7 @@ proc ::uuid::generate_tcl_machinfo {} { # If we have /dev/urandom just stream 128 bits from that ### if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] + set fin [open /dev/urandom rb] binary scan [read $fin 128] H* machinfo close $fin } elseif {[catch {package require nettool}]} { @@ -236,7 +236,7 @@ namespace eval ::uuid { unset e } -package provide uuid 1.0.7 +package provide uuid 1.0.9 # ------------------------------------------------------------------------- # Local variables: diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.12.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.12.tm index 1983211c4274a86b312dfaeee4ea996e1b9ac7e1..99a566c7b8c867e67a04e4b22e3ace38a2be6d18 100644 GIT binary patch delta 217 zcmez5^TTJu6-faO4hHL$GST~t)8iL&GB9Lrej=I9S#Qhy&u#OAS5u|;NH{y~R{Vd{ zx$PF8ll7F_%Z0So25x;>QTu1|;?t)88Fp0q3M*HaMwF*(p7Ykdo~Tzn@7&z%TQ^E$ zw~9K*&Ef8kda9*jA$q}Rn*EwJU82+a=5Af#k$N=lNkctzfHyOX2m=Gq1vVweb(XJc zUwV#_fgy*Pfq_|(fo-ytniAXp|4a-FjGNypUuVQ{>Evsw4vZX=#nluTA5XSWGhzG2 H%>V=dQ<709 delta 220 zcmez2^T}t!6-f~W4u*-!1yP%mB{$FGWMGh$WnfU6{7zMMGq02#XT3Gkx%GEEj=m5O z;{E9_YSdAdb=&b)oZ+G)D{i^$w%c@4@S#;L!-PG2or!y_M0S7Xe;zsQwZU{-|AXh| z=Iq(&cY{lT|J+-*wMC+nCUIp*o|bnGJIdvK{G5Bpl1)kakG|ax@MdNaVPF6{!lvZ7 z&hl05OV2SfFyt^ZFeoyxGAK`WQd404{~su{`K$7EMgerkPQIh+z{oIJR!xEN-efy9 L6SfcBK*JaSk%ds4 diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm index f6b5aa6a..1e09252d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm @@ -8259,9 +8259,29 @@ namespace eval punk { interp alias {} d/~ {} punk::nav::fs::d/~ interp alias "" x/ "" punk::nav::fs::x/ + variable pshell_path "" + # ---------------------------------------- + set pshell_path [auto_execok pwsh] ;#Still not installed by default on win10 11? + if {$pshell_path eq ""} { + #fallback to powershell 5 + #set pshell_path [auto_execok powershell] + set pshell_path powershell ;#temp + } else { + set pshell_path pwsh ;#temp + } + #todo - review run commands and handling of paths with spaces + # ---------------------------------------- - if {$::tcl_platform(platform) eq "windows"} { + + + if {$pshell_path eq ""} { + set has_powershell 0 + } else { + #todo - review powershell detection on non-windows platforms set has_powershell 1 + } + + if {$::tcl_platform(platform) eq "windows"} { interp alias {} dl {} dir /q interp alias {} dw {} dir /W/D } else { @@ -8269,8 +8289,6 @@ namespace eval punk { #interp alias {} dl {} interp alias {} dl {} puts stderr "not implemented" interp alias {} dw {} puts stderr "not implemented" - #todo - powershell detection on other platforms - set has_powershell 0 } #todo - distinguish non-preinstalled pwsh (powershell core) from powershell which is available by default @@ -8279,13 +8297,19 @@ namespace eval punk { # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() # $ps = [Powershell]::Create() - interp alias {} pse {} exec >@stdout pwsh -nolo -nop -c - interp alias {} psx {} runx -n pwsh -nop -nolo -c - interp alias {} psr {} run -n pwsh -nop -nolo -c - interp alias {} psout {} runout -n pwsh -nop -nolo -c - interp alias {} pserr {} runerr -n pwsh -nop -nolo -c - interp alias {} psls {} shellrun::runconsole pwsh -nop -nolo -c ls - interp alias {} psps {} shellrun::runconsole pwsh -nop -nolo -c ps + interp alias {} pse {} exec >@stdout {*}$pshell_path -nolo -nop -c + interp alias {} psx {} runx -n {*}$pshell_path -nop -nolo -c + interp alias {} psr {} run -n {*}$pshell_path -nop -nolo -c + interp alias {} psout {} runout -n {*}$pshell_path -nop -nolo -c + interp alias {} pserr {} runerr -n {*}$pshell_path -nop -nolo -c + #interp alias {} psls {} shellrun::runconsole $pshell_path -nop -nolo -c ls + #interp alias {} psls {} shellrun::runconsole {*}$pshell_path -nop -nolo -c {ls | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table} + proc psls args { + variable pshell_path + shellrun::runconsole {*}$pshell_path -nop -nolo -c {*}[string map [list %a% $args] {{ls %a% | Select-Object Mode, @{Name='Owner';Expression={(Get-Acl $_.FullName).Owner}}, LastWriteTime, Length, Name | Format-Table}}] + } + interp alias {} psls {} punk::psls + interp alias {} psps {} shellrun::runconsole {*}$pshell_path -nop -nolo -c ps } else { set ps_missing "powershell missing (powershell is MIT licensed open source and can be installed on windows and most unix-like platforms)" interp alias {} pse {} puts stderr $ps_missing diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index 69df08b9..c8195b6e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -2761,6 +2761,69 @@ tcl::namespace::eval punk::char { } +tcl::namespace::eval punk::char::lib { + variable num_superscript + #digits and a small set of related symbols + set num_superscript [list\ + i \u2071\ + 0 \u2070\ + 1 \u00B9\ + 2 \u00B2\ + 3 \u00B3\ + 4 \u2074\ + 5 \u2075\ + 6 \u2076\ + 7 \u2077\ + 8 \u2078\ + 9 \u2079\ + + \u207A\ + - \u207B\ + = \u207C\ + ( \u207D\ + ) \u207E\ + n \u207F\ + ] + variable num_supersub_re + set num_supersub_re {^[0-9in+\-\(\)\=]+$} + proc superscript_number {n} { + if {$n eq ""} {return ""} + variable num_superscript + variable num_supersub_re + if {![regexp $num_supersub_re $n]} { + error "Cannot convert string '$n' to superscript. valid chars: [dict keys $num_superscript]" + } + return [string map $num_superscript $n] + } + set num_subscript [list\ + i \u1D62\ + 0 \u2080\ + 1 \u2081\ + 2 \u2082\ + 3 \u2083\ + 4 \u2084\ + 5 \u2085\ + 6 \u2086\ + 7 \u2087\ + 8 \u2088\ + 9 \u2089\ + + \u208A\ + - \u208B\ + = \u208C\ + ( \u208D\ + ) \u208E\ + n \u2099\ + ] + proc subscript_number {n} { + if {$n eq ""} {return ""} + variable num_subscript + variable num_supersub_re + if {![regexp $num_supersub_re $n]} { + error "Cannot convert string '$n' to subcript. valid chars: [dict keys $num_subscript]" + } + return [string map $num_subscript $n] + } +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index afd06d2a..17c9918b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -759,7 +759,7 @@ namespace eval punk::mix::cli { } } else { - puts -nonewline stderr "P" + puts -nonewline stderr "Z" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $build_event targetset_end SKIPPED @@ -791,7 +791,7 @@ namespace eval punk::mix::cli { $event targetset_end OK -note "zip modpod" } } else { - puts -nonewline stderr "p" + puts -nonewline stderr "z" set did_skip 1 if {$is_interesting} { puts stderr "$modulefile [$event targetset_source_changes]" @@ -802,7 +802,8 @@ namespace eval punk::mix::cli { } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar ? + } file { set m $modpath diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm index ef3e2a2f..85ef0692 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/scriptwrap-0.1.0.tm @@ -257,6 +257,24 @@ namespace eval punk::mix::commandset::scriptwrap { set target_labels_found [dict create] set possible_target_labels_found [dict create] set warning_target_labels_found [dict create] + + #todo - allow analysis of colon-less call. May need to check list of internal commands - but what about external ones? + #set searchregexex [list {(.*\s+|^)(@*call\s*:*)(\S.*)} {(.*\s+|^)(@*CALL\s*:*)(\S.*)} {(.*\s+|^)(@*goto\s*:*)(\S.*)} {(.*\s+|^)(@*GOTO\s*:*)(\S.*)}] + + #order of regex testing is important - test more specific entries with colon/comment before we test whitespace only version of goto/call + set searchregexes [list {(.*\s+|^)(@*call\s*:)(\S.*)} {(.*\s+|^)(@*CALL\s*:)(\S.*)} {(.*\s+|^)(@*goto\s*:)(\S.*)} {(.*\s*|.*\s+|^)(@*GOTO\s*:)(\S.*)}] + lappend searchregexes {(.*\|\|.*)(@*GOTO\s*:)(\S.*)} ;#review + lappend searchregexes {(.*\s+|^)(@*goto\s+%=.*=%\s*:)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*goto\s+%=.*=%\s+)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*goto\s+)(\S.*)} + + lappend searchregexes {(.*\s+|^)(@*GOTO\s+%=.*=%\s*:)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*GOTO\s+%=.*=%\s+)(\S.*)} + lappend searchregexes {(.*\s+|^)(@*GOTO\s+)(\S.*)} + #review + #todo - better callsite analysis. There can be data between @GOTO or @CALL and : other than just whitespace + #e.g for @goto %= possible comment=% :mylabe%%l etc + for {set callingline_index 0} {$callingline_index < $line_count} {incr callingline_index} { set callingline_info [$objFile lineinfo $callingline_index] set callingline_payload [dict get $callingline_info payload] @@ -273,18 +291,15 @@ namespace eval punk::mix::commandset::scriptwrap { } default { - #todo - better callsite analysis. There can be data between @GOTO or @CALL and : other than just whitespace! - #todo - allow analysis of colon-less call. May need to check list of internal commands - but what about external ones? - #foreach search_regex [list {(.*\s+|^)(@*call\s*:*)(\S.*)} {(.*\s+|^)(@*CALL\s*:*)(\S.*)} {(.*\s+|^)(@*goto\s*:*)(\S.*)} {(.*\s+|^)(@*GOTO\s*:*)(\S.*)}] {} - foreach search_regex [list {(.*\s+|^)(@*call\s*:)(\S.*)} {(.*\s+|^)(@*CALL\s*:)(\S.*)} {(.*\s+|^)(@*goto\s*:)(\S.*)} {(.*\s*|.*\s+|^)(@*GOTO\s*:)(\S.*)} {(.*\|\|.*)(@*GOTO\s*:)(\S.*)}] { + foreach search_regex $searchregexes { if {[regexp $search_regex $callingline_payload _m precall call labelplus]} { #todo further checks to see if it's actually a batch script line # - - - - work out what cmd.exe considers start of 512B boundaries when scanning from a callsite #callposn affected by newlines? #set callposn [expr {$file_offset + [string length $callingline_payload]}] ;#take callposn as end of line .. review - multiline statements? - set callposn [expr {$file_offset + $callingline_len}] - + set callposn [expr {$file_offset + $callingline_len -1}] + #Note there are anomalies around target labels in bracketed sections such as IF blocks #this is bad practice - as it can lead to unbalanced braces - but batch files can still work under cmd.exe with them in some cases #e.g unbalanced trailing bracket may be ignored. @@ -1741,7 +1756,7 @@ namespace eval punk::mix::commandset::scriptwrap { #note that: #@REM ----- #@goto ^ - #:label + #:label #@REM----- # is a valid callsite - but doesn't appear to be found by the label scanner as it's own target label even though :label is on it's own line from non-batch perspective # so the caller will have to do some batch-style line processing to find all call sites diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 97969463..43311b9e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -4206,7 +4206,7 @@ tcl::namespace::eval textblock { } #examples ptable.com - set elements [list\ + set elements_layout [list\ 1 H "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" He\ 2 Li Be "" "" "" "" "" "" "" "" "" "" B C N O F Ne\ 3 Na Mg "" "" "" "" "" "" "" "" "" "" Al Si P S Cl Ar\ @@ -4218,6 +4218,76 @@ tcl::namespace::eval textblock { "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ ] + #generate list of elements ordered by atomic number from the layout table (0 based - so atomic number is +1) + #create a lookup dict from symbol to atomic number at same time + set elements [list] + set e_atomic [dict create] + set e_group [dict create] + set e_period [dict create] + set atomic 0 ;#first, H, will be 1 + set period 0 + set group 0 + foreach e $elements_layout { + if {[string trim $e] eq ""} { + switch -- $period { + 6a { + set period "6c" + set atomic 71 ;#next is Hf=72 + } + 7a { + set period "7c" + set atomic 103 ;#next is Rf=104 + } + } + if {$group == 18} { + #handle rows of blanks + set group 0 + } else { + incr group + } + continue + } + if {[string is digit -strict $e]} { + if {$period in {0 1 2 3 4}} { + set period $e + } else { + switch -- $period { + 5 { + set period 6a + } + 6c { + set period 7a + } + 6b { + set period 7b + set atomic 88 ;#next is Ac=89 + } + 7c { + set period 6b + set atomic 56 ;#next is La=57 + } + } + } + incr group + continue + } + + incr atomic + lappend elements $e + dict set e_atomic $e $atomic + dict set e_group $e $group + dict set e_period $e [string index $period 0] + if {$group == 18} { + set group 0 ;#false group 0 for first column of period numbers + } else { + incr group + } + } + #test no screwup above + if {[dict get $e_atomic Og] ne "118" || [dict get $e_atomic Lr] ne "103"} { + error "textblock::periodic programming error Og->[dict get $e_atomic Og] Lr->[dict get $e_atomic Lr] should be Og->118 Lr->103" + } + set type_colours [list] @@ -4297,20 +4367,35 @@ tcl::namespace::eval textblock { tcl::dict::set ecat $e $val } - set elements1 [list] + set elements_layout_coloured [list] set RST [a+] - foreach e $elements { - if {[tcl::dict::exists $ecat $e]} { - set ansi [tcl::dict::get $ecat $e ansi] - #lappend elements1 [textblock::pad $ansi$e -width 2 -which right] - #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway - lappend elements1 $ansi$e - } else { - lappend elements1 $e + if {[tcl::dict::get $opts -compact]} { + foreach e $elements_layout { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #lappend elements_layout_coloured [textblock::pad $ansi$e -width 2 -which right] + #no need to pad here - table column_configure -textalign default of left will do the work of padding right anyway + lappend elements_layout_coloured $ansi$e + } else { + lappend elements_layout_coloured $e + } + } + } else { + foreach e $elements_layout { + if {[tcl::dict::exists $ecat $e]} { + set ansi [tcl::dict::get $ecat $e ansi] + #the atomic number should be a superscript as is the norm + #use subscript on line above + set a [punk::char::lib::subscript_number [tcl::dict::get $e_atomic $e]] + lappend elements_layout_coloured "$ansi$a\n $e " + } else { + lappend elements_layout_coloured $e + } } + } - set t [list_as_table -columns 19 -return tableobject $elements1] + set t [list_as_table -columns 19 -return tableobject $elements_layout_coloured] #(defaults to show_hseps 0) #todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options diff --git a/src/bootsupport/modules/uuid-1.0.8.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.9.tm similarity index 98% rename from src/bootsupport/modules/uuid-1.0.8.tm rename to src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.9.tm index c5cffa67..dd6d3cd5 100644 --- a/src/bootsupport/modules/uuid-1.0.8.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/uuid-1.0.9.tm @@ -47,8 +47,7 @@ proc ::uuid::generate_tcl_machinfo {} { # If we have /dev/urandom just stream 128 bits from that ### if {[file exists /dev/urandom]} { - set fin [open /dev/urandom r] - fconfigure $fin -encoding binary + set fin [open /dev/urandom rb] binary scan [read $fin 128] H* machinfo close $fin } elseif {[catch {package require nettool}]} { @@ -237,7 +236,7 @@ namespace eval ::uuid { unset e } -package provide uuid 1.0.8 +package provide uuid 1.0.9 # ------------------------------------------------------------------------- # Local variables: diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.12.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.12.tm index 1983211c4274a86b312dfaeee4ea996e1b9ac7e1..99a566c7b8c867e67a04e4b22e3ace38a2be6d18 100644 GIT binary patch delta 217 zcmez5^TTJu6-faO4hHL$GST~t)8iL&GB9Lrej=I9S#Qhy&u#OAS5u|;NH{y~R{Vd{ zx$PF8ll7F_%Z0So25x;>QTu1|;?t)88Fp0q3M*HaMwF*(p7Ykdo~Tzn@7&z%TQ^E$ zw~9K*&Ef8kda9*jA$q}Rn*EwJU82+a=5Af#k$N=lNkctzfHyOX2m=Gq1vVweb(XJc zUwV#_fgy*Pfq_|(fo-ytniAXp|4a-FjGNypUuVQ{>Evsw4vZX=#nluTA5XSWGhzG2 H%>V=dQ<709 delta 220 zcmez2^T}t!6-f~W4u*-!1yP%mB{$FGWMGh$WnfU6{7zMMGq02#XT3Gkx%GEEj=m5O z;{E9_YSdAdb=&b)oZ+G)D{i^$w%c@4@S#;L!-PG2or!y_M0S7Xe;zsQwZU{-|AXh| z=Iq(&cY{lT|J+-*wMC+nCUIp*o|bnGJIdvK{G5Bpl1)kakG|ax@MdNaVPF6{!lvZ7 z&hl05OV2SfFyt^ZFeoyxGAK`WQd404{~su{`K$7EMgerkPQIh+z{oIJR!xEN-efy9 L6SfcBK*JaSk%ds4 diff --git a/src/vendormodules/modpod-0.1.2.tm b/src/vendormodules/modpod-0.1.2.tm deleted file mode 100644 index aa27ebce..00000000 --- a/src/vendormodules/modpod-0.1.2.tm +++ /dev/null @@ -1,702 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) 2024 -# -# @@ Meta Begin -# Application modpod 0.1.2 -# Meta platform tcl -# Meta license -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin modpod_module_modpod 0 0.1.2] -#[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] -#[require modpod] -#[keywords module] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of modpod -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by modpod -#[list_begin itemized] - -package require Tcl 8.6- -package require struct::set ;#review -package require punk::lib -package require punk::args -#*** !doctools -#[item] [package {Tcl 8.6-}] - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section API] - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::class { - #*** !doctools - #[subsection {Namespace modpod::class}] - #[para] class definitions - if {[info commands [namespace current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Base namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod { - namespace export {[a-z]*}; # Convention: export all lowercase - - variable connected - if {![info exists connected(to)]} { - set connected(to) list - } - variable modpodscript - set modpodscript [info script] - if {[string tolower [file extension $modpodscript]] eq ".tcl"} { - set connected(self) [file dirname $modpodscript] - } else { - #expecting a .tm - set connected(self) $modpodscript - } - variable loadables [info sharedlibextension] - variable sourceables {.tcl .tk} ;# .tm ? - - #*** !doctools - #[subsection {Namespace modpod}] - #[para] Core API functions for modpod - #[list_begin definitions] - - - - #proc sample1 {p1 args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" - #} - - #old tar connect mechanism - review - not needed? - proc connect {args} { - puts stderr "modpod::connect--->>$args" - set argd [punk::args::get_dict { - @id -id ::modpod::connect - -type -default "" - @values -min 1 -max 1 - path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" - } $args] - catch { - punk::lib::showdict $argd ;#heavy dependencies - } - set opt_path [dict get $argd values path] - variable connected - set original_connectpath $opt_path - set modpodpath [modpod::system::normalize $opt_path] ;# - - if {$modpodpath in $connected(to)} { - return [dict create ok ALREADY_CONNECTED] - } - lappend connected(to) $modpodpath - - set connected(connectpath,$opt_path) $original_connectpath - set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] - - set connected(location,$modpodpath) [file dirname $modpodpath] - set connected(startdata,$modpodpath) -1 - set connected(type,$modpodpath) [dict get $argd opts -type] - set connected(fh,$modpodpath) "" - - if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { - set connected(type,$modpodpath) "unwrapped" - lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] - - } else { - #connect to .tm but may still be unwrapped version available - lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) - set this_pkg_tm_folder [file dirname $modpodpath] - if {$connected(type,$modpodpath) ne "unwrapped"} { - #Not directly connected to unwrapped version - but may still be redirected there - set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] - if {[file exists $unwrappedFolder]} { - #folder with exact version-match must exist for redirect to 'unwrapped' - set con(type,$modpodpath) "modpod-redirecting" - } - } - - } - set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" - set connected(tmfile,$modpodpath) - set tail_segments [list] - set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] - break - } - } - if {[llength $tail_segments]} { - set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require - } else { - set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] - } - - switch -exact -- $connected(type,$modpodpath) { - "modpod-redirecting" { - #redirect to the unwrapped version - set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] - - } - "unwrapped" { - if {[info commands ::thread::id] ne ""} { - set from [pid],[thread::id] - } else { - set from [pid] - } - #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" - return [list ok ""] - } - default { - #autodetect .tm - zip/tar ? - #todo - use vfs ? - - #connect to tarball - start at 1st header - set connected(startdata,$modpodpath) 0 - set fh [open $modpodpath r] - set connected(fh,$modpodpath) $fh - fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} - - if {$connected(startdata,$modpodpath) >= 0} { - #verify we have a valid tar header - if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { - seek $fh $connected(startdata,$modpodpath) start - return [list ok $fh] - } else { - #error "cannot verify tar header" - } - } - lpop connected(to) end - set connected(startdata,$modpodpath) -1 - unset connected(fh,$modpodpath) - catch {close $fh} - return [dict create err {Does not appear to be a valid modpod}] - } - } - } - proc disconnect {{modpod ""}} { - variable connected - if {![llength $connected(to)]} { - return 0 - } - if {$modpod eq ""} { - puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" - set modpod [lindex $connected(to) end] - } - - if {[set posn [lsearch $connected(to) $modpod]] == -1} { - puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" - return 0 - } - if {[string length $connected(fh,$modpod)]} { - close $connected(fh,$modpod) - } - array unset connected *,$modpod - set connected(to) [lreplace $connected(to) $posn $posn] - return 1 - } - proc get {args} { - set argd [punk::args::get_dict { - -from -default "" -help "path to pod" - *values -min 1 -max 1 - filename - } $args] - set frompod [dict get $argd opts -from] - set filename [dict get $argd values filename] - - variable connected - #//review - set modpod [::modpod::system::connect_if_not $frompod] - set fh $connected(fh,$modpod) - if {$connected(type,$modpod) eq "unwrapped"} { - #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder - if {[string range $filename 0 0 eq "/"]} { - #absolute path (?) - set path [file join $connected(location,$modpod) .. [string trim $filename /]] - } else { - #relative path - use #modpod-xxx as base - set path [file join $connected(location,$modpod) $filename] - } - set fd [open $path r] - #utf-8? - #fconfigure $fd -encoding iso8859-1 -translation binary - return [list ok [lindex [list [read $fd] [close $fd]] 0]] - } else { - #read from vfs - puts stderr "get $filename from wrapped pod '$frompod' not implemented" - } - } - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -namespace eval modpod::lib { - namespace export {[a-z]*}; # Convention: export all lowercase - namespace path [namespace parent] - #*** !doctools - #[subsection {Namespace modpod::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 - #} - - proc is_valid_tm_version {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionparts $versionparts]]} { - return 1 - } else { - return 0 - } - } - - #zipfile is a pure zip at this point - ie no script/exe header - proc make_zip_modpod {args} { - set argd [punk::args::get_dict { - @id -id ::modpod::lib::make_zip_modpod - -offsettype -default "archive" -choices {archive file} -help\ - "Whether zip offsets are relative to start of file or start of zip-data within the file. - 'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, - but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) - info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. - -offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" - @values -min 2 -max 2 - zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" - outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" - } $args] - set zipfile [dict get $argd values zipfile] - set outfile [dict get $argd values outfile] - set opt_offsettype [dict get $argd opts -offsettype] - - - set mount_stub [string map [list %offsettype% $opt_offsettype] { - #zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. - #Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. - #generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% - if {[catch {file normalize [info script]} modfile]} { - error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" - } - if {$modfile eq "" || ![file exists $modfile]} { - error "modpod zip stub error. Unable to determine module path" - } - set moddir [file dirname $modfile] - set mod_and_ver [file rootname [file tail $modfile]] - lassign [split $mod_and_ver -] moduletail version - if {[file exists $moddir/#modpod-$mod_and_ver]} { - source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #determine module namespace so we can mount appropriately - proc intersect {A B} { - if {[llength $A] == 0} {return {}} - if {[llength $B] == 0} {return {}} - if {[llength $B] > [llength $A]} { - set res $A - set A $B - set B $res - } - set res {} - foreach x $A {set ($x) {}} - foreach x $B { - if {[info exists ($x)]} { - lappend res $x - } - } - return $res - } - set lcase_tmfile_segments [string tolower [file split $moddir]] - set lcase_modulepaths [string tolower [tcl::tm::list]] - foreach lc_mpath $lcase_modulepaths { - set mpath_segments [file split $lc_mpath] - if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { - set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail - break - } - } - if {[llength $tail_segments]} { - set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require - set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver - } else { - set fullpackage $moduletail - set mount_at #modpod/#mounted-modpod-$mod_and_ver - } - - if {[info commands tcl::zipfs::mount] ne ""} { - #argument order changed to be consistent with vfs::zip::Mount etc - #early versions: zipfs::Mount mountpoint zipname - #since 2023-09: zipfs::Mount zipname mountpoint - #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) - #This is presumably related to // being interpreted as a network path - set mountpoints [dict keys [tcl::zipfs::mount]] - if {"//zipfs:/$mount_at" ni $mountpoints} { - #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it - if {[catch { - #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) - #puts "tcl::zipfs::mount $modfile $mount_at" - tcl::zipfs::mount $modfile $mount_at - } errM]} { - #try old api - if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { - puts stderr "modpod stub>>> tcl::zipfs::mount failed.\nbut old api: tcl::zipfs::mount succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" - puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" - } - } - if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" - #tcl::zipfs::unmount //zipfs:/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form - source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } else { - #fallback to slower vfs::zip - #NB. We don't create the intermediate dirs - but the mount still works - if {![file exists $moddir/$mount_at]} { - if {[catch {package require vfs::zip} errM]} { - set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" - append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." - append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" - error $msg - } else { - set fd [vfs::zip::Mount $modfile $moddir/$mount_at] - if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { - vfs::zip::Unmount $fd $moddir/$mount_at - error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" - } - } - } - source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm - } - } - #zipped data follows - }] - #todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? - append mount_stub \x1A - modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype - - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace modpod::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -namespace eval modpod::system { - #*** !doctools - #[subsection {Namespace modpod::system}] - #[para] Internal functions that are not part of the API - - #deflate,store only supported - - #zipfile here is plain zip - no script/exe prefix part. - proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { - set inzip [open $zipfile r] - fconfigure $inzip -encoding iso8859-1 -translation binary - set out [open $outfile w+] - fconfigure $out -encoding iso8859-1 -translation binary - puts -nonewline $out $mount_stub - set stuboffset [tell $out] - lappend report "stub size: $stuboffset" - fcopy $inzip $out - close $inzip - - set size [tell $out] - lappend report "tmfile : [file tail $outfile]" - lappend report "output size : $size" - lappend report "offsettype : $offsettype" - - if {$offsettype eq "file"} { - #make zip offsets relative to start of whole file including prepended script. - #same offset structure as Tcl's 'zipfs mkimg' as at 2024-10 - #not editable by 7z,nanazip,peazip - - #we aren't adding any new files/folders so we can edit the offsets in place - - #Now seek in $out to find the end of directory signature: - #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text - if {$size < 65559} { - set tailsearch_start 0 - } else { - set tailsearch_start [expr {$size - 65559}] - } - seek $out $tailsearch_start - set data [read $out] - #EOCD - End of Central Directory record - #PK\5\6 - set start_of_end [string last "\x50\x4b\x05\x06" $data] - #set start_of_end [expr {$start_of_end + $seek}] - #incr start_of_end $seek - set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] - - lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" - - seek $out $filerelative_eocd_posn - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - lappend report "End of central directory: [array get eocd]" - seek $out [expr {$filerelative_eocd_posn+16}] - - #adjust offset of start of central directory by the length of our sfx stub - puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] - flush $out - - seek $out $filerelative_eocd_posn - set end_of_ctrl_dir [read $out] - binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ - eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) - - # 0x06054b50 - end of central dir signature - puts stderr "$end_of_ctrl_dir" - puts stderr "comment_len: $eocd(comment_len)" - puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" - lappend report "New dir offset: $eocd(diroffset)" - lappend report "Adjusting $eocd(totalnum) zip file items." - catch { - punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies - } - - seek $out $eocd(diroffset) - for {set i 0} {$i <$eocd(totalnum)} {incr i} { - set current_file [tell $out] - set fileheader [read $out 46] - puts -------------- - puts [ansistring VIEW -lf 1 $fileheader] - puts -------------- - #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - - binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - set ::last_header $fileheader - - puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" - puts "ver: $x(version)" - puts "method: $x(method)" - - #PK\1\2 - #33639248 dec = 0x02014b50 - central directory file header signature - if { $x(sig) != 33639248 } { - error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" - } - - foreach size $x(lengths) var {filename extrafield comment} { - if { $size > 0 } { - set x($var) [read $out $size] - } else { - set x($var) "" - } - } - set next_file [tell $out] - lappend report "file $i: $x(offset) $x(sizes) $x(filename)" - - seek $out [expr {$current_file+42}] - puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] - - #verify: - flush $out - seek $out $current_file - set fileheader [read $out 46] - lappend report "old $x(offset) + $stuboffset" - binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ - x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) - lappend report "new $x(offset)" - - seek $out $next_file - } - } - - close $out - #pdict/showdict reuire punk & textlib - ie lots of dependencies - #don't fall over just because of that - catch { - punk::lib::showdict -roottype list -chan stderr $report - } - #puts [join $report \n] - return - } - - proc connect_if_not {{podpath ""}} { - upvar ::modpod::connected connected - set podpath [::modpod::system::normalize $podpath] - set docon 0 - if {![llength $connected(to)]} { - if {![string length $podpath]} { - error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" - } else { - set docon 1 - } - } else { - if {![string length $podpath]} { - set podpath [lindex $connected(to) end] - puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" - } else { - if {$podpath ni $connected(to)} { - set docon 1 - } - } - } - if {$docon} { - if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { - error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" - } else { - return $podpath - } - } - #we were already connected - return $podpath - } - - proc myversion {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" - } - set fname [file tail [file rootname [file normalize $script]]] - set scriptdir [file dirname $script] - - if {![string match "#modpod-*" $fname]} { - lassign [lrange [split $fname -] end-1 end] _pkgname version - } else { - lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version - if {![string length $version]} { - #try again on the name of the containing folder - lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version - #todo - proper walk up the directory tree - if {![string length $version]} { - #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) - lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version - } - } - } - - #tarjar::Log debug "'myversion' determined version for [info script]: $version" - return $version - } - - proc myname {} { - upvar ::modpod::connected connected - set script [info script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" - } - return $connected(fullpackage,$script) - } - proc myfullname {} { - upvar ::modpod::connected connected - set script [info script] - #set script [::tarjar::normalize $script] - set script [file normalize $script] - if {![string length $script]} { - error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" - } - return $::tarjar::connected(fullpackage,$script) - } - proc normalize {path} { - #newer versions of Tcl don't do tilde sub - - #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) - # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. - set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. - set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after - set path [file normalize $path] - #set path [string tolower $path] ;#must do this after file normalize - return [string map [list $matilda ~] $path] ;#get our tildes back. -} -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide modpod [namespace eval modpod { - variable pkg modpod - variable version - set version 0.1.2 -}] -return - -#*** !doctools -#[manpage_end] - diff --git a/src/vendormodules/overtype-1.6.5.tm b/src/vendormodules/overtype-1.6.5.tm deleted file mode 100644 index 9363fb6d..00000000 --- a/src/vendormodules/overtype-1.6.5.tm +++ /dev/null @@ -1,4773 +0,0 @@ -# -*- tcl -*- -# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt -# -# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. -# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# (C) Julian Noble 2003-2023 -# -# @@ Meta Begin -# Application overtype 1.6.5 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.5] -#[copyright "2024"] -#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] -#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] -#[require overtype] -#[keywords module text ansi] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of overtype -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by overtype -#[list_begin itemized] - -package require Tcl 8.6- -package require textutil -package require punk::lib ;#required for lines_as_list -package require punk::ansi ;#required to detect, split, strip and calculate lengths -package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars -package require punk::assertion -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package textutil] -#[item] [package punk::ansi] -#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes -#[item] [package punk::char] -#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - -#PERFORMANCE notes -#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised -#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps -#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. -#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code -#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... -#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes -#generally using 'list' is preferred for the map as less error prone. -#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section API] - - -#Julian Noble - 2003 -#Released under standard 'BSD license' conditions. -# -#todo - ellipsis truncation indicator for center,right - -#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range -# - need to extract and replace ansi codes? - -tcl::namespace::eval overtype { - namespace import ::punk::assertion::assert - punk::assertion::active true - - namespace path ::punk::lib - - namespace export * - variable default_ellipsis_horizontal "..." ;#fallback - variable default_ellipsis_vertical "..." - tcl::namespace::eval priv { - proc _init {} { - upvar ::overtype::default_ellipsis_horizontal e_h - upvar ::overtype::default_ellipsis_vertical e_v - set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis - set e_v [format %c 0x22EE] - #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text - #Also - unicode ellipsis has semantic meaning that other processors can interpret - #unicode does also provide a midline horizontal ellipsis 0x22EF - - #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal - #if {![catch {package require punk::char}]} { - # set e [punk::char::charshort boxd_ltdshhz] - #} - } - } - priv::_init -} -proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" -} - -tcl::namespace::eval overtype { - variable grapheme_widths [tcl::dict::create] - - variable escape_terminals - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - - #self-contained 2 byte ansi escape sequences - review more? - variable ansi_2byte_codes_dict - set ansi_2byte_codes_dict [tcl::dict::create\ - "reset_terminal" "\u001bc"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - "NEL - Next Line" "\u001bE"\ - "IND - Down one line" "\u001bD"\ - "HTS - Set Tab Stop" "\u001bH"\ - ] - - #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. - # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ -} - - - - -proc overtype::string_columns {text} { - if {[punk::ansi::ta::detect $text]} { - #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::ansistrip $text] - } - return [punk::char::ansifreestring_width $text] -} - -#todo - consider a way to merge overtype::left/centre/right -#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock -#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. -#(i.e not even necessariy having it's top left within the underlay) -tcl::namespace::eval overtype::priv { -} - -#could return larger than renderwidth -proc _get_row_append_column {row} { - #obsolete? - upvar outputlines outputlines - set idx [expr {$row -1}] - if {$row <= 1 || $row > [llength $outputlines]} { - return 1 - } else { - upvar opt_expand_right expand_right - upvar renderwidth renderwidth - set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] - set endpos [expr {$existinglen +1}] - if {$expand_right} { - return $endpos - } else { - if {$endpos > $renderwidth} { - return $renderwidth + 1 - } else { - return $endpos - } - } - } -} - -tcl::namespace::eval overtype { - #*** !doctools - #[subsection {Namespace overtype}] - #[para] Core API functions for overtype - #[list_begin definitions] - - - - #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r - #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. - #The underlay and overlay can be multiline blocks of text of varying line lengths. - #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. - #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. - # a cursor start position other than top-left is a possible addition to consider. - #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline - proc renderspace {args} { - #*** !doctools - #[call [fun overtype::renderspace] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext - - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - variable default_ellipsis_horizontal - - if {[llength $args] < 2} { - error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - set optargs [lrange $args 0 end-2] - if {[llength $optargs] % 2 == 0} { - set overblock [lindex $args end] - set underblock [lindex $args end-1] - #lassign [lrange $args end-1 end] underblock overblock - set argsflags [lrange $args 0 end-2] - } else { - set optargs [lrange $args 0 end-1] - if {[llength $optargs] %2 == 0} { - set overblock [lindex $args end] - set underblock "" - set argsflags [lrange $args 0 end-1] - } else { - error "renderspace expects opt-val pairs followed by: or just " - } - } - set opts [tcl::dict::create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -startcolumn 1\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -expand_right 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -cp437 0\ - -looplimit \uFFEF\ - -crm_mode 0\ - -reverse_mode 0\ - -insert_mode 0\ - -wrap 0\ - -info 0\ - -console {stdin stdout stderr}\ - ] - #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. - # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) - # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. - # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. - # - further implication is that if expand_right grows the virtual renderspace terminal width - - # then some sort of reflow/rerender needs to be done for preceeding lines? - # possibly not - as expand_right is distinct from a normal terminal-width change event, - # expand_right being primarily to support other operations such as textblock::table - - #todo - viewport width/height as separate concept to terminal width/height? - #-ellipsis args not used if -wrap is true - foreach {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - - -transparent - -exposed1 - -exposed2 - -experimental - - -expand_right - -appendlines - - -reverse_mode - -crm_mode - -insert_mode - - -cp437 - - -info - -console { - tcl::dict::set opts $k $v - } - -wrap - -autowrap_mode { - #temp alias -autowrap_mode for consistency with renderline - #todo - - tcl::dict::set opts -wrap $v - } - default { - error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - #review - expand_left for RTL text? - set opt_expand_right [tcl::dict::get $opts -expand_right] - #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. - set opt_width [tcl::dict::get $opts -width] - set opt_height [tcl::dict::get $opts -height] - set opt_startcolumn [tcl::dict::get $opts -startcolumn] - set opt_appendlines [tcl::dict::get $opts -appendlines] - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo - set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo - # -- --- --- --- --- --- - set opt_crm_mode [tcl::dict::get $opts -crm_mode] - set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] - set opt_insert_mode [tcl::dict::get $opts -insert_mode] - ##### - # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_autowrap_mode [tcl::dict::get $opts -wrap] - #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) - ##### - # -- --- --- --- --- --- - set opt_cp437 [tcl::dict::get $opts -cp437] - set opt_info [tcl::dict::get $opts -info] - - - - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set edit_mode 0 - set opt_experimental [tcl::dict::get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - data_mode { - set data_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - - #set underlines [split $underblock \n] - - #underblock is a 'rendered' block - so width height make sense - #only non-cursor affecting and non-width occupying ANSI codes should be present. - #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already - #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - - if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { - lassign [blocksize $underblock] _w renderwidth _h renderheight - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } - if {$opt_height ne "\uFFEF"} { - set renderheight $opt_height - } - } else { - set renderwidth $opt_width - set renderheight $opt_height - } - #initial state for renderspace 'terminal' reset - set initial_state [dict create\ - renderwidth $renderwidth\ - renderheight $renderheight\ - crm_mode $opt_crm_mode\ - reverse_mode $opt_reverse_mode\ - insert_mode $opt_insert_mode\ - autowrap_mode $opt_autowrap_mode\ - cp437 $opt_cp437\ - ] - #modes - #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l - #opt_startcolumn ?? - DECSLRM ? - set vtstate $initial_state - - # -- --- --- --- - #REVIEW - do we need ansi resets in the underblock? - if {$underblock eq ""} { - set underlines [lrepeat $renderheight ""] - } else { - set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays - set underlines [split $underblock \n] - } - #if {$underblock eq ""} { - # set blank "\x1b\[0m\x1b\[0m" - # #set underlines [list "\x1b\[0m\x1b\[0m"] - # set underlines [lrepeat $renderheight $blank] - #} else { - # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW - # set underlines [lines_as_list -ansiresets 1 $underblock] - #} - # -- --- --- --- - - #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth - #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. - #(in cases where there are interline moves or cursor jumps anyway) - #This works - but doesn't seem efficient. - #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first - - #a hack until we work out how to avoid infinite loops... - # - set looplimit [tcl::dict::get $opts -looplimit] - if {$looplimit eq "\uFFEF"} { - #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? - #do we need any margin above the length? (telnet mapscii.me test) - set looplimit [expr {[tcl::string::length $overblock] + 10}] - } - - #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 scheme 4 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list $overblock] - } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln - } - if {[llength $lflines]} { - lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] - } - #set inputchunks $lflines[unset lflines] - set inputchunks [lindex [list $lflines [unset lflines]] 0] - - } - 4 { - set inputchunks [list] - foreach ln [split $overblock \n] { - lappend inputchunks $ln\n - } - if {[llength $inputchunks]} { - lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] - } - } - } - - - - - set replay_codes_underlay [tcl::dict::create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "[punk::ansi::a]" - set unapplied "" - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - - - set outputlines $underlines - set overidx 0 - - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - #if {$data_mode} { - # set col [_get_row_append_column $row] - #} else { - set col $opt_startcolumn - #} - - set instruction_stats [tcl::dict::create] - - set loop 0 - #while {$overidx < [llength $inputchunks]} { } - - while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![tcl::string::length $overtext]} { - incr loop - continue - } - #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] - set renderedrow $row - - #renderline pads each underaly line to width with spaces and should track where end of data is - - - #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext $replay_codes_overlay$overtext - if {[tcl::dict::exists $replay_codes_underlay $row]} { - set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext - } - #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set renderopts [list -experimental $opt_experimental\ - -cp437 $opt_cp437\ - -info 1\ - -crm_mode [tcl::dict::get $vtstate crm_mode]\ - -insert_mode [tcl::dict::get $vtstate insert_mode]\ - -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ - -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ - -cursor_restore_attributes $cursor_saved_attributes\ - -transparent $opt_transparent\ - -width [tcl::dict::get $vtstate renderwidth]\ - -exposed1 $opt_exposed1\ - -exposed2 $opt_exposed2\ - -expand_right $opt_expand_right\ - -cursor_column $col\ - -cursor_row $row\ - ] - set rinfo [renderline {*}$renderopts $undertext $overtext] - - set instruction [tcl::dict::get $rinfo instruction] - tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] - tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] - tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# - tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] - #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext - - #Note carefully the difference betw overflow_right and unapplied. - #overflow_right may need to be included in next run before the unapplied data - #overflow_right most commonly has data when in insert_mode - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] - set unapplied [tcl::dict::get $rinfo unapplied] - set unapplied_list [tcl::dict::get $rinfo unapplied_list] - set post_render_col [tcl::dict::get $rinfo cursor_column] - set post_render_row [tcl::dict::get $rinfo cursor_row] - set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] - set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] - set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line - set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] - set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] - tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] - - #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - if {0 && [tcl::dict::get $vtstate reverse_mode]} { - #test branch - todo - prune - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - #review - #JMN3 - set existing_reverse_state 0 - #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence - #e.g \x1b\[0;31;7m has a reset,colour red and reverse - set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" - } - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::renderspace loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[tcl::dict::size $c_saved_pos] >= 1} { - set cursor_saved_position $c_saved_pos - set cursor_saved_attributes $c_saved_attributes - } - - - set overflow_handled 0 - - - - set nextprefix "" - - - #todo - handle potential insertion mode as above for cursor restore? - #keeping separate branches for debugging - review and merge as appropriate when stable - set instruction_type [lindex $instruction 0] ;#some instructions have params - tcl::dict::incr instruction_stats $instruction_type - switch -- $instruction_type { - reset { - #reset the 'renderspace terminal' (not underlying terminal) - set row 1 - set col 1 - set vtstate [tcl::dict::merge $vtstate $initial_state] - #todo - clear screen - } - {} { - #end of supplied line input - #lf included in data - set row $post_render_row - set col $post_render_col - if {![llength $unapplied_list]} { - if {$overflow_right ne ""} { - incr row - } - } else { - puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" - } - set col $opt_startcolumn - } - up { - - #renderline knows it's own line number, and knows not to go above row l - #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. - #row returned should be correct. - #column may be the overflow column - as it likes to report that to the caller. - - #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. - #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review - #puts stderr "up $post_render_row" - #puts stderr "$rinfo" - - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout - } - down { - if {$data_mode == 0} { - #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[tcl::dict::exists $cursor_saved_position row]} { - set row [tcl::dict::get $cursor_saved_position row] - set col [tcl::dict::get $cursor_saved_position column] - #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" - #set nextprefix $cursor_saved_attributes - #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [tcl::dict::create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::renderspace cursor_restore without save data available" - } - #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it - #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. - if {!$overflow_handled && $overflow_right ne ""} { - #wrap before restore? - possible effect on saved cursor position - #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc - #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call - #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks - - puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - - set sub_info [overtype::renderline\ - -info 1\ - -width [tcl::dict::get $vtstate renderwidth]\ - -insert_mode [tcl::dict::get $vtstate insert_mode]\ - -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ - -expand_right [tcl::dict::get $opts -expand_right]\ - ""\ - $overflow_right\ - ] - set foldline [tcl::dict::get $sub_info result] - tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? - tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. - linsert outputlines $renderedrow $foldline - #review - row & col set by restore - but not if there was no save.. - } - set overflow_handled 1 - - } - move { - ######## - if {$post_render_row > [llength $outputlines]} { - #Ansi moves need to create new lines ? - #if {$opt_appendlines} { - # set diff [expr {$post_render_row - [llength $outputlines]}] - # if {$diff > 0} { - # lappend outputlines {*}[lrepeat $diff ""] - # } - # set row $post_render_row - #} else { - set row [llength $outputlines] - #} - } else { - set row $post_render_row - } - ####### - set col $post_render_col - #overflow + unapplied? - } - clear_and_move { - #e.g 2J - if {$post_render_row > [llength $outputlines]} { - set row [llength $outputlines] - } else { - set row $post_render_row - } - set col $post_render_col - set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant - set clearedlines [list] - foreach ln $outputlines { - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m - if 0 { - - set lineparts [punk::ansi::ta::split_codes $ln] - set numcells 0 - foreach {pt _code} $lineparts { - if {$pt ne ""} { - foreach grapheme [punk::char::grapheme_split $pt] { - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - incr numcells 1 - } - default { - if {$grapheme eq "\u0000"} { - incr numcells 1 - } else { - incr numcells [grapheme_width_cached $grapheme] - } - } - } - - } - } - } - #replays/resets each line - lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m - } - } - set outputlines $clearedlines - #todo - determine background/default to be in effect - DECECM ? - puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" - #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] - - } - lf_start { - #raw newlines - # ---------------------- - #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 $opt_startcolumn - # ---------------------- - } - lf_mid { - - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" - set row $post_render_row - #set col $post_render_col - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - if 1 { - if {$overflow_right ne ""} { - if {$opt_expand_right} { - append rendered $overflow_right - set overflow_right "" - } else { - #review - we should really make renderline do the work...? - set overflow_width [punk::ansi::printing_length $overflow_right] - if {$visualwidth + $overflow_width <= $renderwidth} { - append rendered $overflow_right - set overflow_right "" - } else { - if {[tcl::dict::get $vtstate autowrap_mode]} { - set outputlines [linsert $outputlines $renderedrow $overflow_right] - set overflow_right "" - set row [expr {$renderedrow + 2}] - } else { - set overflow_right "" ;#abandon - } - - if {0 && $visualwidth < $renderwidth} { - puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" - error "incomplete - abandon?" - set overflowparts [punk::ansi::ta::split_codes $overflow_right] - set remaining_overflow $overflowparts - set filled 0 - foreach {pt code} $overflowparts { - lpop remaining_overflow 0 - if {$pt ne ""} { - set graphemes [punk::char::grapheme_split $pt] - set add "" - set addlen $visualwidth - foreach g $graphemes { - set w [overtype::grapheme_width_cached $g] - if {$addlen + $w <= $renderwidth} { - append add $g - incr addlen $w - } else { - set filled 1 - break - } - } - append rendered $add - } - if {!$filled} { - lpop remaining_overflow 0 ;#pop code - } - } - set overflow_right [join $remaining_overflow ""] - } - } - } - } - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - #old version - known to work with various ansi graphics - e.g fruit.ans - # - but fails to limit lines to renderwidth when expand_right == 0 - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col $opt_startcolumn - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } - } - } - lf_overflow { - #linefeed after renderwidth 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 - } - if {![tcl::dict::get $vtstate insert_mode]} { - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode - } - - 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 $opt_startcolumn - - } - newlines_above { - #we get a newlines_above instruction when received at column 1 - #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) - #in other cases - we want to treat at column 1 the same as any other - - puts "--->newlines_above" - puts "rinfo: $rinfo" - #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col - if {$insert_lines_above > 0} { - set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above - #? set row $post_render_row #can renderline tell us? - } - } - newlines_below { - #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - #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 $opt_startcolumn - } - } 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 < $renderwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $renderwidth - } - } - } - } - wrapmoveforward { - #doesn't seem to be used by fruit.ans testfile - #used by dzds.ans - #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $renderwidth - set r $post_render_row - if {$post_render_col > $renderwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $renderwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c $opt_startcolumn - } else { - incr c - } - incr i - } - set col $c - } else { - #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" - set r [expr {$post_render_row +1}] - set c $post_render_col - } - set row $r - set col $c - } - wrapmovebackward { - set c $renderwidth - 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 $renderwidth - } else { - #leave r at 1 set c 1 - #testfile besthpav.ans first line top left border alignment - set c 1 - break - } - } else { - incr c -1 - } - incr i -1 - } - set col $c - } else { - puts stderr "Wrapmovebackward - but postrendercol >= 1???" - } - set row $r - set col $c - } - overflow { - #normal single-width grapheme overflow - #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" - set row $post_render_row ;#renderline will not advance row when reporting overflow char - if {[tcl::dict::get $vtstate autowrap_mode]} { - incr row - set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? - } else { - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #set unapplied [tcl::string::range $unapplied 1 end] - #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs - #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate - #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' - set idx 0 - set next_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set next_grapheme_index $idx - break - } - incr idx - } - assert {$next_grapheme_index >= 0} - #drop the overflow grapheme - keeping all codes in place. - set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] - #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines - - set overflow_handled 1 - #handled by dropping overflow if any - } - } - overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char - - #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts - #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc - if {[tcl::dict::get $vtstate autowrap_mode]} { - if {$renderwidth < 2} { - #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } else { - set col $opt_startcolumn - incr row - } - } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$renderwidth < 2} { - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } - } - - } - vt { - - #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col - } - set_window_title { - set newtitle [lindex $instruction 1] - puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" - # - } - reset_colour_palette { - puts stderr "overtype::renderspace instruction '$instruction' unimplemented" - } - default { - puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" - } - - } - - - if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[tcl::dict::get $opts -ellipsis]} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - set overflow_handled 1 - } else { - #no wrap - no ellipsis - silently truncate - set overflow_handled 1 - } - } - - - - if {$renderedrow <= [llength $outputlines]} { - lset outputlines [expr {$renderedrow-1}] $rendered - } else { - if {$opt_appendlines} { - lappend outputlines $rendered - } else { - #? - lset outputlines [expr {$renderedrow-1}] $rendered - } - } - - if {!$overflow_handled} { - append nextprefix $overflow_right - } - - append nextprefix $unapplied - - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - } - } - } - - if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] - } - - - incr overidx - incr loop - if {$loop >= $looplimit} { - puts stderr "overtype::renderspace looplimit reached ($looplimit)" - lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" - set Y [a+ yellow bold] - set RST [a] - set sep_header ----DEBUG----- - set debugmsg "" - append debugmsg "${Y}${sep_header}${RST}" \n - append debugmsg "looplimit $looplimit reached\n" - append debugmsg "data_mode:$data_mode\n" - append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" - append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" - tcl::dict::for {k v} $rinfo { - append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n - } - append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n - - puts stdout $debugmsg - #todo - config regarding error dumps rather than just dumping in working dir - set fd [open [pwd]/error_overtype.txt w] - puts $fd $debugmsg - close $fd - error $debugmsg - break - } - } - - set result [join $outputlines \n] - if {!$opt_info} { - return $result - } else { - #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? - #append result \n$instruction_stats\n - set inforesult [dict create\ - result $result\ - last_instruction $instruction\ - instruction_stats $instruction_stats\ - ] - if {$opt_info == 2} { - return [pdict -channel none inforesult] - } else { - return $inforesult - } - } - } - - #todo - left-right ellipsis ? - proc centre {args} { - variable default_ellipsis_horizontal - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - - foreach {underblock overblock} [lrange $args end-1 end] break - - #todo - vertical vs horizontal overflow for blocks - set opts [tcl::dict::create\ - -bias left\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - ] - set argsflags [lrange $args 0 end-2] - foreach {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- - - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$renderwidth - $overblock_width}] - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - set undertext "$undertext[string repeat { } $udiff]" - } - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - #review - right-to-left langs should elide on left! - extra option required - - if {$overflowlength > 0} { - #overlay line wider or equal - #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - #todo - get replay_codes from overflow_right instead of wherever it was truncated? - - #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified - if {![tcl::dict::get $opts -overflow]} { - #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] - #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - } - } - lappend outputlines $rendered - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] - } else { - #background block is wider than or equal to data for this line - #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - return [join $outputlines \n] - } - - #overtype::right is for a rendered ragged underblock and a rendered ragged overblock - #ie we can determine the block width for bost by examining the lines and picking the longest. - # - proc right {args} { - #NOT the same as align-right - which should be done to the overblock first if required - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - foreach {underblock overblock} [lrange $args end-1 end] break - - set opts [tcl::dict::create\ - -bias ignored\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -align "left"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { - tcl::dict::set opts $k $v - } - default { - set known_opts [tcl::dict::keys $opts] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - #set opts [tcl::dict::merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_align [tcl::dict::get $opts -align] - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] - set left_exposed $under_exposed_max - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_align { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline\ - -info 1\ - -insert_mode 0\ - -transparent $opt_transparent\ - -exposed1 $opt_exposed1 -exposed2 $opt_exposed2\ - -overflow $opt_overflow\ - -startcolumn [expr {1 + $startoffset}]\ - $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis $replay_codes$opt_ellipsistext - #todo - overflow on left if allign = right?? - set rendered [overtype::right $rendered $ellipsis] - } - } - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - - proc left {args} { - overtype::block -blockalign left {*}$args - } - #overtype a (possibly ragged) underblock with a (possibly ragged) overblock - proc block {args} { - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - #foreach {underblock overblock} [lrange $args end-1 end] break - lassign [lrange $args end-1 end] underblock overblock - - set opts [tcl::dict::create\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -textalign "left"\ - -textvertical "top"\ - -blockalign "left"\ - -blockalignbias left\ - -blockvertical "top"\ - ] - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { - tcl::dict::set opts $k $v - } - default { - error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- - set opt_transparent [tcl::dict::get $opts -transparent] - set opt_ellipsis [tcl::dict::get $opts -ellipsis] - set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] - set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] - set opt_overflow [tcl::dict::get $opts -overflow] - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - set opt_textalign [tcl::dict::get $opts -textalign] - set opt_blockalign [tcl::dict::get $opts -blockalign] - if {$opt_blockalign eq "center"} { - set opt_blockalign "centre" - } - # -- --- --- --- --- --- - - set underblock [tcl::string::map {\r\n \n} $underblock] - set overblock [tcl::string::map {\r\n \n} $overblock] - - set underlines [split $underblock \n] - lassign [blocksize $underblock] _w renderwidth _h renderheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] - - switch -- $opt_blockalign { - left { - set left_exposed 0 - } - right { - set left_exposed $under_exposed_max - } - centre { - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - } - default { - set left_exposed 0 - } - } - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $renderwidth} { - set udiff [expr {$renderwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_textalign { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext $replay_codes_underlay$undertext - set overtext $replay_codes_overlay$overtext - - set overflowlength [expr {$overtext_datalen - $renderwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [tcl::dict::get $rinfo replay_codes] - set rendered [tcl::dict::get $rinfo result] - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use tcl::string::range on ANSI data - #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[tcl::string::trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] - } - } - - #if {$opt_ellipsis} { - # set show_ellipsis 1 - # if {!$opt_ellipsiswhitespace} { - # #we don't want ellipsis if only whitespace was lost - # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - # if {[tcl::string::trim $lostdata] eq ""} { - # set show_ellipsis 0 - # } - # } - # if {$show_ellipsis} { - # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] - # #todo - overflow on left if allign = right?? - # set rendered [overtype::right $rendered $ellipsis] - # } - #} - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" - set overflow_right [tcl::dict::get $rinfo overflow_right] - set unapplied [tcl::dict::get $rinfo unapplied] - lappend outputlines [tcl::dict::get $rinfo result] - } - set replay_codes [tcl::dict::get $rinfo replay_codes] - set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] - set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - - variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches - - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. - # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # - # - #-returnextra enables returning of overflow and length - #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? - #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements - #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char? - # This would probably be impractical to support for different fonts) - #todo - review transparency issues with single/double width characters - #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? - proc renderline {args} { - #*** !doctools - #[call [fun overtype::renderline] [arg args] ] - #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell - #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts - #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal - #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. - #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. - #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. - #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay - #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. - #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. - #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. - # - #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. - #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. - #[para] The main 3 are the result, overflow_right, and unapplied. - #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. - - #puts stderr "renderline '$args'" - variable optimise_ptruns - - if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-expand_right [1|0]? undertext overtext} - } - set under [lindex $args end-1] - set over [lindex $args end] - #lassign [lrange $args end-1 end] under over - if {[string last \n $under] >= 0} { - error "overtype::renderline not allowed to contain newlines in undertext" - } - #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { - # error "overtype::renderline not allowed to contain newlines" - #} - - #generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7) - set opts [tcl::dict::create\ - -etabs 0\ - -width \uFFEF\ - -expand_right 0\ - -transparent 0\ - -startcolumn 1\ - -cursor_column 1\ - -cursor_row ""\ - -insert_mode 1\ - -crm_mode 0\ - -autowrap_mode 1\ - -reverse_mode 0\ - -info 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -cursor_restore_attributes ""\ - -cp437 0\ - -experimental {}\ - ] - #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller - - #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return - #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs - - #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right - #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error - - set argsflags [lrange $args 0 end-2] - tcl::dict::for {k v} $argsflags { - switch -- $k { - -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row - - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode - - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { - tcl::dict::set opts $k $v - } - default { - error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" - } - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [tcl::dict::get $opts -width] - set opt_etabs [tcl::dict::get $opts -etabs] - set opt_expand_right [tcl::dict::get $opts -expand_right] - set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay - set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay - set opt_row_context [tcl::dict::get $opts -cursor_row] - if {[string length $opt_row_context]} { - if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { - error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) - set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) - #default is for overtype - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line - set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM - set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode - # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] - - set cp437_glyphs [tcl::dict::get $opts -cp437] - set cp437_map [tcl::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? - tcl::dict::unset cp437_map \n - } - - set opt_transparent [tcl::dict::get $opts -transparent] - if {$opt_transparent eq "0"} { - set do_transparency 0 - } else { - set do_transparency 1 - if {$opt_transparent eq "1"} { - set opt_transparent {[\s]} - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_returnextra [tcl::dict::get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [tcl::dict::get $opts -exposed1] - set opt_exposed2 [tcl::dict::get $opts -exposed2] - # -- --- --- --- --- --- --- --- --- --- --- --- - - if {$opt_row_context eq ""} { - set cursor_row 1 - } else { - set cursor_row $opt_row_context - } - - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 - set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) - set reverse_mode $opt_reverse_mode - - #----- - # - if {[info exists punk::console::tabwidth]} { - #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted - #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync - #todo - we also need to handle the new threaded repl where console config is in a different thread. - # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - - set overdata $over - if {!$cp437_glyphs} { - #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text - if {!$opt_etabs} { - if {[string first \t $under] >= 0} { - #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] - } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] - } - } - } - #------- - - #ta_detect ansi and do simpler processing? - - #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, - #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. - - # -- --- --- --- --- --- --- --- - if {$under ne ""} { - if {[punk::ansi::ta::detect $under]} { - set undermap [punk::ansi::ta::split_codes_single $under] - } else { - #single plaintext part - set undermap [list $under] - } - } else { - set undermap [list] - } - set understacks [list] - set understacks_gx [list] - set pm_list [list] - - set i_u -1 ;#underlay may legitimately be empty - set undercols [list] - set u_codestack [list] - #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway - set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) - #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation - set remainder [list] ;#for returnextra - foreach {pt code} $undermap { - #pt = plain text - #append pt_underchars $pt - if {$pt ne ""} { - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex - set re [tcl::string::cat {^[} \\U$hex {]+$}] - set is_ptrun [regexp $re $pt] - } - if {$is_ptrun} { - #switch -- $p1 { - # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - # set width 1 - # } - # default { - # if {$p1 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 $p1] ;# when zero??? - # } - # } - #} - set width [grapheme_width_cached $p1] ;# when zero??? - set ptlen [string length $pt] - if {$width <= 1} { - #review - 0 and 1? - incr i_u $ptlen - lappend understacks {*}[lrepeat $ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] - lappend undercols {*}[lrepeat $ptlen $p1] - } else { - incr i_u $ptlen ;#2nd col empty str - so same as above - set 2ptlen [expr {$ptlen * 2}] - lappend understacks {*}[lrepeat $2ptlen $u_codestack] - lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] - set l [concat {*}[lrepeat $ptlen [list $p1 ""]] - lappend undercols {*}$l - unset l - } - - } else { - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly but easy 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. - #todo - test decimal value instead, compare performance - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 - } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - #zero width still acts as 1 below??? review what should happen - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. - set grapheme $gvis - set width 1 - } - } - } - } - } - - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" - } - } - - } - } - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #keep any remaining PMs in place - if {$code ne ""} { - set c1c2 [tcl::string::range $code 0 1] - - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - \x1b^ 7PMX\ - \x1bX 7SOS\ - ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars - - switch -- $leadernorm { - 7CSI - 8CSI { - #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse - #REVIEW - what else could end in m but be mistaken as a normal SGR code here? - set maybemouse "" - if {[tcl::string::index $c1c2 0] eq "\x1b"} { - set maybemouse [tcl::string::index $code 2] - } - - if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set u_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set u_codestack [list $code] - } else { - #basic simplification first.. straight dups - set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars - set u_codestack [lremove $u_codestack {*}$dup_posns] - lappend u_codestack $code - } - } - } - 7GFX { - switch -- [tcl::string::index $code 2] { - "0" { - set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess - } - B { - set u_gx_stack [list] - } - } - } - 7PMX - 7SOS { - #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. - #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! - #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. - - #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string - set graphemeplus [lindex $undercols end] - if {$graphemeplus ne "\0"} { - append graphemeplus $code - } else { - set graphemeplus $code - } - lset undercols end $graphemeplus - #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. - #we need to manually cache the item with it's proper width - variable grapheme_widths - #stripped and plus version keys pointing to same length - dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] - - } - default { - - } - - } - - #if {[punk::ansi::codetype::is_sgr_reset $code]} { - # #set u_codestack [list] - #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - #} elseif {[punk::ansi::codetype::is_sgr $code]} { - #} else { - # #leave SGR stack as is - # if {[punk::ansi::codetype::is_gx_open $code]} { - # } elseif {[punk::ansi::codetype::is_gx_close $code]} { - # } - #} - } - #consider also if there are other codes that should be stacked..? - } - - #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} { - #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - - if {$opt_width ne "\uFFEF"} { - set renderwidth $opt_width - } else { - set renderwidth [llength $undercols] - } - - - if 0 { - # ----------------- - # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose - # Review. - # ----------------- - #replay code for last overlay position in input line - # whether or not we get that far - we need to return it for possible replay on next line - if {[llength $understacks]} { - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - } else { - #in case overlay onto emptystring as underlay - lappend understacks [list] - lappend understacks_gx [list] - } - # ----------------- - } - - #trailing codes in effect for underlay - if {[llength $u_codestack]} { - #set replay_codes_underlay [join $u_codestack ""] - set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] - } else { - set replay_codes_underlay "" - } - - - # -- --- --- --- --- --- --- --- - #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. - #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpadding [string repeat " " [expr {$opt_colstart -1}]] - #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - if {$startpadding ne "" || $overdata ne ""} { - if {[punk::ansi::ta::detect $overdata]} { - set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] - } else { - #single plaintext part - set overmap [list $startpadding$overdata] - } - } else { - set overmap [list] - } - #### - - - #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) - #will that allow some optimisations? - - #todo - detect repeated transparent char in overlay - #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. - # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data - #we should be able to optimize to pass through the underlay?? - - #??? - set colcursor $opt_colstart - #TODO - make a little virtual column object - #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn - #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. - - - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes - - set overstacks [list] - set overstacks_gx [list] - - set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) - set o_gxstack [list] - set pt_overchars "" - set i_o 0 - set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment - set overlay_grapheme_control_stacks [list] - foreach {pt code} $overmap { - if {$pt ne ""} { - #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) - if {$cp437_glyphs} { - set pt [tcl::string::map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - if {!$crm_mode} { - - set is_ptrun 0 - if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { - set p1 [tcl::string::index $pt 0] - set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] - set is_ptrun [regexp $re $pt] - - #leading only? we would have to check for graphemes at the trailing boundary? - #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] - #set is_ptrun [regexp -indices $re $pt runrange] - #if {$is_ptrun && 1} { - #} - } - if {$is_ptrun} { - #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) - #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) - set len [string length $pt] - set g_element [list g $p1] - - #lappend overstacks {*}[lrepeat $len $o_codestack] - #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] - #incr i_o $len - #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] - #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] - - set pi 0 - incr i_o $len - while {$pi < $len} { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - lappend overlay_grapheme_control_list $g_element - lappend overlay_grapheme_control_stacks $o_codestack - incr pi - } - } else { - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - } - } else { - set tsbegin [clock micros] - foreach grapheme_original [punk::char::grapheme_split $pt] { - set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] - #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" - foreach grapheme [punk::char::grapheme_split $pt_crm] { - if {$grapheme eq "\n"} { - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] - } else { - 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 - } - } - } - set elapsed [expr {[clock micros] - $tsbegin}] - puts stderr "ptlen [string length $pt] elapsedus:$elapsed" - } - } - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #order of if-else based on assumptions: - # that pure resets are fairly common - more so than leading resets with other info - # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. - if {$code ne ""} { - #we need to immediately set crm_mode here if \x1b\[3h received - if {$code eq "\x1b\[3h"} { - set crm_mode 1 - } elseif {$code eq "\x1b\[3l"} { - set crm_mode 0 - } - #else crm_mode could be set either way from options - if {$crm_mode && $code ne "\x1b\[00001E"} { - #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? - #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. - set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] - #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop - set chars [split $code_as_pt ""] - set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } - foreach c $chars { - if {$c eq "\n"} { - #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish - lappend codeparts [list crmcontrol "\x1b\[00001E"] - } else { - if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { - set existing [lindex $codeparts end 1] - lset codeparts end [list g [string cat $existing $c]] - } else { - lappend codeparts [list g $c] - } - } - } - - set partidx 0 - foreach record $codeparts { - lassign $record rtype rval - switch -exact -- $rtype { - g { - append pt_overchars $rval - foreach grapheme [punk::char::grapheme_split $rval] { - 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 - } - } - crmcontrol { - #leave o_codestack - lappend overlay_grapheme_control_stacks $o_codestack - lappend overlay_grapheme_control_list [list crmcontrol $rval] - } - } - } - } else { - lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #experiment - #cursor_save - for the replays review. - #jmn - #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - lappend overlay_grapheme_control_list [list other $code] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #experiment - #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] - lappend overlay_grapheme_control_list [list other $code] - } else { - #review - if {[punk::ansi::codetype::is_gx_open $code]} { - set o_gxstack [list "gx0_on"] - lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set o_gxstack [list] - lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { - lappend overlay_grapheme_control_list [list other $code] - } - } - } - } - - } - #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme - set max_overlay_grapheme_index [expr {$i_o -1}] - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - - #set replay_codes_overlay [join $o_codestack ""] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - - #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { - # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] - #} else { - # set replay_codes_overlay "" - #} - # -- --- --- --- --- --- --- --- - - - #potential problem - combinining diacritics directly following control chars like \r \b - - # -- --- --- - #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 - if {$opt_expand_right} { - #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. - #we currently only support horizontal expansion to the right (review regarding RTL text!) - set overflow_idx -1 - } else { - #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation - if {$opt_width ne "\uFFEF"} { - set overflow_idx [expr {$opt_width}] - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } - # -- --- --- - - set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. - - set unapplied "" ;#if we break for move row (but not for /v ?) - set unapplied_list [list] - - set insert_lines_above 0 ;#return key - set insert_lines_below 0 - set instruction "" - - # -- --- --- - #cursor_save_dec, cursor_restore_dec etc - set cursor_restore_required 0 - set cursor_saved_attributes "" - set cursor_saved_position "" - # -- --- --- - - #set idx 0 ;# line index (cursor - 1) - #set idx [expr {$opt_colstart + $opt_colcursor} -1] - - #idx is the per column output index - set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 - #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. - #(for now we are incrementing/decrementing both in sync - which is a bit silly) - set cursor_column $opt_colcursor - - #idx_over is the per grapheme overlay index - set idx_over -1 - - - #movements only occur within the overlay range. - #an underlay is however not necessary.. e.g - #renderline -expand_right 1 "" data - - #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM - #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - #set re_row_move {\x1b\[([0-9]*)(A|B)$} - #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? - #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! - #set re_cursor_restore {\x1b\[u$} - #set re_cursor_save_dec {\x1b7$} - #set re_cursor_restore_dec {\x1b8$} - #set re_other_single {\x1b(D|M|E)$} - #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins - - #puts "-->$overlay_grapheme_control_list<--" - #puts "-->overflow_idx: $overflow_idx" - for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { - set gc [lindex $overlay_grapheme_control_list $gci] - lassign $gc type item - - #emit plaintext chars first using existing SGR codes from under/over stack as appropriate - #then check if the following code is a cursor movement within the line and adjust index if so - #foreach ch $overlay_graphemes {} - switch -- $type { - g { - set ch $item - #crm_mode affects both graphic and control - if {0 && $crm_mode} { - set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] - set chars [string map [list \n "\x1b\[00001E"] $chars] - if {[llength [split $chars ""]] > 1} { - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - #incr idx_over - break - } else { - set ch $chars - } - } - incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. - if {($idx < ($opt_colstart -1))} { - incr idx [grapheme_width_cached $ch] - continue - } - #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width - set within_undercols [expr {$idx <= $renderwidth-1}] - - #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters - #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, - #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. - #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable - #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE - - set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] - #puts --->chtest:$chtest - #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached - switch -- $chtest { - "" { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - if {$idx == 0} { - #puts "---a at col 1" - #linefeed at column 1 - #leave the overflow_idx ;#? review - set instruction lf_start ;#specific instruction for newline at column 1 - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { - #linefeed after final column - #puts "---c at overflow_idx=$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 - set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - #linefeed occurred in middle or at end of text - #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" - if {$insert_mode == 0} { - incr cursor_row - if {$idx == -1 || $overflow_idx > $idx} { - #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 - } - set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - incr cursor_row - #don't adjust the overflow_idx - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction lf_mid - break ;# could have overdata following the \n - don't keep processing - } - } - - } - "" { - #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) - #So far we are assuming the caller has translated to and handle above.. REVIEW. - - #consider also the old space-carriagereturn softwrap convention used in some terminals. - #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. - set idx [expr {$opt_colstart -1}] - set cursor_column $opt_colstart ;#? - } - "" { - #literal backspace char - not necessarily from keyboard - #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype - #(important for -transparent option - hence replacement chars for half-exposed etc) - #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) - if {$idx > ($opt_colstart -1)} { - incr idx -1 - incr cursor_column -1 - } else { - set flag 0 - if $flag { - #review - conflicting requirements? Need a different sequence for destructive interactive backspace? - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction backspace_at_start - break - } - } - } - "" { - #literal del character - some terminals send just this for what is generally expected to be a destructive backspace - #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. - priv::render_delchar $idx - } - "" { - #end processing this overline. rest of line is remainder. cursor for column as is. - #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) - #e.g it could be configured to jump down 6 rows. - #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. - #todo? - incr cursor_row - set overflow_idx $idx - #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction vt - break - } - default { - if {$overflow_idx != -1} { - #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? - #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? - #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc - if {$idx == $overflow_idx-1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 2} { - #review split 2w overflow? - #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line - #better to consider the overlay char as unable to be applied to the line - #render empty 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} { - #REVIEW - set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control - lassign $next_gc next_type next_item - if {$autowrap_mode || $next_type ne "g"} { - 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 { - #no point throwing back to caller for each grapheme that is overflowing - #without this branch - renderline would be called with overtext reducing only by one grapheme per call - #processing a potentially long overtext each time (ie - very slow) - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #JMN4 - - } - } - } else { - #review. - #overflow_idx = -1 - #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) - } - - if {($do_transparency && [regexp $opt_transparent $ch])} { - #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) - if {$idx > [llength $outcols]-1} { - lappend outcols " " - #tcl::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] - #JMN - set uwidth [grapheme_width_cached $g] - if {[lindex $outcols $idx] eq ""} { - #2nd col of 2-wide char in underlay - incr idx - incr cursor_column - } elseif {$uwidth == 0} { - #e.g control char ? combining diacritic ? - incr idx - incr cursor_column - } elseif {$uwidth == 1} { - set owidth [grapheme_width_cached $ch] - incr idx - incr cursor_column - if {$owidth > 1} { - incr idx - incr cursor_column - } - } elseif {$uwidth > 1} { - if {[grapheme_width_cached $ch] == 1} { - if {!$insert_mode} { - #normal singlewide transparent overlay onto double-wide underlay - set next_pt_overchar [tcl::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 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode - priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } else { - #? todo - decide what transparency even means for insert mode - incr idx - incr cursor_column - } - } else { - #2wide transparency over 2wide in underlay - review - incr idx - incr cursor_column - } - } - } - } else { - - set idxchar [lindex $outcols $idx] - #non-transparent char in overlay or empty cell - if {$idxchar eq "\u0000"} { - #empty/erased cell indicator - set uwidth 1 - } else { - set uwidth [grapheme_width_cached $idxchar] - } - if {$within_undercols} { - if {$idxchar eq ""} { - #2nd col of 2wide char in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 - #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme - #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 - #vs - # renderline -startcolumn 2 \uFF21---- \uFF23 - if {[lindex $outcols $idx-1] != ""} { - #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) - #reset previous to an exposed 1st-half - but leave understacks code as is - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 - } - incr idx - } else { - set prevcolinfo [lindex $outcols $idx-1] - #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right - #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) - #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char - #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises - #It is perhaps best avoided at another level and try to make renderline do exactly as it's told - #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index - if {$prevcolinfo ne ""} { - #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert - } ;# else?? - incr idx - } - if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth == 0} { - #what if this is some other c0/c1 control we haven't handled specifically? - - #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it - #e.g combining diacritic - increment before over char REVIEW - #arguably the previous overchar should have done this - ie lookahead for combiners? - #if we can get a proper grapheme_split function - this should be easier to tidy up. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column 2 - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } elseif {$uwidth == 1} { - #includes null empty cells - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme - #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack - if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { - priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode - } - incr idx - } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth > 1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - #1wide over 2wide in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char - } else { - #insert mode just pushes all to right - no exposition char here - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } else { - #2wide over 2wide - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx 2 - incr cursor_column 2 - } - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } - } ;# end switch - - - } - other - crmcontrol { - if {$crm_mode && $type ne "crmcontrol" && $item ne "\x1b\[00001E"} { - if {$item eq "\x1b\[3l"} { - set crm_mode 0 - } else { - #When our initial overlay split was done - we weren't in crm_mode - so there are codes that weren't mapped to unicode control character representations - #set within_undercols [expr {$idx <= $renderwidth-1}] - #set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $item] - set chars [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $item] - priv::render_unapplied $overlay_grapheme_control_list $gci - #prefix the unapplied controls with the string version of this control - set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] - set unapplied [join $unapplied_list ""] - - break - } - } - - #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. - #we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore? - set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] - #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' - - - #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI - #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping - #review - cost/benefit of function calls within these switch-arms instead of inline code? - - set c1 [tcl::string::index $code 0] - set c1c2c3 [tcl::string::range $code 0 2] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. - #(somewhat surprising) - set leadernorm [tcl::string::range [tcl::string::map [list\ - \x1b\[< 1006\ - \x1b\[ 7CSI\ - \x1bY 7MAP\ - \x1bP 7DCS\ - \x90 8DCS\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) - - #we leave the tail of the code unmapped for now - switch -- $leadernorm { - 1006 { - #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html - #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] - } - 7CSI - 7OSC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - set codenorm $leadernorm[tcl::string::range $code 2 end] - } - 7DCS { - #ESC P - #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] - } - 8DCS { - #8-bit Device Control String - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - 7MAP { - #map to another type of code to share implementation branch - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 7ESC { - #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - set codenorm $leadernorm[tcl::string::range $code 1 end] - } - 8CSI - 8OSC { - set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] - } - default { - puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #we haven't made a mapping for this - #could in theory be 1,2 or 3 in len - #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches - set codenorm $code - } - } - - switch -- $leadernorm { - 7MAP { - switch -- [lindex $codenorm 4] { - Y { - #vt52 movement. we expect 2 chars representing position (limited range) - set params [tcl::string::range $codenorm 5 end] - if {[tcl::string::length $params] != 2} { - #shouldn't really get here or need this branch if ansi splitting was done correctly - puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - set line [tcl::string::index $params 5] - set column [tcl::string::index $params 1] - set r [expr {[scan $line %c] -31}] - set c [expr {[scan $column %c] -31}] - - #MAP to: - #CSI n;m H - CUP - Cursor Position - set leadernorm 7CSI - set codenorm "$leadernorm${r}\;${c}H" - } - } - } - } - - #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. - switch -- $leadernorm { - 1006 { - #TODO - # - switch -- [tcl::string::index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - set param [tcl::string::range $codenorm 4 end-1] - #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" - set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode - - switch -exact -- $code_end { - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #todo - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - - if {$num eq ""} {set num 1} - incr cursor_row -$num - - if {$cursor_row < 1} { - set cursor_row 1 - } - - #ensure rest of *overlay* is emitted to remainder - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up - #retain cursor_column - break - } - B { - #CUD - Cursor Down - #Row move - down - lassign [split $param {;}] num modifierkey - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - if {$num eq ""} {set num 1} - incr cursor_row $num - - - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - C { - #CUF - Cursor Forward - #Col move - #puts stdout "->forward" - #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. - #cursor forward - #right-arrow/move forward - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - if {$num eq ""} {set num 1} - - #todo - retrict to moving 1 position past datalen? restrict to column width? - #should ideally wrap to next line when interactive and not on last row - #(some ansi art seems to expect this behaviour) - #This presumably depends on the terminal's wrap mode - #e.g DECAWM autowrap mode - # CSI ? 7 h - set: autowrap (also tput smam) - # CSI ? 7 l - reset: no autowrap (also tput rmam) - set version 2 - if {$version eq "2"} { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$cursor_column == $max+1} { - #move_forward while in overflow - incr cursor_column -1 - } - - if {($cursor_column + $num) <= $max} { - incr idx $num - incr cursor_column $num - } else { - if {$autowrap_mode} { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #jmn - if {$idx == $overflow_idx} { - incr num - } - - #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_right and unapplied data - #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) - #leave row as is - caller will need to determine how many rows the column-movement has consumed - incr cursor_column $num ;#give our caller the necessary info as columns from start of row - #incr idx_over - #should be gci following last one applied - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmoveforward - break - } else { - set cursor_column $max - set idx [expr {$cursor_column -1}] - } - } - } else { - #review - dead branch - if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { - incr idx $num - incr cursor_column $num - } else { - if {!$insert_mode} { - #block editing style with arrow keys - #overtype mode - set idxstart $idx - set idxend [llength $outcols] - set moveend [expr {$idxend - $idxstart}] - if {$moveend < 0} {set moveend 0} ;#sanity? - #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" - incr idx $moveend - incr cursor_column $moveend - #if {[tcl::dict::exists $understacks $idx]} { - # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - #} else { - # set stackinfo [list] - #} - if {$idx < [llength $understacks]} { - set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - } else { - set stackinfo [list] - } - if {$idx < [llength $understacks_gx]} { - #set gxstackinfo [tcl::dict::get $understacks_gx $idx] - set gxstackinfo [lindex $understacks_gx $idx] - } else { - set gxstackinfo [list] - } - #pad outcols - set movemore [expr {$num - $moveend}] - #assert movemore always at least 1 or we wouldn't be in this branch - for {set m 1} {$m <= $movemore} {incr m} { - incr idx - incr cursor_column - priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode - } - } else { - #normal - insert - incr idx $num - incr cursor_column $num - if {$idx > [llength $outcols]} { - set idx [llength $outcols];#allow one beyond - for adding character at end of line - set cursor_column [expr {[llength $outcols]+1}] - } - } - } - } - } - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - lassign [split $param {;}] num modifierkey - if {$modifierkey ne ""} { - puts stderr "modifierkey:$modifierkey" - } - if {$num eq ""} {set num 1} - - set version 2 - if {$version eq "2"} { - #todo - startcolumn offset! - if {$cursor_column - $num >= 1} { - incr idx -$num - incr cursor_column -$num - } else { - if {!$autowrap_mode} { - set cursor_column 1 - set idx 0 - } else { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmovebackward - break - } - } - } else { - incr idx -$num - incr cursor_column -$num - if {$idx < $opt_colstart-1} { - #wrap to previous line and position cursor at end of data - set idx [expr {$opt_colstart-1}] - set cursor_column $opt_colstart - } - } - } - E { - #CNL - Cursor Next Line - if {$param eq ""} { - set downmove 1 - } else { - set downmove [expr {$param}] - } - puts stderr "renderline CNL down-by-$downmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row + $downmove}] - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - F { - #CPL - Cursor Previous Line - if {$param eq ""} { - set upmove 1 - } else { - set upmove [expr {$param}] - } - puts stderr "renderline CPL up-by-$upmove" - set cursor_column 1 - set cursor_row [expr {$cursor_row -$upmove}] - if {$cursor_row < 1} { - set cursor_row 1 - } - set idx [expr {$cursor_column - 1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - G { - #CHA - Cursor Horizontal Absolute (move to absolute column no) - if {$param eq ""} { - set targetcol 1 - } else { - set targetcol $param - if {![string is integer -strict $targetcol]} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" - } - set targetcol [expr {$param}] - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$targetcol > $max} { - puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" - set targetcol $max - } - } - #adjust to colstart - as column 1 is within overlay - #??? REVIEW - set idx [expr {($targetcol -1) + $opt_colstart -1}] - - - set cursor_column $targetcol - #puts stderr "renderline absolute col move ESC G (TEST)" - } - H - f { - #CSI n;m H - CUP - Cursor Position - - #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes - # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' - # - REVIEW - #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf - - #test e.g ansicat face_2.ans - #$re_both_move - lassign [split $param {;}] paramrow paramcol - #missing defaults to 1 - #CSI ;5H = CSI 1;5H -> row 1 col 5 - #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 - - if {$paramcol eq ""} {set paramcol 1} - if {$paramrow eq ""} {set paramrow 1} - if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { - puts stderr "renderline CUP (CSI H) unrecognised param $param" - #ignore? - } else { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$paramcol > $max} { - set target_column $max - } else { - set target_column [expr {$paramcol}] - } - - - if {$paramrow < 1} { - puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" - set target_row 1 - } else { - set target_row [expr {$paramrow}] - } - if {$target_row == $cursor_row} { - #col move only - no need for break and move - #puts stderr "renderline CUP col move only to col $target_column param:$param" - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - } else { - set cursor_row $target_row - set cursor_column $target_column - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - } - } - } - J { - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - #CSI ? Pn J - selective erase - puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of screen - } - 1 { - #clear from cursor to beginning of screen - } - 2 { - #clear entire screen - #ansi.sys - move cursor to upper left REVIEW - set cursor_row 1 - set cursor_column 1 - set idx [expr {$cursor_column -1}] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr idx_over - if {[llength $outcols]} { - priv::render_erasechar 0 [llength $outcols] - } - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction clear_and_move - break - } - 3 { - #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? - - } - default { - } - } - - } - } - } - K { - #see DECECM regarding background colour - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? - switch -exact -- $modegroup { - ? { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - set param [string range $param 1 end] ;#chop qmark - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - depending on DECSCA - } - 1 { - #clear from cursor to beginning of line - depending on DECSCA - - } - 2 { - #clear entire line - depending on DECSCA - } - default { - puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$param eq ""} {set param 0} - switch -exact -- $param { - 0 { - #clear from cursor to end of line - } - 1 { - #clear from cursor to beginning of line - - } - 2 { - #clear entire line - } - default { - puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - } - } - } - L { - puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - M { - #CSI Pn M - DL - Delete Line - puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - } - T { - #CSI Pn T - SD Pan Up (empty lines introduced at top) - #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) - #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display - if {$param eq "" || $param eq "0"} {set param 1} - if {[string index $param end] eq "+"} { - puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } else { - puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - X { - puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" - #ECH - erase character - if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase - priv::render_erasechar $idx $param - #cursor position doesn't change. - } - q { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - {"} { - #DECSCA - Select Character Protection Attribute - #(for use with selective erase: DECSED and DECSEL) - set param [tcl::string::range $codenorm 4 end-2] - if {$param eq ""} {set param 0} - #TODO - store like SGR in stacks - replays? - switch -exact -- $param { - 0 - 2 { - #canerase - puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 1 { - #cannoterase - puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - r { - #$re_decstbm - #https://www.vt100.net/docs/vt510-rm/DECSTBM.html - #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins - lassign [split $param {;}] margin_top margin_bottom - - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break - } - s { - #code conflict between ansi emulation and DECSLRM - REVIEW - #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC - # todo - when parameters - support DECSLRM instead - - if {$param ne ""} { - #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) - lassign [split $param {;} margin_left margin_right - puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - if {$margin_left eq ""} { - set margin_left 1 - } - set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? - if {$margin_right eq ""} { - set margin_right $columns_per_page - } - puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" - if {![string is integer -strict $margin_left] || $margin_left < 0} { - puts stderr "DECSLRM invalid margin_left" - } - if {![string is integer -strict $margin_right] || $margin_right < 0} { - puts stderr "DECSLRM invalid margin_right" - } - set scrolling_region_size [expr {$margin_right - $margin_left}] - if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { - puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" - } - #todo - - - } else { - #DECSC - #//notes on expected behaviour: - #DECSC - saves following items in terminal's memory - #cursor position - #character attributes set by the SGR command - #character sets (G0,G1,G2 or G3) currently in GL and GR - #Wrap flag (autowrap or no autowrap) - #State of origin mode (DECOM) - #selective erase attribute - #any single shift 2 (SS2) or single shift 3(SSD) functions sent - - #$re_cursor_save - #cursor save could come after last column - if {$overflow_idx != -1 && $idx == $overflow_idx} { - #bartman2.ans test file - fixes misalignment at bottom of dialog bubble - #incr cursor_row - #set cursor_column 1 - #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) - set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] - } else { - set cursor_saved_position [list row $cursor_row column $cursor_column] - } - #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save - - #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. - #set sgr_stack [lindex $understacks $idx] - #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - - set sgr_stack [list] - set gx_stack [list] - - #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. - #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. - - foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code - #types g other sgr gx0 - switch -- $type { - gx0 { - #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off - set gx_stack [list $code] - } - sgr { - #code is the raw code - if {[punk::ansi::codetype::is_sgr_reset $code]} { - #jmn - set sgr_stack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set sgr_stack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #often we don't get resets - and codes just pile up. - #as a first step to simplifying - at least remove earlier straight up dupes - set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) - set sgr_stack [lremove $sgr_stack {*}$dup_posns] - lappend sgr_stack $code - } - } - } - } - set cursor_saved_attributes "" - switch -- [lindex $gx_stack 0] { - gx0_on { - append cursor_saved_attributes "\x1b(0" - } - gx0_off { - append cursor_saved_attributes "\x1b(B" - } - } - #append cursor_saved_attributes [join $sgr_stack ""] - append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] - - #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. - - #don't incr index - or the save will cause cursor to move to the right - #carry on - } - } - u { - #ANSISYSRC save cursor (when no parameters) (DECSC) - - #$re_cursor_restore - #we are going to jump somewhere.. for now we will assume another line, and process accordingly. - #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) - #don't set overflow at this point. The existing underlay to the right must be preserved. - #we only want to jump and render the unapplied at the new location. - - #lset overstacks $idx_over [list] - #set replay_codes_overlay "" - - #if {$cursor_saved_attributes ne ""} { - # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk - #} else { - #jj - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set replay_codes_overlay "" - #} - - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code - incr idx_over - - set unapplied "" - set unapplied_list [list] - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - #incr idx_over - } - set unapplied [join $unapplied_list ""] - #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. - set instruction restore_cursor - break - } - "{" { - - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - "}" { - set code_secondlast [tcl::string::index $codenorm end-1] - switch -exact -- $code_secondlast { - ' { - puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - default { - puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" - } - } - } - ~ { - set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ - switch -exact -- $code_secondlast { - ' { - #DECDC - editing sequence - Delete Column - puts stderr "renderline warning - DECDC - unimplemented" - } - default { - #$re_vt_sequence - lassign [split $param {;}] key mod - - #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ - # - #e.g esc \[2~ insert esc \[2;2~ shift-insert - #mod - subtract 1, and then use bitmask - #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" - if {$key eq "1"} { - #home - } elseif {$key eq "2"} { - #Insert - if {$mod eq ""} { - #no modifier key - set insert_mode [expr {!$insert_mode}] - #rather than set the cursor - we return the insert mode state so the caller can decide - } - } elseif {$key eq "3"} { - #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end - switch -- $mod { - "" { - priv::render_delchar $idx - } - "5" { - #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) - } - } - } elseif {$key eq "4"} { - #End - } elseif {$key eq "5"} { - #pgup - } elseif {$key eq "6"} { - #pgDn - } elseif {$key eq "7"} { - #Home - #?? - set idx [expr {$opt_colstart -1}] - set cursor_column 1 - } elseif {$key eq "8"} { - #End - } elseif {$key eq "11"} { - #F1 - or ESCOP or e.g shift F1 ESC\[1;2P - } elseif {$key eq "12"} { - #F2 - or ESCOQ - } elseif {$key eq "13"} { - #F3 - or ESCOR - } elseif {$key eq "14"} { - #F4 - or ESCOS - } elseif {$key eq "15"} { - #F5 or shift F5 ESC\[15;2~ - } elseif {$key eq "17"} { - #F6 - } elseif {$key eq "18"} { - #F7 - } elseif {$key eq "19"} { - #F8 - } elseif {$key eq "20"} { - #F9 - } elseif {$key eq "21"} { - #F10 - } elseif {$key eq "23"} { - #F11 - } elseif {$key eq "24"} { - #F12 - } - - } - } - - } - h - l { - #set mode unset mode - #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? - - #$re_mode if first after CSI is "?" - #some docs mention ESC=h|l - not seen on windows terminals.. review - #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html - set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = - switch -exact -- $modegroup { - ? { - set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l - #one or more modes can be set - set smparam_list [split $smparams {;}] - foreach num $smparam_list { - switch -- $num { - "" { - #ignore empties e.g extra/trailing semicolon in params - } - 5 { - #DECSNM - reverse video - #How we simulate this to render within a block of text is an open question. - #track all SGR stacks and constantly flip based on the current SGR reverse state? - #It is the job of the calling loop to do this - so at this stage we'll just set the states - - if {$code_end eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } - - } - 7 { - #DECAWM autowrap - if {$code_end eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? - # presume not usually - but sanity check with warning for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" - } - } else { - #reset (disable) - set autowrap_mode 0 - #REVIEW! - set overflow_idx -1 - } - } - 25 { - if {$code_end eq "h"} { - #visible cursor - - } else { - #invisible cursor - - } - } - 117 { - #DECECM - Erase Color Mode - #https://invisible-island.net/ncurses/ncurses.faq.html - #The Erase color selection controls the background color used when text is erased or new - #text is scrolled on to the screen. Screen background causes newly erased areas or - #scrolled text to be written using color index zero, the screen background. This is VT - #and DECterm compatible. Text background causes erased areas or scrolled text to be - #written using the current text background color. This is PC console compatible and is - #the factory default. - - #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen - } - } - } - } - = { - set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l - puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - default { - #e.g CSI 4 h - set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l - switch -exact -- $num { - 3 { - puts stderr "CRM MODE $code_end" - #CRM - Show control character mode - # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' - # - #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 - #https://vt100.net/docs/vt510-rm/CRM.html - #NOTE - vt100 CRM always does auto-wrap at right margin. - #disabling auto-wrap in set-up or by sequence is disabled. - #We should default to turning off auto-wrap when crm_mode enabled.. but - #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) - #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, - #although this would be potentially an annoying difference to some.. REVIEW - if {$code_end eq "h"} { - set crm_mode 1 - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } else { - set crm_mode 0 - } - } - 4 { - #IRM - Insert/Replace Mode - if {$code_end eq "h"} { - #CSI 4 h - set insert_mode 1 - } else { - #CSI 4 l - #replace mode - set insert_mode 0 - } - } - default { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - } - } - | { - switch -- [tcl::string::index $codenorm end-1] { - {$} { - #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) - #real terminals generally only supported 80/132 - #some other virtuals support any where from 2 to 65,536? - #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. - #CSI $ | - #empty or 0 param is 80 for compatibility - other numbers > 2 accepted - set page_width -1 ;#flag as unset - if {$param eq ""} { - set page_width 80 - } elseif {[string is integer -strict $param] && $param >=2 0} { - set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr - } else { - puts stderr "overtype::renderline unacceptable DECSPP value '$param'" - } - - if {$page_width > 2} { - puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" - #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement - - } - - } - default { - puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - default { - puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - 7ESC { - # - #re_other_single {\x1b(D|M|E)$} - #also vt52 Y.. - #also PM \x1b^...(ST) - switch -- [tcl::string::index $codenorm 4] { - c { - #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! - puts stderr "renderline reset" - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction reset - break - } - D { - #\x84 - #index (IND) - #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" - puts stderr "renderline ESC D not fully implemented" - incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - E { - #\x85 - #review - is behaviour different to lf? - #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL - #leave implementation until logic for is set in stone... still under review - #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # - #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" - puts stderr "overtype::renderline ESC E unimplemented" - - } - H { - #\x88 - #Tab Set - puts stderr "overtype::renderline ESC H tab set unimplemented" - } - M { - #\x8D - #Reverse Index (RI) - #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" - puts stderr "overtype::renderline ESC M not fully implemented" - - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move up - incr cursor_row -1 - if {$cursor_row < 1} { - set cursor_row 1 - } - #ensure rest of *overlay* is emitted to remainder - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? - #retain cursor_column - break - } - N { - #\x8e - affects next character only - puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - O { - #\x8f - affects next character only - puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - P { - #\x90 - #DCS - shouldn't get here - handled in 7DCS branch - #similarly \] OSC (\x9d) and \\ (\x9c) ST - } - V { - #\x96 - - } - W { - #\x97 - } - X { - #\x98 - #SOS - if {[string index $code end] eq "\007"} { - set sos_content [string range $code 2 end-1] ;#ST is \007 - } else { - set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #return in some useful form to the caller - #TODO! - lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] - puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - ^ { - #puts stderr "renderline PM" - #Privacy Message. - if {[string index $code end] eq "\007"} { - set pm_content [string range $code 2 end-1] ;#ST is \007 - } else { - set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ - } - #We don't want to render it - but we need to make it available to the application - #see the textblock library in punk, for the exception we make here for single backspace. - #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix - #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' - if {$pm_content eq "\b"} { - #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" - #esc^\b\007 or esc^\besc\\ - #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs - #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. - #If the terminal has the space problem AND does support PMs - then this just won't fix it. - #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. - - #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #idx has been incremented after last grapheme added - priv::render_append_to_char [expr {$idx -1}] $code - } - #lappend to a dict element in the result for application-specific processing - lappend pm_list $pm_content - } - _ { - #APC Application Program Command - #just warn for now.. - puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" - } - } - - } - 7DCS - 8DCS { - puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - #ST (string terminator) \x9c or \x1b\\ - if {[tcl::string::index $codenorm end] eq "\x9c"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c - } else { - set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ - } - - } - 7OSC - 8OSC { - # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit - if {[tcl::string::index $codenorm end] eq "\007"} { - set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 - } else { - set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ - } - set first_colon [tcl::string::first {;} $code_content] - if {$first_colon == -1} { - #there probably should always be a colon - but we'll try to make sense of it without - set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 - } else { - set osc_code [tcl::string::range $code_content 0 $first_colon-1] - } - switch -exact -- $osc_code { - 2 { - set newtitle [tcl::string::range $code_content 2 end] - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction [list set_window_title $newtitle] - break - } - 4 { - #OSC 4 - set colour palette - #can take multiple params - #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ - set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon - set cmap [dict create] - foreach {cnum spec} [split $params {;}] { - if {$cnum >= 0 and $cnum <= 255} { - #todo - parse spec from names like 'red' to RGB - #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) - #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? - dict set cmap $cnum $spec - } else { - #todo - log - puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - - } - 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { - #OSC 10 through 17 - so called 'dynamic colours' - #can take multiple params - each successive parameter changes the next colour in the list - #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more - #10 change text foreground colour - #11 change text background colour - #12 change text cursor colour - #13 change mouse foreground colour - #14 change mouse background colour - #15 change tektronix foreground colour - #16 change tektronix background colour - #17 change highlight colour - set params [tcl::string::range $code_content 2 end] - - puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - - - } - 18 { - #why is this not considered one of the dynamic colours above? - #https://www.xfree86.org/current/ctlseqs.html - #tektronix cursor color - puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 99 { - #kitty desktop notifications - #https://sw.kovidgoyal.net/kitty/desktop-notifications/ - # 99 ; metadata ; payload - puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - 104 { - #reset colour palette - #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt - puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction [list reset_colour_palette] - break - } - 1337 { - #iterm2 graphics and file transfer - puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - 5113 { - puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" - } - default { - puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" - } - } - - } - default { - } - } - - - } - default { - #don't need to handle sgr or gx0 types - #we have our sgr gx0 codes already in stacks for each overlay grapheme - } - } - } - - #-------- - if {$opt_expand_right == 0} { - #need to truncate to the width of the original undertext - #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? - #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars - } - if {$overflow_idx == -1} { - #overflow was initially unlimited and hasn't been overridden - } else { - - } - #-------- - - - #coalesce and replay codestacks for outcols grapheme list - set outstring "" ;#output prior to overflow - set overflow_right "" ;#remainder after overflow point reached - set i 0 - set cstack [list] - set prevstack [list] - set prev_g0 [list] - #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves - set in_overflow 0 ;#used to stop char-width scanning once in overflow - if {$overflow_idx == 0} { - #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW - set in_overflow 1 - } - set trailing_nulls 0 - foreach ch [lreverse $outcols] { - if {$ch eq "\u0000"} { - incr trailing_nulls - } else { - break - } - } - if {$trailing_nulls} { - set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] - } else { - set first_tail_null_posn -1 - } - - #puts stderr "first_tail_null_posn: $first_tail_null_posn" - #puts stderr "colview: [ansistring VIEW $outcols]" - - foreach ch $outcols { - #puts "---- [ansistring VIEW $ch]" - - set gxleader "" - if {$i < [llength $understacks_gx]} { - #set g0 [tcl::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 [tcl::dict::get $understacks $i] - set cstack [lindex $understacks $i] - if {$cstack ne $prevstack} { - if {[llength $prevstack] && ![llength $cstack]} { - #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? - append sgrleader \033\[m - } else { - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - } - } - set prevstack $cstack - } else { - set prevstack [list] - } - - - - if {$in_overflow} { - if {$i == $overflow_idx} { - set 0 [lindex $understacks_gx $i] - set gxleader "" - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } elseif {$g0 eq [list "gx0_off"]} { - set gxleader "\x1b(B" - } - append overflow_right $gxleader - set cstack [lindex $understacks $i] - set sgrleader "" - #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right - #if {[llength $prevstack] && ![llength $cstack]} { - # append sgrleader \033\[m - #} - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - append overflow_right $sgrleader - append overflow_right $ch - } else { - append overflow_right $gxleader - append overflow_right $sgrleader - append overflow_right $ch - } - } else { - if {$overflow_idx != -1 && $i+1 == $overflow_idx} { - #one before overflow - #will be in overflow in next iteration - set in_overflow 1 - if {[grapheme_width_cached $ch]> 1} { - #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) - set ch $opt_exposed1 - } - } - append outstring $gxleader - append outstring $sgrleader - if {$ch eq "\u0000"} { - if {$cp437_glyphs} { - #map all nulls including at tail to space - append outstring " " - } else { - if {$trailing_nulls && $i < $first_tail_null_posn} { - append outstring " " ;#map inner nulls to space - } else { - append outstring \u0000 - } - } - } else { - append outstring $ch - } - } - incr i - } - #flower.ans good test for null handling - reverse line building - #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. - #The cells could have been erased? - #if {!$cp437_glyphs} { - # #if {![ansistring length $overflow_right]} { - # # set outstring [tcl::string::trimright $outstring "\u0000"] - # #} - # set outstring [tcl::string::trimright $outstring "\u0000"] - # set outstring [tcl::string::map {\u0000 " "} $outstring] - #} - - - #REVIEW - #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] - #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] - - set replay_codes "" - if {[llength $understacks] > 0} { - if {$overflow_idx == -1} { - #set tail_idx [tcl::dict::size $understacks] - set tail_idx [llength $understacks] - } else { - set tail_idx [llength $undercols] - } - if {$tail_idx-1 < [llength $understacks]} { - #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes - set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes - } - if {$tail_idx-1 < [llength $understacks_gx]} { - set gx0 [lindex $understacks_gx $tail_idx-1] - if {$gx0 eq [list "gx0_on"]} { - #if it was on, turn gx0 off at the point we stop processing overlay - append outstring "\x1b(B" - } - } - } - if {[string length $overflow_right]} { - #puts stderr "remainder:$overflow_right" - } - #pdict $understacks - - if {[punk::ansi::ta::detect_sgr $outstring]} { - append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column - - #close off any open gx? - #probably should - and overflow_right reopen? - } - - if {$opt_returnextra} { - #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review - #replay_codes_underlay is the set of codes in effect at the very end of the original underlay - - #review - #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) - #todo - replay_codes for gx0 mode - - #overflow_idx may change during ansi & character processing - if {$overflow_idx == -1} { - set overflow_right_column "" - } else { - set overflow_right_column [expr {$overflow_idx+1}] - } - set result [tcl::dict::create\ - result $outstring\ - visualwidth [punk::ansi::printing_length $outstring]\ - instruction $instruction\ - stringlen [string length $outstring]\ - overflow_right_column $overflow_right_column\ - overflow_right $overflow_right\ - unapplied $unapplied\ - unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ - crm_mode $crm_mode\ - reverse_mode $reverse_mode\ - insert_lines_above $insert_lines_above\ - insert_lines_below $insert_lines_below\ - cursor_saved_position $cursor_saved_position\ - cursor_saved_attributes $cursor_saved_attributes\ - cursor_column $cursor_column\ - cursor_row $cursor_row\ - expand_right $opt_expand_right\ - replay_codes $replay_codes\ - replay_codes_underlay $replay_codes_underlay\ - replay_codes_overlay $replay_codes_overlay\ - pm_list $pm_list\ - ] - if {$opt_returnextra == 1} { - #puts stderr "renderline: $result" - 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. - } - } - tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] - tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] - tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] - tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] - tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] - tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] - tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] - tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] - return $result - } - } else { - #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" - return $outstring - } - #return [join $out ""] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace overtype ---}] -} - -tcl::namespace::eval overtype::piper { - proc overcentre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::centre {*}$argsflags $under $over - } - proc overleft {args} { - if {[llength $args] < 2} { - error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::left {*}$argsflags $under $over - } -} - - -# -- --- --- --- --- --- --- --- --- --- --- -proc overtype::transparentline {args} { - foreach {under over} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - set defaults [tcl::dict::create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - set newargs [tcl::dict::merge $defaults $argsflags] - tailcall overtype::renderline {*}$newargs $under $over -} -#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. -# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. -#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. -# -tcl::namespace::eval overtype::piper { - proc renderline {args} { - if {[llength $args] < 2} { - error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} - } - foreach {over under} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - tailcall overtype::renderline {*}$argsflags $under $over - } -} -interp alias "" piper_renderline "" overtype::piper::renderline - -#intended primarily for single grapheme - but will work for multiple -#WARNING: query CAN contain ansi or newlines - but if cache was not already set manually,the answer will be incorrect! -#We deliberately allow this for PM/SOS attached within a column -#(a cache of ansifreestring_width calls - as these are quite regex heavy) -proc overtype::grapheme_width_cached {ch} { - variable grapheme_widths - if {[tcl::dict::exists $grapheme_widths $ch]} { - return [tcl::dict::get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - tcl::dict::set grapheme_widths $ch $width - return $width -} - - - -proc overtype::test_renderline {} { - set t \uFF5E ;#2-wide tilde - set u \uFF3F ;#2-wide underscore - set missing \uFFFD - return [list $t $u A${t}B] -} - -#maintenance warning -#same as textblock::size - but we don't want that circular dependency -#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both -proc overtype::blocksize {textblock} { - if {$textblock eq ""} { - return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings - } - if {[tcl::string::first \t $textblock] >= 0} { - if {[info exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests - if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::ansistrip $textblock] - } - if {[tcl::string::last \n $textblock] >= 0} { - set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set num_le 0 - set width [punk::char::ansifreestring_width $textblock] - } - #our concept of block-height is likely to be different to other line-counting mechanisms - set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - - return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height -} - -tcl::namespace::eval overtype::priv { - variable cache_is_sgr [tcl::dict::create] - - #we are likely to be asking the same question of the same ansi codes repeatedly - #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS - #todo - test if still worthwhile after a large cache is built up. (limit cache size?) - proc is_sgr {code} { - variable cache_is_sgr - if {[tcl::dict::exists $cache_is_sgr $code]} { - return [tcl::dict::get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - tcl::dict::set cache_is_sgr $code $answer - return $answer - } - # better named render_to_unapplied? - proc render_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - #append unapplied [join [lindex $overstacks $idx_over] ""] - #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - - #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack - proc render_this_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - proc render_delchar {i} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - set nxt [llength $o] - if {$i < $nxt} { - set o [lreplace $o $i $i] - set ustacks [lreplace $ustacks $i $i] - set gxstacks [lreplace $gxstacks $i $i] - } elseif {$i == 0 || $i == $nxt} { - #nothing to do - } else { - puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" - } - } - proc render_erasechar {i count} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - upvar replay_codes_overlay replay - #ECH clears character attributes from erased character positions - #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. - if {![tcl::string::is integer -strict $count] || $count < 1} { - error "render_erasechar count must be integer >= 1" - } - set start $i - set end [expr {$i + $count -1}] - #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? - if {$i > [llength $o]-1} { - return - } - if {$end > [llength $o]-1} { - set end [expr {[llength $o]-1}] - } - set num [expr {$end - $start + 1}] - set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? - #DECECM ??? - set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] - set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review - return - } - proc render_setchar {i c } { - upvar outcols o - lset o $i $c - } - - #Initial usecase is for old-terminal hack to add PM-wrapped \b - #review - can be used for other multibyte sequences that occupy one column? - #combiners? diacritics? - proc render_append_to_char {i c} { - upvar outcols o - if {$i > [llength $o]-1} { - error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" - } - set existing [lindex $o $i] - if {$existing eq "\0"} { - lset o $i $c - } else { - lset o $i $existing$c - } - } - #is actually addgrapheme? - proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - - # -- --- --- - #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review - #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes - upvar reverse_mode do_reverse - #if {$do_reverse} { - # lappend sgrstack [a+ reverse] - #} else { - # lappend sgrstack [a+ noreverse] - #} - - #JMN3 - if {$do_reverse} { - #note we can't just look for \x1b\[7m or \x1b\[27m - # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc - - set existing_reverse_state 0 - set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] - set codestate_reverse [dict get $codeinfo codestate reverse] - switch -- $codestate_reverse { - 7 { - set existing_reverse_state 1 - } - 27 { - set existing_reverse_state 0 - } - "" { - } - } - if {$existing_reverse_state == 0} { - set rflip [a+ reverse] - } else { - #reverse of reverse - set rflip [a+ noreverse] - } - #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) - set sgrstack [list [dict get $codeinfo mergeresult] $rflip] - #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] - } - - # -- --- --- - - set nxt [llength $o] - if {!$insert_mode} { - if {$i < $nxt} { - #These lists must always be in sync - lset o $i $c - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - lset ustacks $i $sgrstack - lset gxstacks $i $gx0stack - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } else { - #insert of single-width vs double-width when underlying is double-width? - if {$i < $nxt} { - set o [linsert $o $i $c] - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -tcl::namespace::eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [tcl::namespace::eval overtype { - variable version - set version 1.6.5 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/vendormodules/packagetrace-0.8.tm b/src/vendormodules/packagetrace-0.8.tm deleted file mode 100644 index 2025cdc2..00000000 --- a/src/vendormodules/packagetrace-0.8.tm +++ /dev/null @@ -1,643 +0,0 @@ - - -#JMN 2005 - Public Domain -# -#REVIEW: This package may not robustly output xml. More testing & development required. -# - -#NOTE: the 'x' attribute on the 'info' tag may have its value truncated. -#It is a human-readable indicator only and should not be used to cross-reference to the corresponding 'require' tag using the 'p' attribute. -#Use the fact that the corresponding 'info' tag directly follows its 'require' tag. - - -#changes -#2021-09-17 -# - added variable ::packagetrace::showpresent with default 1 -# setting this to 0 will hide the tags which sometimes make the output too verbose. -# - changed t from an integer number of milliseconds to show fractional millis by using ([clock microseconds]-$t0)/1000.0 in the expr. - -namespace eval packagetrace::class { - if {[info commands [namespace current]::tracer] eq ""} { - oo::class create tracer { - method get {} { - } - method test {} { - return tracertest - } - } - } -} - - -namespace eval packagetrace { - variable tracerlist [list] - variable chan stderr - variable showpresent 1 - variable output "" - - - proc help {} { - return { - REVIEW - documentation inaccurate -Enable package tracing using 'package require packagetrace' -Disable package tracing using 'package forget packagetrace; package require packagetrace' - (This 2nd 'package require packagetrace' will raise an error. This is deliberate.) -use packagetrace::channel to desired output channel or none. (default stderr) - -set packagetrace::showpresent 0 to skip output -} - } - - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - # Maintenance - tm_version... functions - primary source is punk::lib module - # - these should be synced with code from latest punk::lib - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - proc tm_version_isvalid {versionpart} { - #Needs to be suitable for use with Tcl's 'package vcompare' - if {![catch [list package vcompare $versionpart $versionpart]]} { - return 1 - } else { - return 0 - } - } - proc tm_version_major {version} { - if {![tm_version_isvalid $version]} { - error "Invalid version '$version' is not a proper Tcl module version number" - } - set firstpart [lindex [split $version .] 0] - #check for a/b in first segment - if {[string is integer -strict $firstpart]} { - return $firstpart - } - if {[string first a $firstpart] > 0} { - return [lindex [split $firstpart a] 0] - } - if {[string first b $firstpart] > 0} { - return [lindex [split $firstpart b] 0] - } - error "tm_version_major unable to determine major version from version number '$version'" - } - proc tm_version_canonical {ver} { - #accepts a single valid version only - not a bounded or unbounded spec - if {![tm_version_isvalid $ver]} { - error "tm_version_canonical version '$ver' is not valid for a package version" - } - set parts [split $ver .] - set newparts [list] - foreach o $parts { - set trimmed [string trimleft $o 0] - set firstnonzero [string index $trimmed 0] - switch -exact -- $firstnonzero { - "" { - lappend newparts 0 - } - a - b { - #e.g 000bnnnn -> bnnnnn - set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] - if {$tailtrimmed eq ""} { - set tailtrimmed 0 - } - lappend newparts 0$firstnonzero$tailtrimmed - } - default { - #digit - if {[string is integer -strict $trimmed]} { - #e.g 0100 -> 100 - lappend newparts $trimmed - } else { - #e.g 0100b003 -> 100b003 (still need to process tail) - if {[set apos [string first a $trimmed]] > 0} { - set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch - set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits - set rhs [string trimleft $rhs 0] - if {$rhs eq ""} { - set rhs 0 - } - lappend newparts ${lhs}a${rhs} - } elseif {[set bpos [string first b $trimmed]] > 0} { - set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch - set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits - set rhs [string trimleft $rhs 0] - if {$rhs eq ""} { - set rhs 0 - } - lappend newparts ${lhs}b${rhs} - } else { - #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b - error "tm_version_canonical error - trimfail - unexpected" - } - } - } - } - } - return [join $newparts .] - } - proc tm_version_required_canonical {versionspec} { - #also trim leading zero from any dottedpart? - #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. - #e.g 1.01 is equivalent to 1.1 and 01.001 - #also 1b3 == 1b0003 - - if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "tm_version_required_canonical - invalid version specification" - if {[string first - $versionspec] < 0} { - #no dash - #looks like a minbounded version (ie a single version with no dash) convert to min-max form - set from $versionspec - if {![tm_version_isvalid $from]} { - error "$errmsg '$versionpec'" - } - if {![catch {tm_version_major $from} majorv]} { - set from [tm_version_canonical $from] - return "${from}-[expr {$majorv +1}]" - } else { - error "$errmsg '$versionspec'" - } - } else { - # min- or min-max - #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) - set parts [split $versionspec -] ;#we expect only 2 parts - lassign $parts from to - if {![tm_version_isvalid $from]} { - error "$errmsg '$versionspec'" - } - set from [tm_version_canonical $from] - if {[llength $parts] == 2} { - if {$to ne ""} { - if {![tm_version_isvalid $to]} { - error "$errmsg '$versionspec'" - } - set to [tm_version_canonical $to] - return $from-$to - } else { - return $from- - } - } else { - error "$errmsg '$versionspec'" - } - error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" - } - } - # end tm_version... functions - # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == - - #convenience function in case the sequence 'package forget packagetrace;package require packagetrace' is too unintuitive or weird. - #REVIEW - proc unload {} { - package forget packagetrace - if {[catch {package require packagetrace}]} { - return 1 ;#yes - we get an error if we unloaded successfully - } else { - error "packagetrace was not unloaded" - } - } - proc emit {str} { - variable chan - variable output - append output $str - if {$chan ne "none"} { - puts -nonewline $chan $str - } - return - } - proc get {{as raw}} { - variable output - switch -- [string tolower $as] { - asxml { - if {[package provide tdom] eq ""} { - set previous_output $output - package require tdom - set output $previous_output - } - set d [dom parse $output] - return [$d asXML] - } - aslist { - if {[package provide tdom] eq ""} { - set previous_output $output - package require tdom - set output $previous_output - } - set d [dom parse $output] - return [$d asList] - } - default { - return $output - } - } - } - proc channel {{ch ""}} { - variable chan - switch -exact -- $ch { - "" { - return $chan - } - none { - set chan none - return none - } - stderr - stdout { - #note stderr stdout not necessarily in [chan names] (due to transforms etc?) but can still work - set chan $ch - return $ch - } - default { - if {$ch in [chan names]} { - set chan $ch - return $ch - } else { - error "chan '$ch' not in \[chan names\]: [chan names]" - } - } - } - } - proc init {} { - uplevel 1 { - set ::packagetrace::level -1 - if {![llength [info commands tcl_findLibrary]]} { - tcl::namespace::eval :: $::auto_index(tcl_findLibrary) - } - package require commandstack - - - set targetcommand [namespace which tcl_findLibrary] ;# normalize to presumably ::tcl_findLibrary - set stackrecord [commandstack::rename_command -renamer packagetrace $targetcommand [info args $targetcommand] { - set marg [string repeat { } $::packagetrace::level] - packagetrace::emit "${marg} tcl_findLibrary $basename $version $patch $initScript $enVarName $varName \n" - uplevel 1 [list $COMMANDSTACKNEXT $basename $version $patch $initScript $enVarName $varName] - }] - if {[dict get $stackrecord implementation] ne ""} { - set old_tcl_findLibrary [dict get $stackrecord implementation] - puts stderr "packagetrace::init renamed $targetcommand to $old_tcl_findLibrary and is providing an override" - } else { - puts stderr "packagetrace::init failed to rename $targetcommand" - } - - - - set package_command [namespace which package] - set stackrecord [commandstack::rename_command -renamer packagetrace $package_command {subcommand args} { - set tracerlist $::packagetrace::tracerlist - set tracer [lindex $tracerlist end] - if {$tracer eq ""} { - - } - set ch $::packagetrace::chan - set next $COMMANDSTACKNEXT - if {$next ne "$COMMANDSTACKNEXT_ORIGINAL"} { - puts stderr "(packagetrace package) DEBUG - command changed since start: $COMMANDSTACKNEXT_ORIGINAL is now $next" - } - - #cache $ch instead of using upvar, - #because namespace may be deleted during call. - - #!todo - optionally silence Tcl & Tk requires to reduce output? - #if {[lindex $args 0] eq "Tcl"} { - # return [$next $subcommand {*}$args] - #} - switch -exact -- [tcl::prefix::match {files forget ifneeded names prefer present provide require unknown vcompare versions vsatisfies} $subcommand] { - require { - #columns - set c1 [string repeat { } 30] ;#tree col - set c1a " " - set c2 [string repeat { } 20] ;#package name col - set c2a " " ;# close require/present tags - set c3 [string repeat { } 18] ;#version col - must handle v= "999999.0a1.0" without truncation - set c4 [string repeat { } 12] ;#timing col 5 chars of punct leaving remainder for value. - set c5 [string repeat { } 10] ;#module col - set c5a [string repeat { } 3] ;#close result tag col - - #we assume 'package require' API sticks to solo option flags like -exact and is relatively stable. - set argidx 0 - set is_exact 0 - foreach a $args { - if {[string range $a 0 0] ne "-"} { - #assume 1st non-dashed argument is package name - set pkg $a - set v_requirements [lrange $args $argidx+1 end] - #normalize - if {$is_exact} { - set req [lindex $v_requirements 0] ;#only one is allowed for -exact - set v_requirements $req-$req ;#translate to v-v normalised equiv of -exact - } else { - set reqs [list] - foreach req $v_requirements { - lappend reqs [::packagetrace::tm_version_required_canonical $v_requirement] ;#empty remains empty, v -> v-, leading zeros stripped from all segments. - } - set v_requirements $reqs ;#each normalised - } - set pkg_ [lrange $args $argidx end] ;# raw e.g "Tcl 8.6" or "Tcl 8.5 9" - break - } else { - if {$a eq "-exact"} { - set is_exact 1 - } - } - incr argidx - } - - - incr ::packagetrace::level - if {$::packagetrace::level == 0} { - set packagetrace::output "" - } - - - set marg [string repeat { } $::packagetrace::level] - set margnext [string repeat { } [expr {$::packagetrace::level + 1}]] - - if {![catch {set ver [$next present {*}$args]}]} { - if {$::packagetrace::showpresent} { - #already loaded.. - set f1 [packagetrace::overtype::left $c1 "${marg} " - #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n - packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n - } - } else { - set f1 [packagetrace::overtype::left $c1 "${marg} " - #puts -nonewline $ch $f1$c1a$f2$f2a$f3$f4$f5\n - packagetrace::emit $f1$c1a$f2$f2a$f3$f4$f5$f5a\n - - set errMsg "" - #set t0 [clock clicks -milliseconds] - set t0 [clock microseconds] - - if {[catch {set ver [$next require {*}$args]} errMsg]} { - set ver "" - # - #NOTE error must be raised at some point - see below - } - #set t [expr {[clock clicks -millisec]-$t0}] - set t [expr {([clock microseconds]-$t0)/1000.0}] - - - - - #jmn - set f1 [packagetrace::overtype::left $c1 "${margnext} [expr {[string length $c4]}]} { - set f4 "[packagetrace::overtype::left [string range $c4 0 end-1] [string trimright $f4]]\"" - } - - if {[string length $ver]} { - set num "" - foreach c [split $ver ""] { - if {[string is digit $c] || $c eq "."} { - append num $c - } else { - break - } - } - set ver $num - - #review - scr not guaranteed to be valid tcl list - should parse properly? - set scr [$next ifneeded $pkg $ver] - if {[string range $scr end-2 end] ne ".tm"} { - set f5 $c5 - } else { - #!todo - optionally output module path instead of boolean? - #set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"[lindex $scr end]"] - set f5 [packagetrace::overtype::left -ellipsis 1 -ellipsistext ... [string range $c5 0 end-1] "tm= \"1"] - if {[string length [string trimright $f5]] <= [expr [string length $c5]-1]} { - set f5 [packagetrace::overtype::left $c5 [string trimright $f5]\"] - } - } - } else { - set f5 $c5 - } - - set f5a [packagetrace::overtype::left $c5a "/>"] ;#end of "] - set f1a "" - set f2 "" - set c2a "" - set f3 "" - set f4 "" - set f5 "" - set f5a "" - #puts -nonewline $ch $f1$f1a$f2$c2a$f3$f4$f5$f5a\n - packagetrace::emit $f1$f1a$f2$c2a$f3$f4$f5$f5a\n - - - if {![string length $ver]} { - if {[lindex $args 0] eq "packagetrace"} { - #REVIEW - what is going on here? - namespace delete ::packagetrace::overtype - } - - #we must raise an error if original 'package require' would have - incr ::packagetrace::level -1 - error $errMsg - } - - } - incr ::packagetrace::level -1 - return $ver - } - vcompare - vsatisifies - provide - ifneeded { - set result [$next $subcommand {*}$args] - #puts -nonewline $ch " -- package $subcommand $args\n" - return $result - } - default { - set result [$next $subcommand {*}$args] - #puts $ch "*** here $subcommand $args" - return $result - } - } - - }] - if {[set stored_target [dict get $stackrecord implementation]] ne ""} { - puts stderr "packagetrace::init renamed $package_command to $stored_target and is providing an override" - set f1 [string repeat { } 30] - #set f1a " " - set f1a "" - set f2 [packagetrace::overtype::left [string repeat { } 20] "PACKAGE"] - set f2a " " - set f3 [packagetrace::overtype::left [string repeat { } 15] "VERSION"] - set f4 [packagetrace::overtype::left [string repeat { } 12] "LOAD-ms"] - set f5 [packagetrace::overtype::left [string repeat { } 10] "MODULE"] - - #puts -nonewline $::packagetrace::chan "-$f1$f1a$f2$f2a$f3$f4$f5\n" - #packagetrace::emit "-$f1$f1a$f2$f2a$f3$f4$f5\n" - puts -nonewline stderr "-$f1$f1a$f2$f2a$f3$f4$f5\n" - unset f1 f1a f2 f2a f3 f4 f5 - } else { - puts stderr "packagetrace::init failed to rename $package_command" - } - } - } -} - - - -#The preferred source of the ::overtype:: functions is the 'overtype' package -# - pasted here because packagetrace should have no extra dependencies. -# - overtype package has better support for ansi and supports wide chars -namespace eval packagetrace::overtype {set version INLINE} - -namespace eval packagetrace::overtype { - proc left {args} { - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-ellipsis) 0 - set opt(-ellipsistext) {...} - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set len [string length $undertext] - set overlen [string length $overtext] - set diff [expr {$overlen - $len}] - if {$diff > 0} { - if {$opt(-overflow)} { - return $overtext - } else { - if {$opt(-ellipsis)} { - return [right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)] - } else { - return [string range $overtext 0 [expr {$len -1}]] - } - } - } else { - - return "$overtext[string range $undertext $overlen end]" - } - } - - proc centre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - foreach {undertext overtext} [lrange $args end-1 end] break - - set opt(-bias) left - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - - set olen [string length $overtext] - set ulen [string length $undertext] - set diff [expr {$ulen - $olen}] - if {$diff > 0} { - set half [expr {round(int($diff / 2))}] - if {[string match right $opt(-bias)]} { - if {[expr {2 * $half}] < $diff} { - incr half - } - } - - set rhs [expr {$diff - $half - 1}] - set lhs [expr {$half - 1}] - - set a [string range $undertext 0 $lhs] - set b $overtext - set c [string range $undertext end-$rhs end] - return $a$b$c - } else { - if {$diff < 0} { - if {$opt(-overflow)} { - return $overtext - } else { - return [string range $overtext 0 [expr {$ulen - 1}]] - } - } else { - return $overtext - } - } - } - - proc right {args} { - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? undertext overtext} - } - lassign [lrange $args end-1 end] undertext overtext - - set opt(-overflow) 0 - array set opt [lrange $args 0 end-2] - - set olen [string length $overtext] - set ulen [string length $undertext] - - if {$opt(-overflow)} { - return [string range $undertext 0 end-$olen]$overtext - } else { - if {$olen > $ulen} { - set diff [expr {$olen - $ulen}] - return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff] - } else { - return [string range $undertext 0 end-$olen]$overtext - } - } - } - -} - - - - - -proc packagetrace::deinit {} { - packagetrace::disable - #namespace delete packagetrace - #package forget packagetrace -} -proc packagetrace::disable {} { - ::commandstack::remove_rename {::tcl_findLibrary packagetrace} - ::commandstack::remove_rename {::package packagetrace} -} -proc packagetrace::enable {} { - #init doesn't clear state - so this is effectively an alias - tailcall packagetrace::init -} - -#clear state - reset to defaults -proc packagetrace::clear {} { - variable chan - set chan stderr - variable showpresent - set showpresent 1 -} - -package provide packagetrace [namespace eval packagetrace { - set version 0.8 -}] - - diff --git a/src/vendormodules/uuid-1.0.9.tm b/src/vendormodules/uuid-1.0.9.tm new file mode 100644 index 00000000..dd6d3cd5 --- /dev/null +++ b/src/vendormodules/uuid-1.0.9.tm @@ -0,0 +1,245 @@ +# uuid.tcl - Copyright (C) 2004 Pat Thoyts +# +# UUIDs are 128 bit values that attempt to be unique in time and space. +# +# Reference: +# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt +# +# uuid: scheme: +# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html +# +# Usage: uuid::uuid generate +# uuid::uuid equal $idA $idB + +package require Tcl 8.5 9 + +namespace eval uuid { + variable accel + array set accel {critcl 0} + + namespace export uuid + + variable uid + if {![info exists uid]} { + set uid 1 + } + + proc K {a b} {set a} +} + +### +# Optimization +# Caches machine info after the first pass +### + +proc ::uuid::generate_tcl_machinfo {} { + variable machinfo + if {[info exists machinfo]} { + return $machinfo + } + lappend machinfo [clock seconds]; # timestamp + lappend machinfo [clock clicks]; # system incrementing counter + lappend machinfo [info hostname]; # spatial unique id (poor) + lappend machinfo [pid]; # additional entropy + lappend machinfo [array get ::tcl_platform] + + ### + # If we have /dev/urandom just stream 128 bits from that + ### + if {[file exists /dev/urandom]} { + set fin [open /dev/urandom rb] + binary scan [read $fin 128] H* machinfo + close $fin + } elseif {[catch {package require nettool}]} { + # More spatial information -- better than hostname. + # bug 1150714: opening a server socket may raise a warning messagebox + # with WinXP firewall, using ipconfig will return all IP addresses + # including ipv6 ones if available. ipconfig is OK on win98+ + if {[string equal $::tcl_platform(platform) "windows"]} { + catch {exec ipconfig} config + lappend machinfo $config + } else { + catch { + set s [socket -server void -myaddr [info hostname] 0] + K [fconfigure $s -sockname] [close $s] + } r + lappend machinfo $r + } + + if {[package provide Tk] != {}} { + lappend machinfo [winfo pointerxy .] + lappend machinfo [winfo id .] + } + } else { + ### + # If the nettool package works on this platform + # use the stream of hardware ids from it + ### + lappend machinfo {*}[::nettool::hwid_list] + } + return $machinfo +} + +# Generates a binary UUID as per the draft spec. We generate a pseudo-random +# type uuid (type 4). See section 3.4 +# +proc ::uuid::generate_tcl {} { + package require md5 2 + variable uid + + set tok [md5::MD5Init] + md5::MD5Update $tok [incr uid]; # package incrementing counter + foreach string [generate_tcl_machinfo] { + md5::MD5Update $tok $string + } + set r [md5::MD5Final $tok] + binary scan $r c* r + + # 3.4: set uuid versioning fields + lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] + lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] + + return [binary format c* $r] +} + +if {[string equal $tcl_platform(platform) "windows"] + && [package provide critcl] != {}} { + namespace eval uuid { + critcl::ccode { + #define WIN32_LEAN_AND_MEAN + #define STRICT + #include + #include + typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); + typedef const unsigned char cu_char; + } + critcl::cproc generate_c {Tcl_Interp* interp} ok { + HRESULT hr = S_OK; + int r = TCL_OK; + UUID uuid = {0}; + HMODULE hLib; + LPFNUUIDCREATE lpfnUuidCreate = NULL; + hLib = LoadLibraryA(("rpcrt4.dll")); + if (hLib) + lpfnUuidCreate = (LPFNUUIDCREATE) + GetProcAddress(hLib, "UuidCreate"); + if (lpfnUuidCreate) { + Tcl_Obj *obj; + lpfnUuidCreate(&uuid); + obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); + Tcl_SetObjResult(interp, obj); + } else { + Tcl_SetResult(interp, "error: failed to create a guid", + TCL_STATIC); + r = TCL_ERROR; + } + return r; + } + } +} + +# Convert a binary uuid into its string representation. +# +proc ::uuid::tostring {uuid} { + binary scan $uuid H* s + foreach {a b} {0 7 8 11 12 15 16 19 20 end} { + append r [string range $s $a $b] - + } + return [string tolower [string trimright $r -]] +} + +# Convert a string representation of a uuid into its binary format. +# +proc ::uuid::fromstring {uuid} { + return [binary format H* [string map {- {}} $uuid]] +} + +# Compare two uuids for equality. +# +proc ::uuid::equal {left right} { + set l [fromstring $left] + set r [fromstring $right] + return [string equal $l $r] +} + +# Call our generate uuid implementation +proc ::uuid::generate {} { + variable accel + if {$accel(critcl)} { + return [generate_c] + } else { + return [generate_tcl] + } +} + +# uuid generate -> string rep of a new uuid +# uuid equal uuid1 uuid2 +# +proc uuid::uuid {cmd args} { + switch -exact -- $cmd { + generate { + if {[llength $args] != 0} { + return -code error "wrong # args:\ + should be \"uuid generate\"" + } + return [tostring [generate]] + } + equal { + if {[llength $args] != 2} { + return -code error "wrong \# args:\ + should be \"uuid equal uuid1 uuid2\"" + } + return [eval [linsert $args 0 equal]] + } + default { + return -code error "bad option \"$cmd\":\ + must be generate or equal" + } + } +} + +# ------------------------------------------------------------------------- + +# LoadAccelerator -- +# +# This package can make use of a number of compiled extensions to +# accelerate the digest computation. This procedure manages the +# use of these extensions within the package. During normal usage +# this should not be called, but the test package manipulates the +# list of enabled accelerators. +# +proc ::uuid::LoadAccelerator {name} { + variable accel + set r 0 + switch -exact -- $name { + critcl { + if {![catch {package require tcllibc}]} { + set r [expr {[info commands ::uuid::generate_c] != {}}] + } + } + default { + return -code error "invalid accelerator package:\ + must be one of [join [array names accel] {, }]" + } + } + set accel($name) $r +} + +# ------------------------------------------------------------------------- + +# Try and load a compiled extension to help. +namespace eval ::uuid { + variable e {} + foreach e {critcl} { + if {[LoadAccelerator $e]} break + } + unset e +} + +package provide uuid 1.0.9 + +# ------------------------------------------------------------------------- +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/src/vfs/_vfscommon.vfs/modules/modpodtest-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/modpodtest-0.1.0.tm index 55decf05700f9df828a91b3b38cb2f23e1916696..a2966397b32eb48991f4f2bf39c0cb4b29cc1fa1 100644 GIT binary patch delta 1607 zcmV-N2Dth4NQ6nS=@|h9lZ+!U1^@p6006TZ8W#fr29t~<8wYy-{{jF20h3N0MiV=! z99yRf@-m49003nZ001li29t~<8k0;U6Mz5z0ssI3wOCPa+cpq>*RQzQ1G=TNl61qc zc}3ea-9vz-E0(+&LO@Gro3Ko(B<0vK{NHy+O15kzZJe}10^8*A?z`iC$D_K?JL-W; zbN-CFa4Dp6sDw%pE|hhqOr6xK4>^iCf}0@x>7RJ9Si}nu7NiBCGAJ!VQL3q(V1J&& ziwx&56H|Nv+Q3k%W1iyy0H>iWGT{(LM$h1NF&)3@4NIA4b2OH$#ctsU%S>lwPBw8? z}FAyw0|Ox2y&{Gl^Ghs zFVz?XyubRukS{N;!MY{c&t-~=B!5RVIyT7G94(s_!pWh`rCY+SbQ2$&YYHT$+Ab~G zj>*co&ahHl7#yK7n0cv6tA$i37$RUU$8wklGg75_$&sLMES<~YFK|7j4S%qVS<8o z?!e_oM@R5Ots?3UW<*#>^PmgxUkC!n&woDKp)I-$3kp4| zRAK{R#Z}9NGK1lA*STC;SEZn&(jo6KOQLAY@3323IR1!#@3qbIq67x@f>k9+$wQ8H z_w`WS9p3T8o*HN?@}geNzDW<698JDiG7w*qgR6no{eGGYYe5mUECI&@RZ!9D_cx3C zeVmKDu{*W;Rm6nb1Ap&_nw!7+SSxC)pfCpckP$&`h9jvYudTGn5v&FtlT;&iju=jb z!opx5Xj;;7qFlm~4$X)LZ>*p*4^I=o&(P_tE7T7l4`>>>hpL>Rp(BoWbtBP;aq161 zXxVGp`J%PTCL2oN{GYR{E2?2$b=!y5ss_?V*mj`uGebAgRDW5yXs?7BpRQZ*z6voI zOa=8a9^O4M_Vu@6i)cf}fDINWAA(?}_!{E9Id|t(MfH z(1s=lqIZ`Zt$zXj;$~1$n;QD*YM%2e*SBa=LKvbk7e@M?V6nW5o?dhIip{w;z9E58 zsnW3H+-Wxah`z$H3QJ*h3LDlJr=U3FZB4Q6Lx3BE8W0B96e>@eqW+@jQx_CC9r_pw zc8PHuuPaJ*8%{O*9qJZpP%Sw)Gvm^q^8Lmfv$x@_sDEXWJsFy~p-6x;zKcJt8?dvT zMvd(UiCPhf#t*1su8rx=p^^tw)dCw`D!vc7KYcgj23=_sbo8_XHL*6^c3%p8iLlMm zpzcYpiob{Q_E6$p(QQg)!YqC6ejf(+`+Twb#x&knM7PCB`vj--x zTdunaU4ID37`34Umokj+kQ~zJ5hrWleChmUH<12N$`i_d-}Am!(F)W<=Fl8 zQ?6?wTaw+)wTRMkF0-AgG9~0j+aQ^%-bVRBi?041-U2{GQ3$yfJ^WH3 zT#x<-P)h*<6abUa85#=!0000000000005IP9UYUWBN+h{lffe)1^@s608ImvF&!N% zP)h*<6aW+e00;;GJEr9zCsnrm2 z6bl45MflS{gXMBLSc0%1EeMrCX%UK2&FmEO9G+#kfPcA|;WN+%Mp7N~91j3E4P}uD zhcGsJ4lj$@k*RwZapnozr8T>kM^G=Vne;|(ta;lY;85+Vb)dU2*y?V!xFE2iVbt|%;%M=w! zj%jpakbkW?S~f3)lOvf+w}M;gram?wDUg_IyRu|^KvvFmhL!5V;24d;%u7{TEu=!h z2my0Bk)u4Akt)qgjs$&U>0FL}fsZr#@S$c)>?jl>orwv8!9rWS%qVTyuw?!e_oM@R5Ot)kPro(ok_3~xs4 z^Df1zoVkhJ4vr_ZDAmQv$jQ_}mxI^kF(+M)8QK)qmmzb{K3r@P0Fs{1Q8`%m`|w`O z5q~UtR)x(Jyz6?*nMllY7FdUog_r2}H>{gb1kHU`7(IKs-$e_B17Za0W$%2bI0;!F zkV1o>N@+0KRW>uj)vY#}t*FOC5g7hi2qO~cAGl}jsMitrmngrGc)QcBs}Y92L&r9`peI3qj!c*(W=+Lw}cHL7_*LN{kRzT(w*%GZ?M*oy(Af6lJ1sD^pf zZ68{zBBW8+_Mq}JM>o|}S-EJhg@2ixZd&jjg%}K`f_fPb@17X@`Wx9I+K@3|gGm#6 zyzd@YSa*+9QPL66^;rWyvaW7JXw!7}kx*}Wx_?;k=@1369sW)1Lu~Z3dDJo#EQKwu z(<_{8{hAM(4*wliLk=qvZ@Ja`%KGp~d8ksWCABQHp~-8}ze|ob0Do~asDG$U4gGXA z&-s<>TQn&l4AEE!BYjV>T-|lPzUDNF&AB$dA%StJ(y-&)X-0l@9^qJpr7${$E$fR@ zP@M6$rdaPGz!9OY2?J~kl_yP6e^KK1BHEjc(d zlhU8^!)T7#8#ya#nWP~@6Mr`p32?@D@uzhIcDC23vHc)XD+#b_3}Tr97b=4n6N{H8Jr$;a@ix|N09kzs1yI!D&o^@4|qPHeX4DCth0XoVega zTZugRf-W|^lz3Vj8+0`Ctp;&lx+(42DaY;~7_o3&6WNOFZm&g@mJ6BfRizfg?mw-! zXKXQ>#22x>x$13{9~`vk>fhll0CXq{A=mD?(bO*$!u9BXP)h*<7XXvd85j-#00000 z0096X0Jebu0Fyu@8BqKO{c}k_i9+000UI@;m?l diff --git a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm index 75d36319..c8195b6e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm @@ -2788,7 +2788,7 @@ tcl::namespace::eval punk::char::lib { proc superscript_number {n} { if {$n eq ""} {return ""} variable num_superscript - variable num_super_re + variable num_supersub_re if {![regexp $num_supersub_re $n]} { error "Cannot convert string '$n' to superscript. valid chars: [dict keys $num_superscript]" } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm index afd06d2a..17c9918b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm @@ -759,7 +759,7 @@ namespace eval punk::mix::cli { } } else { - puts -nonewline stderr "P" + puts -nonewline stderr "Z" set did_skip 1 #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $build_event targetset_end SKIPPED @@ -791,7 +791,7 @@ namespace eval punk::mix::cli { $event targetset_end OK -note "zip modpod" } } else { - puts -nonewline stderr "p" + puts -nonewline stderr "z" set did_skip 1 if {$is_interesting} { puts stderr "$modulefile [$event targetset_source_changes]" @@ -802,7 +802,8 @@ namespace eval punk::mix::cli { } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar ? + } file { set m $modpath diff --git a/src/vfs/_vfscommon.vfs/modules/uuid-1.0.9.tm b/src/vfs/_vfscommon.vfs/modules/uuid-1.0.9.tm new file mode 100644 index 00000000..dd6d3cd5 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/uuid-1.0.9.tm @@ -0,0 +1,245 @@ +# uuid.tcl - Copyright (C) 2004 Pat Thoyts +# +# UUIDs are 128 bit values that attempt to be unique in time and space. +# +# Reference: +# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt +# +# uuid: scheme: +# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html +# +# Usage: uuid::uuid generate +# uuid::uuid equal $idA $idB + +package require Tcl 8.5 9 + +namespace eval uuid { + variable accel + array set accel {critcl 0} + + namespace export uuid + + variable uid + if {![info exists uid]} { + set uid 1 + } + + proc K {a b} {set a} +} + +### +# Optimization +# Caches machine info after the first pass +### + +proc ::uuid::generate_tcl_machinfo {} { + variable machinfo + if {[info exists machinfo]} { + return $machinfo + } + lappend machinfo [clock seconds]; # timestamp + lappend machinfo [clock clicks]; # system incrementing counter + lappend machinfo [info hostname]; # spatial unique id (poor) + lappend machinfo [pid]; # additional entropy + lappend machinfo [array get ::tcl_platform] + + ### + # If we have /dev/urandom just stream 128 bits from that + ### + if {[file exists /dev/urandom]} { + set fin [open /dev/urandom rb] + binary scan [read $fin 128] H* machinfo + close $fin + } elseif {[catch {package require nettool}]} { + # More spatial information -- better than hostname. + # bug 1150714: opening a server socket may raise a warning messagebox + # with WinXP firewall, using ipconfig will return all IP addresses + # including ipv6 ones if available. ipconfig is OK on win98+ + if {[string equal $::tcl_platform(platform) "windows"]} { + catch {exec ipconfig} config + lappend machinfo $config + } else { + catch { + set s [socket -server void -myaddr [info hostname] 0] + K [fconfigure $s -sockname] [close $s] + } r + lappend machinfo $r + } + + if {[package provide Tk] != {}} { + lappend machinfo [winfo pointerxy .] + lappend machinfo [winfo id .] + } + } else { + ### + # If the nettool package works on this platform + # use the stream of hardware ids from it + ### + lappend machinfo {*}[::nettool::hwid_list] + } + return $machinfo +} + +# Generates a binary UUID as per the draft spec. We generate a pseudo-random +# type uuid (type 4). See section 3.4 +# +proc ::uuid::generate_tcl {} { + package require md5 2 + variable uid + + set tok [md5::MD5Init] + md5::MD5Update $tok [incr uid]; # package incrementing counter + foreach string [generate_tcl_machinfo] { + md5::MD5Update $tok $string + } + set r [md5::MD5Final $tok] + binary scan $r c* r + + # 3.4: set uuid versioning fields + lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] + lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] + + return [binary format c* $r] +} + +if {[string equal $tcl_platform(platform) "windows"] + && [package provide critcl] != {}} { + namespace eval uuid { + critcl::ccode { + #define WIN32_LEAN_AND_MEAN + #define STRICT + #include + #include + typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); + typedef const unsigned char cu_char; + } + critcl::cproc generate_c {Tcl_Interp* interp} ok { + HRESULT hr = S_OK; + int r = TCL_OK; + UUID uuid = {0}; + HMODULE hLib; + LPFNUUIDCREATE lpfnUuidCreate = NULL; + hLib = LoadLibraryA(("rpcrt4.dll")); + if (hLib) + lpfnUuidCreate = (LPFNUUIDCREATE) + GetProcAddress(hLib, "UuidCreate"); + if (lpfnUuidCreate) { + Tcl_Obj *obj; + lpfnUuidCreate(&uuid); + obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); + Tcl_SetObjResult(interp, obj); + } else { + Tcl_SetResult(interp, "error: failed to create a guid", + TCL_STATIC); + r = TCL_ERROR; + } + return r; + } + } +} + +# Convert a binary uuid into its string representation. +# +proc ::uuid::tostring {uuid} { + binary scan $uuid H* s + foreach {a b} {0 7 8 11 12 15 16 19 20 end} { + append r [string range $s $a $b] - + } + return [string tolower [string trimright $r -]] +} + +# Convert a string representation of a uuid into its binary format. +# +proc ::uuid::fromstring {uuid} { + return [binary format H* [string map {- {}} $uuid]] +} + +# Compare two uuids for equality. +# +proc ::uuid::equal {left right} { + set l [fromstring $left] + set r [fromstring $right] + return [string equal $l $r] +} + +# Call our generate uuid implementation +proc ::uuid::generate {} { + variable accel + if {$accel(critcl)} { + return [generate_c] + } else { + return [generate_tcl] + } +} + +# uuid generate -> string rep of a new uuid +# uuid equal uuid1 uuid2 +# +proc uuid::uuid {cmd args} { + switch -exact -- $cmd { + generate { + if {[llength $args] != 0} { + return -code error "wrong # args:\ + should be \"uuid generate\"" + } + return [tostring [generate]] + } + equal { + if {[llength $args] != 2} { + return -code error "wrong \# args:\ + should be \"uuid equal uuid1 uuid2\"" + } + return [eval [linsert $args 0 equal]] + } + default { + return -code error "bad option \"$cmd\":\ + must be generate or equal" + } + } +} + +# ------------------------------------------------------------------------- + +# LoadAccelerator -- +# +# This package can make use of a number of compiled extensions to +# accelerate the digest computation. This procedure manages the +# use of these extensions within the package. During normal usage +# this should not be called, but the test package manipulates the +# list of enabled accelerators. +# +proc ::uuid::LoadAccelerator {name} { + variable accel + set r 0 + switch -exact -- $name { + critcl { + if {![catch {package require tcllibc}]} { + set r [expr {[info commands ::uuid::generate_c] != {}}] + } + } + default { + return -code error "invalid accelerator package:\ + must be one of [join [array names accel] {, }]" + } + } + set accel($name) $r +} + +# ------------------------------------------------------------------------- + +# Try and load a compiled extension to help. +namespace eval ::uuid { + variable e {} + foreach e {critcl} { + if {[LoadAccelerator $e]} break + } + unset e +} + +package provide uuid 1.0.9 + +# ------------------------------------------------------------------------- +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm b/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm index 1983211c4274a86b312dfaeee4ea996e1b9ac7e1..99a566c7b8c867e67a04e4b22e3ace38a2be6d18 100644 GIT binary patch delta 217 zcmez5^TTJu6-faO4hHL$GST~t)8iL&GB9Lrej=I9S#Qhy&u#OAS5u|;NH{y~R{Vd{ zx$PF8ll7F_%Z0So25x;>QTu1|;?t)88Fp0q3M*HaMwF*(p7Ykdo~Tzn@7&z%TQ^E$ zw~9K*&Ef8kda9*jA$q}Rn*EwJU82+a=5Af#k$N=lNkctzfHyOX2m=Gq1vVweb(XJc zUwV#_fgy*Pfq_|(fo-ytniAXp|4a-FjGNypUuVQ{>Evsw4vZX=#nluTA5XSWGhzG2 H%>V=dQ<709 delta 220 zcmez2^T}t!6-f~W4u*-!1yP%mB{$FGWMGh$WnfU6{7zMMGq02#XT3Gkx%GEEj=m5O z;{E9_YSdAdb=&b)oZ+G)D{i^$w%c@4@S#;L!-PG2or!y_M0S7Xe;zsQwZU{-|AXh| z=Iq(&cY{lT|J+-*wMC+nCUIp*o|bnGJIdvK{G5Bpl1)kakG|ax@MdNaVPF6{!lvZ7 z&hl05OV2SfFyt^ZFeoyxGAK`WQd404{~su{`K$7EMgerkPQIh+z{oIJR!xEN-efy9 L6SfcBK*JaSk%ds4