From 4b0ac4d3a72484d03c3c6b324790f5e60b4f0655 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Wed, 24 Dec 2025 12:27:07 +1100 Subject: [PATCH] update bootsupport and project_layouts with recent fixes --- .../custom/_project/punk.basic/src/make.tcl | 10 +- .../bootsupport/modules/commandstack-0.4.tm | 518 ++ .../modules/include_modules.config | 3 + .../src/bootsupport/modules/overtype-1.7.4.tm | 5267 +++++++++++++++++ .../bootsupport/modules/punk/ansi-0.1.1.tm | 14 +- .../modules/punk/ansi/sauce-0.1.0.tm | 628 ++ .../bootsupport/modules/punk/args-0.2.1.tm | 2 +- .../modules/punk/libunknown-0.1.tm | 10 +- .../bootsupport/modules/punk/nav/ns-0.1.0.tm | 302 + .../modules/punk/packagepreference-0.1.0.tm | 47 +- .../_project/punk.project-0.1/src/make.tcl | 10 +- .../bootsupport/modules/commandstack-0.4.tm | 518 ++ .../modules/include_modules.config | 3 + .../src/bootsupport/modules/overtype-1.7.4.tm | 5267 +++++++++++++++++ .../bootsupport/modules/punk/ansi-0.1.1.tm | 14 +- .../modules/punk/ansi/sauce-0.1.0.tm | 628 ++ .../bootsupport/modules/punk/args-0.2.1.tm | 2 +- .../modules/punk/libunknown-0.1.tm | 10 +- .../bootsupport/modules/punk/nav/ns-0.1.0.tm | 302 + .../modules/punk/packagepreference-0.1.0.tm | 47 +- .../_project/punk.shell-0.1/src/make.tcl | 10 +- .../_vfscommon.vfs/lib/vfszip/pkgIndex.tcl | 53 + src/vfs/_vfscommon.vfs/lib/vfszip/zipvfs.tcl | 937 +++ .../modules/commandstack-0.4.tm | 518 ++ .../_vfscommon.vfs/modules/overtype-1.7.4.tm | 41 + .../_vfscommon.vfs/modules/punk/ansi-0.1.1.tm | 14 +- .../modules/punk/ansi/sauce-0.1.0.tm | 68 +- .../_vfscommon.vfs/modules/punk/args-0.2.1.tm | 2 +- .../modules/punk/libunknown-0.1.tm | 10 +- .../modules/punk/packagepreference-0.1.0.tm | 47 +- 30 files changed, 15106 insertions(+), 196 deletions(-) create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.4.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.4.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.4.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.4.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm create mode 100644 src/vfs/_vfscommon.vfs/lib/vfszip/pkgIndex.tcl create mode 100644 src/vfs/_vfscommon.vfs/lib/vfszip/zipvfs.tcl create mode 100644 src/vfs/_vfscommon.vfs/modules/commandstack-0.4.tm diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index 9ae26516..5dc72254 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -738,7 +738,7 @@ proc ::punkboot::check_package_availability {args} { lappend ::test::pkg_missing $pkgrequest } } else { - if {$pkgrequest ni $::test_pkg_broken} { + if {$pkgrequest ni $::test::pkg_broken} { lappend ::test::pkg_broken $pkgrequest } @@ -1481,12 +1481,12 @@ if {$::punkboot::command eq "check"} { } } flush stdout - set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] + set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { lassign $pkg_request pkgname vrequest package require $pkgname {*}$vrequest ;#todo? } - flush stderr + flush stderr #punk::lib::showdict -channel stderr $::punkboot::pkg_availability set missing_out [::punkboot::get_display_missing_packages $::punkboot::pkg_availability] puts stdout $missing_out\n @@ -1566,7 +1566,9 @@ if {$::punkboot::command eq "check"} { set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { lassign $pkg_request pkgname vrequest - catch {package require $pkgname {*}$vrequest} ;#todo + if {[catch {package require $pkgname {*}$vrequest} errM]} { + puts stderr "failed to load $pkgname\n - $errM\n - $::errorInfo" + } } flush stderr #punk::lib::showdict -channel stderr $::punkboot::pkg_availability diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.4.tm new file mode 100644 index 00000000..19c21289 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/commandstack-0.4.tm @@ -0,0 +1,518 @@ + + +#JMN 2021 - Public Domain +#cooperative command renaming +# +# REVIEW 2024 - code was originally for specific use in packageTrace +# - code should be reviewed for more generic utility. +# - API is obscure and undocumented. +# - unclear if intention was only for builtins +# - consider use of newer 'info cmdtype' - (but need also support for safe interps) +# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. +# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename +#changes: +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#2021-09-18 +# - initial version +# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command +# - They need to be able to load and unload in any order. +# + +#strive for no other package dependencies here. + + +namespace eval commandstack { + variable all_stacks + variable debug + set debug 0 + variable known_renamers [list ::packagetrace ::packageSuppress] + if {![info exists all_stacks]} { + #don't wipe it + set all_stacks [dict create] + } +} + +namespace eval commandstack::util { + #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. + #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace + #A magic comment was chosen as the identifying method. + #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. + + #return unspecified if the command is a proc with a body but no magic comment ID + #return unknown if the command doesn't have a proc body to analyze + #otherwise return the package name identified in the magic comment + proc get_IMPLEMENTOR {command} { + #assert - command has already been resolved to a namespace ie fully qualified + if {[llength [info procs $command]]} { + #look for *IMPLEMENTOR_*! + set prefix IMPLEMENTOR_ + set suffix "!" + set body [uplevel 1 [list info body $command]] + if {[string match "*$prefix*$suffix*" $body]} { + set prefixposn [string first "$prefix" $body] + set pkgposn [expr {$prefixposn + [string length $prefix]}] + #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] + set suffixposn [string first $suffix $body $pkgposn] + return [string range $body $pkgposn $suffixposn-1] + } else { + return unspecified + } + } else { + if {[info commands tcl::info::cmdtype] ne ""} { + #tcl9 and maybe some tcl 8.7s ? + switch -- [tcl::info::cmdtype $command] { + native { + return builtin + } + default { + return undetermined + } + } + } else { + return undetermined + } + } + } +} +namespace eval commandstack::renamed_commands {} +namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place + +namespace eval commandstack { + namespace export {[a-z]*} + proc help {} { + return { + + } + } + + proc debug {{on_off {}}} { + variable debug + if {$on_off eq ""} { + return $debug + } else { + if {[string is boolean -strict $debug]} { + set debug [expr {$on_off && 1}] + return $debug + } + } + } + + proc get_stack {{command ""}} { + variable all_stacks + if {$command eq ""} { + return $all_stacks + } + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + return [dict get $all_stacks $command] + } else { + return [list] + } + } + + #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. + #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? + #e.g if renaming builtin 'package' - this command is generally called 'a lot' + proc get_next_command {command renamer tokenid} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + #stack is a list of dicts, 1st entry is token { } + set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] + if {$posn > -1} { + set record [lindex $stack $posn] + return [dict get $record implementation] + } else { + error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" + } + } else { + return $command + } + } + proc basecall {command args} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + set rec1 [lindex $stack 0] + tailcall [dict get $rec1 implementation] {*}$args + } else { + tailcall $command {*}$args + } + } else { + tailcall $command {*}$args + } + } + + + #review. + # defaults to calling namespace - but can be arbitrary string + proc rename_command {args} { + #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames + # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack + # + if {[lindex $args 0] eq "-renamer"} { + set renamer [lindex $args 1] + set arglist [lrange $args 2 end] + } else { + set renamer "" + set arglist $args + } + if {[llength $arglist] != 3} { + error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" + } + lassign $arglist command procargs procbody + + set command [uplevel 1 [list namespace which $command]] + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + variable all_stacks + variable known_renamers + variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. + if {$renamer eq ""} { + set renamer [uplevel 1 [list namespace current]] + } + if {$renamer ni $known_renamers} { + lappend known_renamers $renamer + dict set renamer_command_tokens [list $renamer $command] 0 + } + + #TODO - reduce emissions to stderr - flag for debug? + + #e.g packageTrace and packageSuppress packages use this convention. + set nextinfo [uplevel 1 [list\ + apply {{command renamer procbody} { + #todo - munge dash so we can make names in renamed_commands separable + # {- _dash_} ? + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] + set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. + set do_rename 0 + if {[llength [info procs $command]] || [llength [info commands $next_target]]} { + #$command is not the standard builtin - something has replaced it, could be ourself. + set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] + set munged_next_implementor [string map {:: _ns_} $next_implementor] + #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. + if {[dict exists $::commandstack::all_stacks $command]} { + set comstacks [dict get $::commandstack::all_stacks $command] + } else { + set comstacks [list] + } + set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') + if {[llength $this_renamer_previous_entries]} { + if {$next_implementor eq $renamer} { + #previous renamer was us. Rather than assume our job is done.. compare the implementations + #don't rename if immediate predecessor is same code. + #set topstack [lindex $comstacks end] + #set next_impl [dict get $topstack implementation] + set current_body [info body $command] + lassign [commandstack::lib::split_body $current_body] _ current_code + set current_code [string trim $current_code] + set new_code [string trim $procbody] + if {$current_code eq $new_code} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [::commandstack::show_stack $command] + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." + puts stdout "----------" + puts stdout "$current_code" + puts stdout "----------" + puts stdout "$new_code" + puts stdout "----------" + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } elseif {$next_implementor in $::commandstack::known_renamers} { + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {builtin}} { + #native/builtin could still have been renamed + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {unspecified undetermined}} { + #could be a standard tcl proc, or from application or package + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } else { + puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + #_originalcommand_ + #assume builtin/original + set next_implementor original + #rename $command $next_target + set do_rename 1 + } + #There are of course other ways in which $command may have been renamed - but we can't detect. + set token [list $command $renamer $tokenid] + return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] + } } $command $renamer $procbody] + ] + + + variable debug + if {$debug} { + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" + } else { + #assume this is the original + puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" + } + } + + #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) + #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) + set new_record [dict create\ + token [dict get $nextinfo token]\ + renamer $renamer\ + next_implementor [dict get $nextinfo next_implementor]\ + next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ + implementation [dict get $nextinfo next_target]\ + ] + if {![dict get $nextinfo do_rename]} { + #review + puts stderr "no rename performed" + return [dict create implementation ""] + } + catch {rename ::commandstack::temp::testproc ""} + set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { + #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + set final_procbody "$nextinit$procbody" + #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command + #(e.g due to invalid argument specifiers) + proc ::commandstack::temp::testproc $procargs $final_procbody + uplevel 1 [list rename $command [dict get $nextinfo next_target]] + uplevel 1 [list rename ::commandstack::temp::testproc $command] + dict lappend all_stacks $command $new_record + + + return $new_record + } + + #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer + #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost + #todo - removal of all entries pertaining to a particular renamer + #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? + + #remove by token, or by commandname if called from same context as original rename_command + #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. + #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. + #similarly a nonexistant token or renamer will not remove anything and will just return the current stack + proc remove_rename {token_or_command} { + if {[llength $token_or_command] == 3} { + #is token + lassign $token_or_command command renamer tokenid + } elseif {[llength $token_or_command] == 2} { + #command and renamer only supplied + lassign $token_or_command command renamer + set tokenid "" + } elseif {[llength $token_or_command] == 1} { + #is command name only + set command $token_or_command + set renamer [uplevel 1 [list namespace current]] + set tokenid "" + } + set command [uplevel 1 [list namespace which $command]] + variable all_stacks + variable known_renamers + if {$renamer ni $known_renamers} { + error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" + } + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {$tokenid ne ""} { + #token_or_command is a token as returned within the rename_command result dictionary + #search first dict value + set doomed_posn [lsearch -index 1 $stack $token_or_command] + } else { + #search second dict value + set matches [lsearch -all -index 3 $stack $renamer] + set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer + } + if {$doomed_posn ne "" && $doomed_posn > -1} { + set doomed_record [lindex $stack $doomed_posn] + if {[llength $stack] == ($doomed_posn + 1)} { + #last on stack - put the implemenation from the doomed_record back as the actual command + uplevel #0 [list rename $command ""] + uplevel #0 [list rename [dict get $doomed_record implementation] $command] + } elseif {[llength $stack] > ($doomed_posn + 1)} { + #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed + set rewrite_posn [expr {$doomed_posn + 1}] + set rewrite_record [lindex $stack $rewrite_posn] + + if {[dict get $rewrite_record next_implementor] ne $renamer} { + puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" + } else { + uplevel #0 [list rename [dict get $rewrite_record implementation] ""] + } + dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] + #don't update next_getter - it always refers to self + dict set rewrite_record implementation [dict get $doomed_record implementation] + lset stack $rewrite_posn $rewrite_record + dict set all_stacks $command $stack + } + set stack [lreplace $stack $doomed_posn $doomed_posn] + dict set all_stacks $command $stack + + } + return $stack + } + return [list] + } + + proc show_stack {{commandname_glob *}} { + variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns + return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] + } else { + set result "" + set matchedkeys [dict keys $all_stacks $commandname_glob] + #don't try to calculate widest on empty list + if {[llength $matchedkeys]} { + set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] + set indent [string repeat " " [expr {$widest + 3}]] + set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide + set padkey [string repeat " " 20] + foreach k $matchedkeys { + append result "$k = " + set i 0 + foreach stackmember [dict get $all_stacks $k] { + if {$i > 0} { + append result "\n$indent" + } + append result [string range "$i " 0 4] " = " + set j 0 + dict for {k v} $stackmember { + if {$j > 0} { + append result "\n$indent2" + } + set displaykey [string range "$k$padkey" 0 20] + append result "$displaykey = $v" + incr j + } + incr i + } + append result \n + } + } + return $result + } + } + + #review + #document when this is to be called. Wiping stacks without undoing renames seems odd. + proc Delete_stack {command} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + dict unset all_stacks $command + return 1 + } else { + return 1 + } + } + + #can be used to temporarily put a stack aside - should manually rename back when done. + #review - document how/when to use. example? intention? + proc Rename_stack {oldname newname} { + variable all_stacks + if {[dict exists $all_stacks $oldname]} { + if {[dict exists $all_stacks $newname]} { + error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" + } else { + #set stackval [dict get $all_stacks $oldname] + #dict unset all_stacks $oldname + #dict set all_stacks $newname $stackval + dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] + } + } + } +} + + + + + + + + +namespace eval commandstack::lib { + proc splitx {str {regexp {[\t \r\n]+}}} { + #snarfed from tcllib textutil::splitx to avoid the dependency + # Bugfix 476988 + if {[string length $str] == 0} { + return {} + } + if {[string length $regexp] == 0} { + return [::split $str ""] + } + if {[regexp $regexp {}]} { + return -code error "splitting on regexp \"$regexp\" would cause infinite loop" + } + + set list {} + set start 0 + while {[regexp -start $start -indices -- $regexp $str match submatch]} { + foreach {subStart subEnd} $submatch break + foreach {matchStart matchEnd} $match break + incr matchStart -1 + incr matchEnd + lappend list [string range $str $start $matchStart] + if {$subStart >= $start} { + lappend list [string range $str $subStart $subEnd] + } + set start $matchEnd + } + lappend list [string range $str $start end] + return $list + } + proc split_body {procbody} { + set marker "##" + set header "" + set code "" + set found_marker 0 + foreach ln [split $procbody \n] { + if {!$found_marker} { + if {[string trim $ln] eq $marker} { + set found_marker 1 + } else { + append header $ln \n + } + } else { + append code $ln \n + } + } + if {$found_marker} { + return [list $header $code] + } else { + return [list "" $procbody] + } + } +} + +package provide commandstack [namespace eval commandstack { + set version 0.4 +}] + + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config index 3a8e96a7..0ea2f344 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config @@ -49,6 +49,7 @@ set bootsupport_modules [list\ modules punk::aliascore\ modules punk::ansi::colourmap\ modules punk::ansi\ + modules punk::ansi::sauce\ modules punk::assertion\ modules punk::args\ modules punk::args::moduledoc::tclcore\ @@ -81,6 +82,7 @@ set bootsupport_modules [list\ modules punk::mix::commandset::scriptwrap\ modules punk::mod\ modules punk::nav::fs\ + modules punk::nav::ns\ modules punk::ns\ modules punk::overlay\ modules punk::path\ @@ -93,6 +95,7 @@ set bootsupport_modules [list\ modules punk::unixywindows\ modules punk::zip\ modules punk::winpath\ + modules overtype\ modules shellfilter\ modules shellrun\ modules shellthread\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.4.tm new file mode 100644 index 00000000..e4ea54d7 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.4.tm @@ -0,0 +1,5267 @@ +# -*- 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.7.4 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin overtype_module_overtype 0 1.7.4] +#[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 "ANSI capable 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 [expr {$renderwidth + 1}] + } else { + return $endpos + } + } + } +} + +tcl::namespace::eval overtype { + #*** !doctools + #[subsection {Namespace overtype}] + #[para] Core API functions for overtype + #[list_begin definitions] + + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + interp alias "" ::overtype::example "" ::punk::args::helpers::example + } + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::overtype::renderspace + @cmd -name overtype::renderspace\ + -summary\ + {}\ + -help\ + {} + @opts + #because underblocks value is optional - restrict opts to flag pairs (no solos) + #We don't use punk::args::parse in the actual function to parse args - so keep it simpler. + -bias -default left -type string -choices {left right} -help ignored + -width -default \uFFEF -type integer + -height -default \uFFEF -type integer + -startcolumn -default 1 -type integer + -startrow -default 1 -type integer + -ellipsis -default 0 -type boolean + -ellipsistext -default ${$::overtype::default_ellipsis_horizontal} -type char + -ellipsiswhitespace -default 0 -type boolean + -expand_right -default 0 -type boolean + -appendlines -default 1 -type boolean + -transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\ + "0 to disable transparency processing + 1 to enable space characters in the + overlay to be transparent, or a regex + to match the character(s) required to be + transparent in the overlay." + -exposed1 -default \uFFFD -type char -help\ + {A character of single terminal column width to use + as replacement when first-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the second-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -exposed2 -default \uFFFD -type char -help\ + {A character of single terminal column width to use + as replacement when second-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the first-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + + -experimental -default 0 + -cp437 -default 0 -type boolean + -looplimit -default \uFFEF\ -type integer -help\ + "internal failsafe - experimental" + -crm_mode -default 0 -type boolean + -reverse_mode -default 0 -type boolean + -insert_mode -default 1 -type boolean + -wrap -default 0 -type boolean + -info -default 0 -type boolean -help\ + "When set to 1, return a dictionary (experimental)" + -binarytext -default "" -type string -choices {"" bios ice} + -console -default {stdin stdout stderr} -type list + + @values -min 1 -max 2 + underblock -type string -optional 1 + overblock -type string -optional 0 + }] + } + + + #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] < 1} { + 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 { + #no solo flags - so we assume only an overblock was supplied + set overblock [lindex $args end] + set underblock "" + set argsflags [lrange $args 0 end-1] + + #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\ + -startrow 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\ + -binarytext ""\ + -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 - -startrow - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace + - -transparent - -exposed1 - -exposed2 - -experimental + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -info - -binarytext - -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_startrow [tcl::dict::get $opts -startrow] + 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] + set opt_binarytext [tcl::dict::get $opts -binarytext] + + + + # ---------------------------- + # -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] + if {$opt_startrow > 1} { + set down [expr {$opt_startrow -1}] + set overblock [punk::ansi::move_down $down]$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 mixed $overblock] + } + 1 { + #todo + set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 2 { + #todo + #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 { + #todo + #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] + switch -- $opt_binarytext { + "" { + foreach ln [split $overblock \n] { + lappend inputchunks [list mixed $ln\n] + } + if {[llength $inputchunks]} { + lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] + } + } + bios { + #16 fg, 8 fg + possible blink + set input "" + set ansisplit [list ""] + set charpair 0 + foreach {ch at} [split $overblock ""] { + #review - does binarytext only apply to cp437??? we need to know the original encoding + set at [encoding convertto cp437 $at] + if {[catch {punk::ansi::colour::byteAnsi $at} code]} { + puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" + #append input [punk::ansi::a+ brightred White] \uFFef + set code [punk::ansi::a+ brightred White] + set ch \uFFeF + } + append input $code $ch + lappend ansisplit $code $ch + incr charpair + } + #lappend inputchunks [list mixed $input] + lappend inputchunks [list ansisplit $ansisplit] + } + ice { + #16 fg, 16 bg (no blink) + set input "" + foreach {ch at} [split $overblock ""] { + set at [encoding convertto cp437 $at] + append input [punk::ansi::colour::byteAnsiIce $at]$ch + } + lappend inputchunks [list mixed $input] + } + } + } + } + + + + + 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]} { } + set renderedrow "" + while {[llength $inputchunks]} { + #set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed' + lassign [lpop inputchunks 0] overtext_type overtext + + #use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member if an 'ansisplit' list + if {$overtext eq ""} { + incr loop + continue + } + #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" + set undertext [lindex $outputlines [expr {$row -1}]] + + #renderline pads each underaly line to width with spaces and should track where end of data is + + switch -- $overtext_type { + mixed { + set overtext $replay_codes_overlay$overtext + } + ansisplit { + ledit overtext -1 -1 "" $replay_codes_overlay + } + default { + error "renderspace unsupported overtext type: $overtext_type overtext: $overtext" + } + } + + + ###################### + #debug + #set partinfo "" + #if {$overtext_type eq "ansisplit"} { + # set partinfo [llength $overtext] + #} else { + # set partinfo [string length $overtext] + #} + #if {$renderedrow eq $row} { + # puts -nonewline stderr <$row>$overtext_type$partinfo + #} else { + # puts -nonewline stderr \n<$row>$overtext_type$partinfo + #} + #if {$overtext_type eq "mixed"} { + # puts -nonewline stderr "\n[ansistring VIEW $overtext]\n" + #} + ###################### + + set renderedrow $row + + 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\ + -overtext_type $overtext_type\ + ] + 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 unapplied_ansisplit [tcl::dict::get $rinfo unapplied_ansisplit] + 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_list [list] + + + #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 "" + } + } + # ---- + # review + set col $post_render_col + #just because it's out of range of the renderwidth - doesn't mean a move down should jump to witin the range - 2025 + #---- + + #set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + #set lastdatacol [punk::ansi::printing_length $existingdata] + + #set col [expr {$lastdatacol+1}] + + #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.. + + #todo!!! + # 2025 fix - this does nothing - so what uses it?? create a test! + 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] + #JMN + #ledit inputchunks -1 -1 $overflow_right$unapplied + + set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right] + #join the trailing and leading pt parts of the 2 lists + ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]" + lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end] + + ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form + + set overflow_right "" + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list] + + 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 ""]] + ledit outputlines $renderedrow-1 $renderedrow-2 {*}[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 stderr "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + + + #renderspace gives us an overflow when there is a grapheme followed by a non-grapheme + #This gives us some possible(probable) leading ANSI (which is probably SGR, or it would have triggered something else) + #followed by a sequence of 1 or more graphemes and some more unprocessed ANSI (which could be anything: SGR,movement etc) + #we want to strip out this leading run of graphemes + #NOTE: 2025 - comment is obsolete/inaccurate. We only ever get 1 grapheme - as prior were consumed/ignored by renderline + #REVIEW!!! + + #example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100] + + 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 + #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 drop_graphemes [list] ;#list of contiguous grapheme indices + set new_unapplied_list [list] + set unapplied_ansisplit [list ""] + set idx 0 + + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + #puts stderr "g$idx:$u" + if {![llength $drop_graphemes] || $idx == [lindex $drop_graphemes end]+1} { + #we are in the first run of uninterrupted graphemes + #drop by doing nothing with it here + lappend drop_graphemes $idx + } else { + lappend new_unapplied_list $u + ledit unapplied_ansisplit end end "[lindex $unapplied_ansisplit end]$u" + } + } else { + lappend new_unapplied_list $u + lappend unapplied_ansisplit $u "" + } + incr idx + } + #debug + if {[llength $drop_graphemes]} { + set idx0 [lindex $drop_graphemes 0] + set dbg "" + if {$idx0 > 0} { + for {set i 0} {$i < $idx0} {incr i} { + #leading SGR + append dbg [lindex $unapplied_list $i] + } + } + foreach idx $drop_graphemes { + append dbg [lindex $unapplied_list $idx] + } + puts stderr "dropped[llength $drop_graphemes]:$dbg\x1b\[m" + } + set unapplied [join $new_unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + set unapplied_list $new_unapplied_list + + #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] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?) + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] + } 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] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient + puts -nonewline stderr . + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] + } + } + + } + 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 + set overflow_right_pt_code_pt [punk::ansi::ta::split_codes_single $overflow_right] + if {![llength $nextprefix_list]} { + set nextprefix_list $overflow_right_pt_code_pt + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $overflow_right_pt_code_pt 0]" + lappend nextprefix_list {*}[lrange $overflow_right_pt_code_pt 1 end] + } + } + + #append nextprefix $unapplied + if {![llength $nextprefix_list]} { + set nextprefix_list $unapplied_ansisplit + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $unapplied_ansisplit 0]" + lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end] + } + + 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 {[llength $nextprefix_list]} { + #set inputchunks [linsert $inputchunks 0 $nextprefix] + #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) + ledit inputchunks -1 -1 [list ansisplit $nextprefix_list] + } + + + 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 + variable optimise_ptruns 5 + + + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::overtype::renderline + @cmd -name overtype::renderline\ + -summary\ + {Render a line of text/ANSI input over a line of text.}\ + -help\ + {renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode + commandline repl for the Tcl Punk Shell. + It is also a central part of an ansi (micro) virtual terminal-emulator of sorts. + 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. + Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't + affect another. + Calling on the punk::ansi library - it can coalesce codes to keep the size down. + + It is a giant mess of doing exactly what common wisdom says not to do... lots at once. + Renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a + static underlay. + 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. + The overlay couuld be similar - in which case it may often be used to overwrite a column or section of + the underlay. + The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + + 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. + By suppyling the ${$B}-info${$N} 1 option - it can return various fields indicating the state of the render. + The main 3 are: result, overflow_right, and unapplied. + 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. + } + @opts + -etabs -default 0 -type boolean + -width -default \uFFEF -type integer + -expand_right -default 0 -type boolean + -transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\ + "0 to disable transparency processing + 1 to enable space characters in the + overlay to be transparent, or a regex + to match the character(s) required to be + transparent in the overlay." + -startcolumn -default 1 -type integer + -cursor_column -default 1 -type integer -help\ + {First column is 1. Cursor column can be zero or negative} + -cursor_row -default "" -type integer + -insert_mode -default 1 -type boolean + -crm_mode -default 0 -type boolean + -autowrap_mode -default 1 -type boolean + -reverse_mode -default 0 -type boolean + -info -default 0 -type boolean -help\ + "When set to 1, return a dictionary of settings useful for + processing ANSI input in a loop. When zero, the resulting + string will contain the updated line, but not all the + overtext may have been applied." + -exposed1 -default \uFFFD -help\ + {A character of single terminal column width to use + as replacement when first-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the second-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -exposed2 -default \uFFFD -help\ + {A character of single terminal column width to use + as replacement when second-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the first-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -cursor_restore_attributes -default "" + -cp437 -default 0 -type boolean + -experimental -default {} + -overtext_type -type string -choices {mixed plain ansisplit} -default mixed + @values -min 2 -max 2 + undertext -type string -help\ + "A single line of text which may contain pre-rendered ANSI. + 'pre-rendered' in this context means that it may contain + various static ANSI codes such as SGR colours and attributes + but not motion-control or more complex ANSI sequences. + It is an error to supply a newline (lf) character in the + undertext." + overtext -type string -help\ + "ANSI (or plain text) to overlay onto the undertext. + May contain ANSI movement codes even if they would move the + cursor to another line. If -info is zero, the output will + only display up to the point where the cursor moved off-line. + If -info is 1, the line moved to may be reflected in the + cursor_row element of the result. Overtext may contain an lf + which is effectively a form of 'movement control' to increment + the row. + Other ANSI codes may perform operations such as changing the + insert_mode or reverse_mode - and these are reflected in the + result dictionary when '-info 1' is used, so that the state + can then be applied to subsequent lines." + }] + } + + proc renderline {args} { + #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext which is not line-based. + #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and slow. + + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # 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? + + + + #*** !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 {}\ + -overtext_type mixed\ + ] + #-overtext_type plain|mixed|ansisplit + + #-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 - -overtext_type { + 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] + set opt_overtext_type [tcl::dict::get $opts -overtext_type] + 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] + } + + #review - is untabifying sensible at this point?? + if {$opt_overtext_type eq "ansisplit"} { + #todo - something for each pt part? + } else { + #plain|mixed + 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} { + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + #puts -nonewline stderr !$ptlen! + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + #we need to store the gx0 state per column - as characters with or without gx0 can be overlayed anywhere + 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] + } + + + #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 {$opt_overtext_type eq "ansisplit"} { + set overmap $overdata + lset overmap 0 "$startpadding[lindex $overmap 0]" + } else { + if {[punk::ansi::ta::detect $overdata]} { + #TODO!! rework this. + #e.g 200K+ input file with no newlines - we are wastefully calling split_codes_single repeatedly on mostly the same data. + #set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + set overmap [punk::ansi::ta::split_codes_single $overdata] + lset overmap 0 "$startpadding[lindex $overmap 0]" + + } 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 + set overlay_grapheme_control_stacks [list] + #REVIEW - even if we pass in a pre-split overtext (-overtext_type ansisplit) + #we are re-generating the overlay_grapheme_control_stacks list each time + #this is a big issue when overtext is not broken into lines, but is just a big long ansi and/or plain text string. + #todo - return also the unapplied portion of the 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] + #puts -nonewline stderr "!$len!" + + #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 {\x1b\[[0-1];[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?t} $code]} { + #pablodraw 24bit color - convert to standard sgr RGB code + #we could do a more precise 000-255 regexp for each r g b, something like: ((?:[0-1]?[0-9]?[0-9])|(?:2[0-4][0-9])|(?:25[0-5])) + #but that seems more expensive for little likely use (?) review + lassign [regexp -all -inline {\x1b\[([0-1]);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?)t} $code] _ isfg pablo_r pablo_g pablo_b + #todo - if any r g b value > 255 - add as [list other $code] + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + set dup_posns [lsearch -all -exact $o_codestack $rgbcode] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $rgbcode + lappend overlay_grapheme_control_list [list sgr $rgbcode] + } 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 - gx0 should just be a flag like autowrap_mode and insert_mode? + 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 unapplied_ansisplit [list ""] ;#pt code ... pt + + 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_to_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 ""]] + #JMN - backwards compat ledit from punk::lib for tcl <9 + ledit unapplied_list -1 -1 {*}[split $chars ""] + set unapplied [join $unapplied_list ""] + lset unapplied_ansisplit 0 $chars ;#no existing ? + + #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_to_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_to_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_to_unapplied $overlay_grapheme_control_list $gci + break + } else { + incr cursor_row + #don't adjust the overflow_idx + priv::render_to_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_to_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_to_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_to_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} { + 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_to_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 + } elseif {0 && $next_type ne "g"} { + incr idx_over -1 + 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] ;#will get index $i out of range error + lappend understacks [list] ;#REVIEW + 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_to_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 ""]] + #JMN + ledit unapplied_list -1 -1 {*}[split $chars ""] + set unapplied [join $unapplied_list ""] + #ledit unapplied_ansisplit -1 -1 $chars + lset unapplied_ansisplit 0 $chars ;#?? + + 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 { + #JMN + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. leadernorm: [ansistring VIEW -lf 1 $leadernorm] code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + puts stderr "ARGS:" + foreach a $args { + puts stderr " $a" + } + puts stderr ----- + foreach {xpt ycode} $overmap { + puts stderr "t:'$xpt'" + puts stderr "c:[ansistring VIEW $ycode]" + } + #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_to_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_to_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_to_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_to_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_to_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_to_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_to_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_to_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_to_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_to_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] + set unapplied_ansisplit [list ""] ;#remove below if nothing added + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + switch -- $type { + g { + lappend unapplied_list $item + ledit unapplied_ansisplit end end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" + } + } + #incr idx_over + } + set unapplied [join $unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [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} { + 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" + } + } + } + t { + set params [split $param {;}] + if {[llength $params] == 4} { + #pablodraw 24bit color + #see also: https://github.com/ansilove/libansilove/blob/master/src/loaders/ansi.c + lassign $params isfg pablo_r pablo_g pablo_b + #e.g esc\[0\;171\;87\;0t + set stack [lindex $overlay_grapheme_control_stacks $gci] + puts stderr "pablodraw debug [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #foreach s $stack { + # puts stderr " - [ansistring VIEW -lf 1 -vt 1 -nul 1 $s]" + #} + #we expect first param to be 0 for background, 1 for foreground + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + #too late here !! + #lappend stack $rgbcode + #lset overlay_grapheme_control_stacks $gci $stack + + } else { + puts stderr "overtype::renderline unrecognised custom CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + default { + puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + 7ESC { + # + #re_other_single {\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_to_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_to_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_to_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_to_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 && $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_to_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}] + } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + + 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\ + unapplied_ansisplit $unapplied_ansisplit\ + 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 unapplied_ansisplit [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_ansisplit]] + 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::renderline_transparent {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 + } + proc render_to_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + + #----------------------------------------- + #review - this is a lot of copies of the same thing. + # ultimately we want to reduce expensive things like redundant grapheme-splits + # perhaps unapplied_tagged of some sort e.g - {g g code pt } ?? + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar unapplied_ansisplit unapplied_ansisplit ;# pt ?code pt...? + #----------------------------------------- + + + 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 unapplied_ansisplit [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 + lappend unapplied_ansisplit $sgr_merged "" + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + #types g other sgr gx0 + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" + } + } + } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + 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 unapplied_ansisplit unapplied_ansisplit + #-------------- + + 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 unapplied_ansisplit [list ""] ;#remove empty entry at end if nothing added + + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + lappend unapplied_ansisplit $sgr_merged "" + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci end] { + lassign $gc type item + #types g other sgr gx0 + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" + } + } + } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + 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] + #JMN insert via ledit + ledit o $i $i-1 $c + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + #set ustacks [linsert $ustacks $i $sgrstack] + #set gxstacks [linsert $gxstacks $i $gx0stack] + #insert via ledit + ledit ustacks $i $i-1 $sgrstack + ledit gxstacks $i $i-1 $gx0stack + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +tcl::namespace::eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::overtype ::overtype::argdoc +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [tcl::namespace::eval overtype { + variable version + set version 1.7.4 +}] +return + +#*** !doctools +#[manpage_end] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 04767a22..45f53981 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -681,12 +681,16 @@ tcl::namespace::eval punk::ansi { } set opt_crm_mode [dict get $opts -crm_mode] - #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines - package require punk::ansi::sauce set binarytext "" - if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { - #no 128 Byte SAUCE record at end of file - set sdict [dict create] + set sdict [dict create] + #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines + if {![catch {package require punk::ansi::sauce}]} { + if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { + #no 128 Byte SAUCE record at end of file + set sdict [dict create] + } + } else { + puts stderr "Warning punk::ansi::sauce package not loaded - unable to detect or use any SAUCE data to aid in display" } if {![dict size $sdict]} { if {[string tolower [file extension $fname]] eq ".bin"} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm new file mode 100644 index 00000000..79ea5901 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm @@ -0,0 +1,628 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::ansi::sauce 0.1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + + + +tcl::namespace::eval punk::ansi::sauce { + variable PUNKARGS + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + } + + proc from_file {fname} { + if {[file size $fname] < 128} { + return + } + set fd [open $fname r] + chan conf $fd -translation binary + chan seek $fd -128 end + set srec [read $fd] + set srec_len 128 ;#This is the normal length of a SAUCE record - we may need to set it shorter if truncation detected + if {[catch {set sdict [to_dict $srec]}]} { + #review - have seen truncated SAUCE records < 128 bytes + #we could search for SAUCE00 in the tail and see what records can be parsed? + #specifically publicdomain roysac images sometimes only 99 Bytes of sauce - suspect remaining were null \x0 padded and trimmed + set sauceposn [string first SAUCE00 $srec] + if {$sauceposn <= 0} { + close $fd + return + } + #emit something to give user an indication something isn't right + puts stderr "punk::ansi::sauce::from_file WARNING SAUCE record seems to be truncated - padding rhs with nulls and trying again.." + #SAUCE00 is not at the beginning + #pad the tail with nulls and try again + set srec [string range $srec $sauceposn end] + set srec_len [string length $srec] + set srec ${srec}[string repeat \x0 [expr {128 - [string length $srec]}]] + if {[catch {set sdict [to_dict $srec]}]} { + close $fd + return + } + dict set sdict warning "SAUCE truncation to $srec_len bytes detected" + } + if {[dict exists $sdict comments] && [dict get $sdict comments] > 0} { + set clines [dict get $sdict comments] + #Use srec_len instead of 128 - in case we had truncated source record which we padded and were able to parse + set offset [expr {-1 *($srec_len + ($clines * 64) + 5)}] + chan seek $fd $offset end + set tag [chan read $fd 5] + if {$tag eq "COMNT"} { + #'character' data - shouldn't be null terminated c-style string - but can be + set commentlines [list] + for {set c 0} {$c < $clines} {incr c} { + set rawline [chan read $fd 64] + set str [lib::get_string $rawline] + set ln [format %-64s $str] + + if {![catch {encoding convertfrom cp437 $ln} line]} { + lappend commentlines $line + } else { + catch { + package require punk::ansi + puts stderr "punk::ansi::sauce::from_file failed to decode (from cp437) comment line:[punk::ansi::ansistring VIEW $ln]" + } + lappend commentlines [string repeat " " 64] + } + } + dict set sdict commentlines $commentlines + } + } + close $fd + return $sdict + } + + set datatypes [dict create] + dict set datatypes 0 none + dict set datatypes 1 character + dict set datatypes 2 bitmap + dict set datatypes 3 vector + dict set datatypes 4 audio + dict set datatypes 5 binarytext + dict set datatypes 6 xbin + dict set datatypes 7 archive + dict set datatypes 8 executable + + set filetypes [dict create] + + #Character + dict set filetypes 1 0 [list name "ASCII" description "Plain ASCII text file with no formatting codes or color codes."] + dict set filetypes 1 1 [list name "ANSi" description "A file with ANSi coloring codes and cursor positioning."] + dict set filetypes 1 2 [list name "ANSiMation" description "Like an ANSi file, but it relies on a fixed screensize."] + dict set filetypes 1 3 [list name "RIP script" description "Remote Imaging Protocol Graphics."] + dict set filetypes 1 4 [list name "PCBoard" description "A file with PCBoard color codes and macros, and ANSi codes."] + dict set filetypes 1 5 [list name "Avatar" description "A file with Avatar color codes, and ANSi codes."] + dict set filetypes 1 6 [list name "HTML" description "HyperText Markup Language."] + dict set filetypes 1 7 [list name "Source" description "Source code for some programming language.\nThe file extension should determine the programming language."] + dict set filetypes 1 8 [list name "TundraDraw" description "A TundraDraw file.\nLike ANSi, but with a custom palette."] + + #Bitmap + dict set filetypes 2 0 [list name "GIF" description "CompuServe Graphics Interchange Format"] + dict set filetypes 2 1 [list name "PCX" description "ZSoft Paintbrush PCX"] + dict set filetypes 2 2 [list name "LBM/IFF" description "DeluxePaint LBM/IFF"] + dict set filetypes 2 3 [list name "TGA" description "Targa Truecolor"] + dict set filetypes 2 4 [list name "FLI" description "Autodesk FLI animation"] + dict set filetypes 2 5 [list name "FLC" description "Autodesk FLC animation"] + dict set filetypes 2 6 [list name "BMP" description "Windows or OS/2 Bitmap"] + dict set filetypes 2 7 [list name "GL" description "Grasp GL Animation"] + dict set filetypes 2 8 [list name "DL" description "DL Animation"] + dict set filetypes 2 9 [list name "WPG" description "Wordperfect Bitmap"] + dict set filetypes 2 10 [list name "PNG" description "Portable Network Graphics"] + dict set filetypes 2 11 [list name "JPG/JPeg" description "JPeg image (any subformat)"] + dict set filetypes 2 12 [list name "MPG" description "MPeg video (any subformat)"] + dict set filetypes 2 12 [list name "AVI" description "Audio Video Interleave (any subformat)"] + + #vector + dict set filetypes 3 0 [list name "DXF" description "CAD Drawing eXchange Format"] + dict set filetypes 3 1 [list name "DWG" description "AutoCAD Drawing File"] + dict set filetypes 3 2 [list name "WPG" description "WordPerfect or DrawPerfect vector graphics"] + dict set filetypes 3 3 [list name "3DS" description "3D Studio"] + + #Audio + dict set filetypes 4 0 [list name "MOD" description "4, 6 or 8 channel MOD (Noise Tracker)"] + dict set filetypes 4 1 [list name "669" description "Renaissance 8 channel 669"] + dict set filetypes 4 2 [list name "STM" description "Future Crew 4 channel ScreamTracker"] + dict set filetypes 4 3 [list name "S3M" description "Future Crew variable channel ScreamTracker 3"] + dict set filetypes 4 4 [list name "MTM" description "Renaissance variable channel MultiTracker"] + dict set filetypes 4 5 [list name "FAR" description "Farandole composer"] + dict set filetypes 4 6 [list name "ULT" description "UltraTracker"] + dict set filetypes 4 7 [list name "AMF" description "DMP/DSMI Advanced Module Format"] + dict set filetypes 4 8 [list name "DMF" description "Delusion Digital Music Format (XTracker)"] + dict set filetypes 4 9 [list name "OKT" description "Oktalyser"] + dict set filetypes 4 10 [list name "ROL" description "AdLib ROL file (FM audio)"] + dict set filetypes 4 11 [list name "CMF" description "Creative Music File (FM Audio)"] + dict set filetypes 4 12 [list name "MID" description "MIDI (Musical Instrument Digital Interface)"] + dict set filetypes 4 13 [list name "SADT" description "SAdT composer (FM Audio)"] + dict set filetypes 4 14 [list name "VOC" description "Creative Voice File"] + dict set filetypes 4 15 [list name "WAV" description "Waveform Audio File Format"] + dict set filetypes 4 16 [list name "SMP8" description "Raw, single channel 8 bit sample"] + dict set filetypes 4 17 [list name "SMP8S" description "Raw, stereo 8 bit sample"] + dict set filetypes 4 18 [list name "SMP16" description "Raw, single channel 16 bit sample"] + dict set filetypes 4 19 [list name "SMP16S" description "Raw, stereo 16 bit sample"] + dict set filetypes 4 20 [list name "PATCH8" description "8 Bit patch file"] + dict set filetypes 4 21 [list name "PATCH16" description "16 Bit patch file"] + dict set filetypes 4 22 [list name "XM" description "FastTracker \]\[ module"] + dict set filetypes 4 23 [list name "HSC" description "HSC Tracker (FM Audio)"] + dict set filetypes 4 24 [list name "IT" description "Impulse Tracker"] + + #Archive + dict set filetypes 7 0 [list name "ZIP" description "PKWare Zip"] + dict set filetypes 7 1 [list name "ARJ" description "Archive Robert K. Jung"] + dict set filetypes 7 2 [list name "LZH" description "Haruyasu Yoshizaki (Yoshi)"] + dict set filetypes 7 3 [list name "ARC" description "S.E.A"] + dict set filetypes 7 4 [list name "TAR" description "Unix TAR"] + dict set filetypes 7 5 [list name "ZOO" description "ZOO"] + dict set filetypes 7 6 [list name "RAR" description "RAR"] + dict set filetypes 7 7 [list name "UC2" description "UC2"] + dict set filetypes 7 8 [list name "PAK" description "PAK"] + dict set filetypes 7 9 [list name "SQZ" description "SQZ"] + + + #review + #map sauce encodings to those that exist by default in Tcl 'encoding names' + set encodings [dict create] + dict set encodings 437 cp437 + dict set encodings 720 cp1256 ;#Arabic + dict set encodings 737 cp737 + dict set encodings 775 cp775 + dict set encodings 819 iso8859-1 ;#Latin-1 Supplemental - review + dict set encodings 850 cp850 + dict set encodings 852 cp852 + dict set encodings 855 cp855 + dict set encodings 857 cp857 + #dict set encodings 858 "" ;#??? + dict set encodings 860 cp860 ;#Porguguese + dict set encodings 861 cp861 ;#Icelandic + dict set encodings 862 cp862 ;#Hebrew + dict set encodings 863 cp863 ;#French Canada + dict set encodings 864 cp864 + dict set encodings 865 cp865 + dict set encodings 866 cp866 ;#Cyrillic + dict set encodings 869 cp869 + #dict set encodings 872 "" ;#Cyrillic - cp855? macCyrillic? + #dict set encodings KAM "" ;#cp867,cp895 ? + #dict set encodings MAZ "" ;#cp667 cp790 ? + dict set encodings MIK cp866 ;#Cyrillic + + + + + #todo - fontName - which can also specify e.g code page 437 + ## Font name [1] Font size Resolution [2] Aspect ratio [3] Vertical stretch [6] Description + ## Display [4] Pixel [5] + + set fontnames [dict create] + + ## IBM VGA 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for 80×25 text mode (code page 437) + dict set fontnames "IBM VGA" [list fontsize "9x16" resolution "720x400" aspect_ratio_display "4:3" aspect_ratio_pixel "20:27 (1:1.35)" vertical_stretch "35%" description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)"] + ## IBM VGA ### [8] 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA 80×25 text mode + # - where ### is placeholder for 437,720,737 etc + + ## IBM VGA50 ### [8] 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA condensed 80×50 text mode + ## IBM VGA25G ### [8] 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color). + + ## 8×16 640×400 4:3 6:5 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA" or code page variant. + ## IBM VGA50 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for condensed 80×50 text mode (code page 437) + ## 8×8 640×400 4:3 5:6 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA50" or code page variant. + ## IBM VGA25G 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color) (code page 437). + ## IBM EGA 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for 80×25 text mode (code page 437) + ## IBM EGA43 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for condensed 80×43 text mode (code page 437) + ## IBM EGA ### [8] 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA 80×25 text mode + ## IBM EGA43 ### [8] 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA condensed 80×43 text mode + ## Amiga Topaz 1 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) + ## Amiga Topaz 1+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) + ## Amiga Topaz 2 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) + ## Amiga Topaz 2+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) + ## Amiga P0T-NOoDLE 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original P0T-NOoDLE font. + ## Amiga MicroKnight 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original MicroKnight font. + ## Amiga MicroKnight+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified MicroKnight font. + ## Amiga mOsOul 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original mOsOul font. + ## C64 PETSCII unshifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original Commodore PETSCII font (PET, VIC-20, C64, CBM-II, Plus/4, C16, C116 and C128) in the unshifted mode. Unshifted mode (graphics) only has uppercase letters and additional graphic characters. This is the normal boot font. + ## C64 PETSCII shifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original PETSCII font in shifted mode. Shifted mode (text) has both uppercase and lowercase letters. This mode is actuated by pressing Shift+Commodore key. + ## Atari ATASCII 8×8 [11] 320×192 4:3 4:5 (1:1.25) 25% Original ATASCII font (Atari 400, 800, XL, XE) + + + #expect a 128 Byte sauce record + #Some sauce records may have been padded with null bytes - and been truncated by some process + + proc to_dict {saucerecord} { + variable datatypes + variable filetypes + variable encodings + if {[string length $saucerecord] != 128} { + error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - length != 128" + } + if {![string match "SAUCE*" $saucerecord]} { + error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - does not begin with 'SAUCE'" + } + #tcl binary scan: cu - unsigned 8-bit, su - unsigned 16-bit, iu - unsigned 32bit, + set sdict [dict create] + dict set sdict version [string range $saucerecord 5 6] ;#2bytes + + #sauce spec says 'character' type is a string encoded according to code page 437 (IBM PC / OEM ASCII) + # - in the wild - string may be terminated with null and have following garbage + # - 'binary scan $rawchars C* str' to get null-terminated string and pad rhs with spaces to cater for this possibility + #"C" specifier not available in tcl 8.6 + + + #dict set sdict title [string range $saucerecord 7 41] ;#35 bytes 'character' + set rawtitle [string range $saucerecord 7 41] ;#35 bytes 'character' + set str [lib::get_string $rawtitle] + dict set sdict title [format %-35s $str] + + #dict set sdict author [string range $saucerecord 42 61] ;#20 bytes 'character' + set rawauthor [string range $saucerecord 42 61] ;#20 bytes 'character' + set str [lib::get_string $rawauthor] + dict set sdict author [format %-20s $str] + + #dict set sdict group [string range $saucerecord 62 81] ;#20 bytes 'character' + set rawgroup [string range $saucerecord 62 81] ;#20 bytes 'character' + set str [lib::get_string $rawgroup] + dict set sdict group [format %-20s $str] + + + #dict set sdict date [string range $saucerecord 82 89] ;#8 bytes 'character' + set rawdate [string range $saucerecord 82 89] ;#8 bytes 'character' + set str [lib::get_string $rawdate] + dict set sdict date [format %-8s $str] + + + if {[binary scan [string range $saucerecord 90 93] iu v]} { + #4 bytes - unsigned littlendian + dict set sdict filesize $v + } else { + dict set sdict filesize "" + } + if {[binary scan [string range $saucerecord 94 94] cu v]} { + #1 byte - unsigned + dict set sdict datatype $v + if {[dict exists $datatypes [dict get $sdict datatype]]} { + dict set sdict datatype_name [dict get $datatypes [dict get $sdict datatype]] + } else { + dict set sdict datatype_name unrecognised + } + } else { + dict set sdict datatype "" + dict set sdict datatype_name failed ;#unrecognised?? + } + if {[binary scan [string range $saucerecord 95 95] cu v]} { + #1 byte - unsigned + dict set sdict filetype $v + if {[dict exists $filetypes [dict get $sdict datatype] $v]} { + dict set sdict filetype_name [dict get $filetypes [dict get $sdict datatype] $v name] + } else { + dict set sdict filetype_name "" + } + } else { + dict set sdict filetype "" + dict set sdict filetype_name "" + } + if {[binary scan [string range $saucerecord 96 97] su v]} { + dict set sdict tinfo1 $v + } else { + dict set sdict tinfo1 "" + } + + if {[binary scan [string range $saucerecord 98 99] su v]} { + dict set sdict tinfo2 $v + } else { + dict set sdict tinfo2 "" + } + + + if {[binary scan [string range $saucerecord 100 101] su v]} { + dict set sdict tinfo3 $v + } else { + dict set sdict tinfo3 "" + } + if {[binary scan [string range $saucerecord 102 103] su v]} { + dict set sdict tinfo4 $v + } else { + dict set sdict tinfo4 "" + } + if {[binary scan [string range $saucerecord 104 104] cu v]} { + #1 byte - unsigned + dict set sdict comments $v + } else { + dict set sdict comments 0 + } + if {[dict get $sdict datatype_name] in {character binarytext} && [binary scan [string range $saucerecord 105 105] cu v]} { + dict set sdict tflags $v + if {$v & 1} { + dict set sdict ansiflags_ice 1 + } else { + dict set sdict ansiflags_ice 0 + } + set bits [format %08b $v] + set ls [string range $bits 5 6] + switch -- $ls { + "00" { + dict set sdict ansiflags_letterspacing unspecified + } + "01" { + dict set sdict ansiflags_letterspacing 8 + } + "10" { + dict set sdict ansiflags_letterspacing 9 + } + "11" { + dict set sdict ansiflags_letterspacing invalid + } + } + set ar [string range $bits 3 4] + switch -- $ar { + "00" { + dict set sdict ansiflags_aspectratio unspecified + } + "01" { + dict set sdict ansiflags_aspectratio tallpixels + } + "10" { + dict set sdict ansiflags_aspectratio squarepixels + } + "11" { + dict set sdict ansiflags_aspectratio invalid + } + } + } else { + dict set sdict tflags "" + } + set rawzstring [string range $saucerecord 106 127] + set str [lib::get_string $rawzstring] + dict set sdict tinfos $str + + + + switch -- [string tolower [dict get $sdict filetype_name]] { + ansi - ascii - pcboard - avatar { + dict set sdict columns [dict get $sdict tinfo1] + dict set sdict rows [dict get $sdict tinfo2] + dict set sdict fontname [dict get $sdict tinfos] + } + ansimation { + dict set sdict columns [dict get $sdict tinfo1] + #review - fixed screen height? + dict set sdict rows [dict get $sdict tinfo2] + dict set sdict fontname [dict get $sdict tinfos] + } + } + switch -- [dict get $sdict datatype] { + 5 { + #binarytext + #filetype is supposed to represent half the characterwidth (only widths with multiples of 2 can be specified) + #HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some other value in filetype (eg 1) + #If both tinfo1 and tinfo2 are non zero - we will use them, even though it's not in spec. + set t1 [dict get $sdict tinfo1] + if {$t1 eq ""} { + set t1 0 + } + set t2 [dict get $sdict tinfo2] + if {$t2 eq ""} { + set t2 0 + } + if {$t1 != 0 && $t2 != 0} { + #not to spec - but we will assume these have values for a reason.. + puts stderr "punk::ansi::sauce::to_dict using tinfo1/tinfo2 data for columns/rows (non-compliant SAUCE data)" + dict set sdict columns [expr {2 * $t1}] + dict set sdict rows $t2 + } else { + #proper mechanism to specify columns for binarytext is the datatype field. + + set cols [expr {2*[dict get $sdict filetype]}] + dict set sdict columns $cols + #rows must be calculated from file size + #rows = (filesize - sauceinfosize)/ filetype * 2 * 2 + #(time additional 2 due to character/attribute pairs) + + #todo - calc filesize from total size of file - EOF - comment - sauce rather than rely on stored filesize? + dict set sdict rows [expr {[dict get $sdict filesize]/($cols * 2)}] + } + + } + 6 { + #xbin - only filtype is 0 + #https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm + dict set sdict columns [dict get $sdict tinfo1] + dict set sdict rows [dict get $sdict tinfo2] + dict set sdict fontname [dict get $sdict tinfos] + } + } + if {[dict exists $sdict fontname]} { + set fname [dict get $sdict fontname] + #IBM VGA and IBM EGA variants are all cp437 - unless a 3 letter code specifying otherwise follows + switch -- [string range $fname 0 6] { + "IBM EGA" - "IBM VGA" { + lassign $fname _ibm _ code + set cp "" + if {$code eq ""} { + set cp "cp437" + } else { + if {[dict exists $encodings $code]} { + set cp [dict get $encodings $code] + } + } + if {$cp ne ""} { + dict set sdict codepage $cp + } + } + } + } + return $sdict + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::ansi::sauce::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + + + #get_string caters for possible null-terminated strings as these may be seen in the wild even though sauce doesn't specify they should be null-terminated + if {[catch {binary scan x C v}]} { + #fallback for tcl 8.6 + proc get_string {bytes} { + set cstr [lindex [split $bytes \0] 0] + binary scan $cstr a* str + return $str + } + } else { + proc get_string {bytes} { + binary scan $bytes C* str + return $str + } + } + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +#tcl::namespace::eval punk::ansi::sauce::system { +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::ansi::sauce { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::ansi::sauce" + @package -name "punk::ansi::sauce" -help\ + "Basic support for SAUCE format + Standard Architecture for Universal Comment Extensions + https://www.acid.org/info/sauce/sauce.htm " + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::ansi::sauce + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::ansi::sauce + ANSI SAUCE block processor + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::ansi::sauce::version" + } + proc get_topic_Contributors {} { + set authors {{"Julian Noble" }} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::ansi::sauce::about" + dict set overrides @cmd -name "punk::ansi::sauce::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::ansi::sauce + }] \n] + dict set overrides topic -choices [list {*}[punk::ansi::sauce::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::ansi::sauce::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::ansi::sauce::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::ansi::sauce::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::ansi::sauce +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::ansi::sauce [tcl::namespace::eval punk::ansi::sauce { + variable pkg punk::ansi::sauce + variable version + set version 0.1.0 +}] +return + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 558f6bde..24f98b6b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -6345,7 +6345,7 @@ tcl::namespace::eval punk::args { } indexexpression { #tcl 9.1+? tip 615 'string is index' - if {$echeck eq "" || [catch {lindex {} $e_check}]} { + if {$e_check eq "" || [catch {lindex {} $e_check}]} { set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm index d7eaf639..ce35138e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -444,6 +444,8 @@ tcl::namespace::eval ::punk::libunknown { proc zipfs_tclPkgUnknown {name args} { #puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" + global dir + variable epoch set pkg_epoch [dict get $epoch pkg current] @@ -609,7 +611,7 @@ tcl::namespace::eval ::punk::libunknown { incr sourced ;#count as sourced even if source fails; keep before actual source action #::tcl::Pkg::source $file #lappend sourced_files $file - tcl_Pkg_source $file + namespace eval :: [list ::punk::libunknown::tcl_Pkg_source $file] } trap {POSIX EACCES} {} { # $file was not readable; silently ignore puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (1)" @@ -640,7 +642,7 @@ tcl::namespace::eval ::punk::libunknown { incr sourced #lappend sourced_files $file #::tcl::Pkg::source $file - tcl_Pkg_source $file + namespace eval :: [list punk::libunknown::tcl_Pkg_source $file] } trap {POSIX EACCES} {} { # $file was not readable; silently ignore puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (2)" @@ -1367,7 +1369,7 @@ tcl::namespace::eval ::punk::libunknown { } } if {[llength $ok_forgets]} { - return [::package:: forget {*}$ok_forgets] + return [uplevel 1 [list ::package:: forget {*}$ok_forgets]] } else { return } @@ -1449,7 +1451,7 @@ tcl::namespace::eval ::punk::libunknown { } } default { - return [::package:: {*}$args] + return [uplevel 1 [list ::package:: {*}$args]] } } } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm new file mode 100644 index 00000000..16cb13a1 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm @@ -0,0 +1,302 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::nav::ns 0.1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + + + +tcl::namespace::eval punk::nav::ns { + variable PUNKARGS + variable ns_current + #allow presetting + if {![info exists ::punk::nav::ns::ns_current]} { + set ns_current :: + } + namespace path {::punk::ns} + + proc ns/ {v {ns_or_glob ""} args} { + variable ns_current ;#change active ns of repl by setting ns_current + + set ns_caller [uplevel 1 {::tcl::namespace::current}] + #puts stderr "ns_cur:$ns_current ns_call:$ns_caller" + + + set types [list all] + set nspathcommands 0 + if {$v eq "/"} { + set types [list children] + } + if {$v eq "///"} { + set nspathcommands 1 + } + + set ns_or_glob [string map {:::: ::} $ns_or_glob] + + #todo - cooperate with repl? + set out "" + if {$ns_or_glob eq ""} { + set is_absolute 1 + set ns_queried $ns_current + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] + } else { + set is_absolute [string match ::* $ns_or_glob] + set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? + if {$is_absolute} { + if {!$has_globchars} { + if {![nsexists $ns_or_glob]} { + error "cannot change to namespace $ns_or_glob" + } + set ns_current $ns_or_glob + set ns_queried $ns_current + tailcall ns/ $v "" + } else { + set ns_queried $ns_or_glob + set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] + } + } else { + if {!$has_globchars} { + set nsnext [nsjoin $ns_current $ns_or_glob] + if {![nsexists $nsnext]} { + error "cannot change to namespace $ns_or_glob" + } + set ns_current $nsnext + set ns_queried $nsnext + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] + } else { + set ns_queried [nsjoin $ns_current $ns_or_glob] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] + } + } + } + set ns_display "\n$ns_queried" + if {$ns_current eq $ns_queried} { + if {$ns_current in [info commands $ns_current] } { + if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { + if {[llength $ensemble_info] > 0} { + #this namespace happens to match ensemble command. + #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. + set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" + } + } + } + } + append out $ns_display + return $out + } + + #create possibly nested namespace structure - but only if not already existant + proc n/new {args} { + variable ns_current + if {![llength $args]} { + error "usage: :/new \[ ...\]" + } + set a1 [lindex $args 0] + set is_absolute [string match ::* $a1] + if {$is_absolute} { + set nspath [nsjoinall {*}$args] + } else { + if {[string match :* $a1]} { + puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" + } + set nspath [nsjoinall $ns_current {*}$args] + } + + set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] + + if {$ns_exists} { + error "Namespace $nspath already exists" + } + #tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] + nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] + n/ $nspath + } + + #nn/ ::/ nsup/ - back up one namespace level + proc nsup/ {v args} { + variable ns_current + if {$ns_current eq "::"} { + puts stderr "Already at global namespace '::'" + } else { + set out "" + set nsq [nsprefix $ns_current] + if {$v eq "/"} { + set out [get_nslist -match [nsjoin $nsq *] -types [list children]] + } else { + set out [get_nslist -match [nsjoin $nsq *] -types [list all]] + } + #set out [nslist [nsjoin $nsq *]] + set ns_current $nsq + append out "\n$ns_current" + return $out + } + } + + + +} + + + +#extra slash implies more verbosity (ie display commands instead of just nschildren) +interp alias {} n/ {} punk::nav::ns::ns/ / +interp alias {} n// {} punk::nav::ns::ns/ // +interp alias {} n/// {} punk::nav::ns::ns/ /// +interp alias {} n/new {} punk::nav::ns::n/new +interp alias {} nn/ {} punk::nav::ns::nsup/ / +interp alias {} nn// {} punk::nav::ns::nsup/ // +if 0 { +#we can't have ::/ without just plain / which is confusing. +interp alias {} :/ {} punk::nav::ns::ns/ / +interp alias {} :// {} punk::nav::ns::ns/ // +interp alias {} :/new {} punk::nav::ns::n/new +interp alias {} ::/ {} punk::nav::ns::nsup/ / +interp alias {} ::// {} punk::nav::ns::nsup/ // +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::nav::ns::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +#tcl::namespace::eval punk::nav::ns::system { +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::nav::ns { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::nav::ns" + @package -name "punk::nav::ns" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::nav::ns + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::nav::ns + description to come.. + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::nav::ns::version" + } + proc get_topic_Contributors {} { + set authors {} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::nav::ns::about" + dict set overrides @cmd -name "punk::nav::ns::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::nav::ns + }] \n] + dict set overrides topic -choices [list {*}[punk::nav::ns::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::nav::ns::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::nav::ns::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::nav::ns::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::nav::ns +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::nav::ns [tcl::namespace::eval punk::nav::ns { + variable pkg punk::nav::ns + variable version + set version 0.1.0 +}] +return + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index 5b504e58..330018ae 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -63,39 +63,6 @@ package require commandstack #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::packagepreference::class { - #*** !doctools - #[subsection {Namespace punk::packagepreference::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::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 # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -188,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } if {!$is_exact && [llength $vwant] <= 1 } { @@ -238,7 +205,7 @@ tcl::namespace::eval punk::packagepreference { } #return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] try { - set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] + set result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg $lversion-$lversion]] } trap {} {emsg eopts} { #REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry #under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown @@ -282,9 +249,9 @@ tcl::namespace::eval punk::packagepreference { if {[regexp {[A-Z]} $pkg]} { #legacy package names #only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation - if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} { + if {[catch {uplevel 1 [list $COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant]} v]} { try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -294,7 +261,7 @@ tcl::namespace::eval punk::packagepreference { } else { #return [$COMMANDSTACKNEXT require $pkg {*}$vwant] try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -328,14 +295,14 @@ tcl::namespace::eval punk::packagepreference { catch { #$COMMANDSTACKNEXT require $pkg {*}$vwant #j2 - $COMMANDSTACKNEXT require punk::args::moduledoc::$dp + uplevel 1 [list $COMMANDSTACKNEXT require punk::args::moduledoc::$dp] } } #--------------------------------------------------------------- return $require_result } default { - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index 9ae26516..5dc72254 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -738,7 +738,7 @@ proc ::punkboot::check_package_availability {args} { lappend ::test::pkg_missing $pkgrequest } } else { - if {$pkgrequest ni $::test_pkg_broken} { + if {$pkgrequest ni $::test::pkg_broken} { lappend ::test::pkg_broken $pkgrequest } @@ -1481,12 +1481,12 @@ if {$::punkboot::command eq "check"} { } } flush stdout - set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] + set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { lassign $pkg_request pkgname vrequest package require $pkgname {*}$vrequest ;#todo? } - flush stderr + flush stderr #punk::lib::showdict -channel stderr $::punkboot::pkg_availability set missing_out [::punkboot::get_display_missing_packages $::punkboot::pkg_availability] puts stdout $missing_out\n @@ -1566,7 +1566,9 @@ if {$::punkboot::command eq "check"} { set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { lassign $pkg_request pkgname vrequest - catch {package require $pkgname {*}$vrequest} ;#todo + if {[catch {package require $pkgname {*}$vrequest} errM]} { + puts stderr "failed to load $pkgname\n - $errM\n - $::errorInfo" + } } flush stderr #punk::lib::showdict -channel stderr $::punkboot::pkg_availability diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.4.tm new file mode 100644 index 00000000..19c21289 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/commandstack-0.4.tm @@ -0,0 +1,518 @@ + + +#JMN 2021 - Public Domain +#cooperative command renaming +# +# REVIEW 2024 - code was originally for specific use in packageTrace +# - code should be reviewed for more generic utility. +# - API is obscure and undocumented. +# - unclear if intention was only for builtins +# - consider use of newer 'info cmdtype' - (but need also support for safe interps) +# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. +# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename +#changes: +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#2021-09-18 +# - initial version +# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command +# - They need to be able to load and unload in any order. +# + +#strive for no other package dependencies here. + + +namespace eval commandstack { + variable all_stacks + variable debug + set debug 0 + variable known_renamers [list ::packagetrace ::packageSuppress] + if {![info exists all_stacks]} { + #don't wipe it + set all_stacks [dict create] + } +} + +namespace eval commandstack::util { + #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. + #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace + #A magic comment was chosen as the identifying method. + #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. + + #return unspecified if the command is a proc with a body but no magic comment ID + #return unknown if the command doesn't have a proc body to analyze + #otherwise return the package name identified in the magic comment + proc get_IMPLEMENTOR {command} { + #assert - command has already been resolved to a namespace ie fully qualified + if {[llength [info procs $command]]} { + #look for *IMPLEMENTOR_*! + set prefix IMPLEMENTOR_ + set suffix "!" + set body [uplevel 1 [list info body $command]] + if {[string match "*$prefix*$suffix*" $body]} { + set prefixposn [string first "$prefix" $body] + set pkgposn [expr {$prefixposn + [string length $prefix]}] + #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] + set suffixposn [string first $suffix $body $pkgposn] + return [string range $body $pkgposn $suffixposn-1] + } else { + return unspecified + } + } else { + if {[info commands tcl::info::cmdtype] ne ""} { + #tcl9 and maybe some tcl 8.7s ? + switch -- [tcl::info::cmdtype $command] { + native { + return builtin + } + default { + return undetermined + } + } + } else { + return undetermined + } + } + } +} +namespace eval commandstack::renamed_commands {} +namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place + +namespace eval commandstack { + namespace export {[a-z]*} + proc help {} { + return { + + } + } + + proc debug {{on_off {}}} { + variable debug + if {$on_off eq ""} { + return $debug + } else { + if {[string is boolean -strict $debug]} { + set debug [expr {$on_off && 1}] + return $debug + } + } + } + + proc get_stack {{command ""}} { + variable all_stacks + if {$command eq ""} { + return $all_stacks + } + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + return [dict get $all_stacks $command] + } else { + return [list] + } + } + + #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. + #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? + #e.g if renaming builtin 'package' - this command is generally called 'a lot' + proc get_next_command {command renamer tokenid} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + #stack is a list of dicts, 1st entry is token { } + set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] + if {$posn > -1} { + set record [lindex $stack $posn] + return [dict get $record implementation] + } else { + error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" + } + } else { + return $command + } + } + proc basecall {command args} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + set rec1 [lindex $stack 0] + tailcall [dict get $rec1 implementation] {*}$args + } else { + tailcall $command {*}$args + } + } else { + tailcall $command {*}$args + } + } + + + #review. + # defaults to calling namespace - but can be arbitrary string + proc rename_command {args} { + #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames + # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack + # + if {[lindex $args 0] eq "-renamer"} { + set renamer [lindex $args 1] + set arglist [lrange $args 2 end] + } else { + set renamer "" + set arglist $args + } + if {[llength $arglist] != 3} { + error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" + } + lassign $arglist command procargs procbody + + set command [uplevel 1 [list namespace which $command]] + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + variable all_stacks + variable known_renamers + variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. + if {$renamer eq ""} { + set renamer [uplevel 1 [list namespace current]] + } + if {$renamer ni $known_renamers} { + lappend known_renamers $renamer + dict set renamer_command_tokens [list $renamer $command] 0 + } + + #TODO - reduce emissions to stderr - flag for debug? + + #e.g packageTrace and packageSuppress packages use this convention. + set nextinfo [uplevel 1 [list\ + apply {{command renamer procbody} { + #todo - munge dash so we can make names in renamed_commands separable + # {- _dash_} ? + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] + set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. + set do_rename 0 + if {[llength [info procs $command]] || [llength [info commands $next_target]]} { + #$command is not the standard builtin - something has replaced it, could be ourself. + set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] + set munged_next_implementor [string map {:: _ns_} $next_implementor] + #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. + if {[dict exists $::commandstack::all_stacks $command]} { + set comstacks [dict get $::commandstack::all_stacks $command] + } else { + set comstacks [list] + } + set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') + if {[llength $this_renamer_previous_entries]} { + if {$next_implementor eq $renamer} { + #previous renamer was us. Rather than assume our job is done.. compare the implementations + #don't rename if immediate predecessor is same code. + #set topstack [lindex $comstacks end] + #set next_impl [dict get $topstack implementation] + set current_body [info body $command] + lassign [commandstack::lib::split_body $current_body] _ current_code + set current_code [string trim $current_code] + set new_code [string trim $procbody] + if {$current_code eq $new_code} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [::commandstack::show_stack $command] + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." + puts stdout "----------" + puts stdout "$current_code" + puts stdout "----------" + puts stdout "$new_code" + puts stdout "----------" + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } elseif {$next_implementor in $::commandstack::known_renamers} { + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {builtin}} { + #native/builtin could still have been renamed + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {unspecified undetermined}} { + #could be a standard tcl proc, or from application or package + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } else { + puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + #_originalcommand_ + #assume builtin/original + set next_implementor original + #rename $command $next_target + set do_rename 1 + } + #There are of course other ways in which $command may have been renamed - but we can't detect. + set token [list $command $renamer $tokenid] + return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] + } } $command $renamer $procbody] + ] + + + variable debug + if {$debug} { + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" + } else { + #assume this is the original + puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" + } + } + + #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) + #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) + set new_record [dict create\ + token [dict get $nextinfo token]\ + renamer $renamer\ + next_implementor [dict get $nextinfo next_implementor]\ + next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ + implementation [dict get $nextinfo next_target]\ + ] + if {![dict get $nextinfo do_rename]} { + #review + puts stderr "no rename performed" + return [dict create implementation ""] + } + catch {rename ::commandstack::temp::testproc ""} + set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { + #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + set final_procbody "$nextinit$procbody" + #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command + #(e.g due to invalid argument specifiers) + proc ::commandstack::temp::testproc $procargs $final_procbody + uplevel 1 [list rename $command [dict get $nextinfo next_target]] + uplevel 1 [list rename ::commandstack::temp::testproc $command] + dict lappend all_stacks $command $new_record + + + return $new_record + } + + #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer + #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost + #todo - removal of all entries pertaining to a particular renamer + #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? + + #remove by token, or by commandname if called from same context as original rename_command + #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. + #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. + #similarly a nonexistant token or renamer will not remove anything and will just return the current stack + proc remove_rename {token_or_command} { + if {[llength $token_or_command] == 3} { + #is token + lassign $token_or_command command renamer tokenid + } elseif {[llength $token_or_command] == 2} { + #command and renamer only supplied + lassign $token_or_command command renamer + set tokenid "" + } elseif {[llength $token_or_command] == 1} { + #is command name only + set command $token_or_command + set renamer [uplevel 1 [list namespace current]] + set tokenid "" + } + set command [uplevel 1 [list namespace which $command]] + variable all_stacks + variable known_renamers + if {$renamer ni $known_renamers} { + error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" + } + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {$tokenid ne ""} { + #token_or_command is a token as returned within the rename_command result dictionary + #search first dict value + set doomed_posn [lsearch -index 1 $stack $token_or_command] + } else { + #search second dict value + set matches [lsearch -all -index 3 $stack $renamer] + set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer + } + if {$doomed_posn ne "" && $doomed_posn > -1} { + set doomed_record [lindex $stack $doomed_posn] + if {[llength $stack] == ($doomed_posn + 1)} { + #last on stack - put the implemenation from the doomed_record back as the actual command + uplevel #0 [list rename $command ""] + uplevel #0 [list rename [dict get $doomed_record implementation] $command] + } elseif {[llength $stack] > ($doomed_posn + 1)} { + #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed + set rewrite_posn [expr {$doomed_posn + 1}] + set rewrite_record [lindex $stack $rewrite_posn] + + if {[dict get $rewrite_record next_implementor] ne $renamer} { + puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" + } else { + uplevel #0 [list rename [dict get $rewrite_record implementation] ""] + } + dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] + #don't update next_getter - it always refers to self + dict set rewrite_record implementation [dict get $doomed_record implementation] + lset stack $rewrite_posn $rewrite_record + dict set all_stacks $command $stack + } + set stack [lreplace $stack $doomed_posn $doomed_posn] + dict set all_stacks $command $stack + + } + return $stack + } + return [list] + } + + proc show_stack {{commandname_glob *}} { + variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns + return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] + } else { + set result "" + set matchedkeys [dict keys $all_stacks $commandname_glob] + #don't try to calculate widest on empty list + if {[llength $matchedkeys]} { + set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] + set indent [string repeat " " [expr {$widest + 3}]] + set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide + set padkey [string repeat " " 20] + foreach k $matchedkeys { + append result "$k = " + set i 0 + foreach stackmember [dict get $all_stacks $k] { + if {$i > 0} { + append result "\n$indent" + } + append result [string range "$i " 0 4] " = " + set j 0 + dict for {k v} $stackmember { + if {$j > 0} { + append result "\n$indent2" + } + set displaykey [string range "$k$padkey" 0 20] + append result "$displaykey = $v" + incr j + } + incr i + } + append result \n + } + } + return $result + } + } + + #review + #document when this is to be called. Wiping stacks without undoing renames seems odd. + proc Delete_stack {command} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + dict unset all_stacks $command + return 1 + } else { + return 1 + } + } + + #can be used to temporarily put a stack aside - should manually rename back when done. + #review - document how/when to use. example? intention? + proc Rename_stack {oldname newname} { + variable all_stacks + if {[dict exists $all_stacks $oldname]} { + if {[dict exists $all_stacks $newname]} { + error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" + } else { + #set stackval [dict get $all_stacks $oldname] + #dict unset all_stacks $oldname + #dict set all_stacks $newname $stackval + dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] + } + } + } +} + + + + + + + + +namespace eval commandstack::lib { + proc splitx {str {regexp {[\t \r\n]+}}} { + #snarfed from tcllib textutil::splitx to avoid the dependency + # Bugfix 476988 + if {[string length $str] == 0} { + return {} + } + if {[string length $regexp] == 0} { + return [::split $str ""] + } + if {[regexp $regexp {}]} { + return -code error "splitting on regexp \"$regexp\" would cause infinite loop" + } + + set list {} + set start 0 + while {[regexp -start $start -indices -- $regexp $str match submatch]} { + foreach {subStart subEnd} $submatch break + foreach {matchStart matchEnd} $match break + incr matchStart -1 + incr matchEnd + lappend list [string range $str $start $matchStart] + if {$subStart >= $start} { + lappend list [string range $str $subStart $subEnd] + } + set start $matchEnd + } + lappend list [string range $str $start end] + return $list + } + proc split_body {procbody} { + set marker "##" + set header "" + set code "" + set found_marker 0 + foreach ln [split $procbody \n] { + if {!$found_marker} { + if {[string trim $ln] eq $marker} { + set found_marker 1 + } else { + append header $ln \n + } + } else { + append code $ln \n + } + } + if {$found_marker} { + return [list $header $code] + } else { + return [list "" $procbody] + } + } +} + +package provide commandstack [namespace eval commandstack { + set version 0.4 +}] + + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config index 3a8e96a7..0ea2f344 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config @@ -49,6 +49,7 @@ set bootsupport_modules [list\ modules punk::aliascore\ modules punk::ansi::colourmap\ modules punk::ansi\ + modules punk::ansi::sauce\ modules punk::assertion\ modules punk::args\ modules punk::args::moduledoc::tclcore\ @@ -81,6 +82,7 @@ set bootsupport_modules [list\ modules punk::mix::commandset::scriptwrap\ modules punk::mod\ modules punk::nav::fs\ + modules punk::nav::ns\ modules punk::ns\ modules punk::overlay\ modules punk::path\ @@ -93,6 +95,7 @@ set bootsupport_modules [list\ modules punk::unixywindows\ modules punk::zip\ modules punk::winpath\ + modules overtype\ modules shellfilter\ modules shellrun\ modules shellthread\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.4.tm new file mode 100644 index 00000000..e4ea54d7 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.4.tm @@ -0,0 +1,5267 @@ +# -*- 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.7.4 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin overtype_module_overtype 0 1.7.4] +#[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 "ANSI capable 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 [expr {$renderwidth + 1}] + } else { + return $endpos + } + } + } +} + +tcl::namespace::eval overtype { + #*** !doctools + #[subsection {Namespace overtype}] + #[para] Core API functions for overtype + #[list_begin definitions] + + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + interp alias "" ::overtype::example "" ::punk::args::helpers::example + } + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::overtype::renderspace + @cmd -name overtype::renderspace\ + -summary\ + {}\ + -help\ + {} + @opts + #because underblocks value is optional - restrict opts to flag pairs (no solos) + #We don't use punk::args::parse in the actual function to parse args - so keep it simpler. + -bias -default left -type string -choices {left right} -help ignored + -width -default \uFFEF -type integer + -height -default \uFFEF -type integer + -startcolumn -default 1 -type integer + -startrow -default 1 -type integer + -ellipsis -default 0 -type boolean + -ellipsistext -default ${$::overtype::default_ellipsis_horizontal} -type char + -ellipsiswhitespace -default 0 -type boolean + -expand_right -default 0 -type boolean + -appendlines -default 1 -type boolean + -transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\ + "0 to disable transparency processing + 1 to enable space characters in the + overlay to be transparent, or a regex + to match the character(s) required to be + transparent in the overlay." + -exposed1 -default \uFFFD -type char -help\ + {A character of single terminal column width to use + as replacement when first-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the second-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -exposed2 -default \uFFFD -type char -help\ + {A character of single terminal column width to use + as replacement when second-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the first-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + + -experimental -default 0 + -cp437 -default 0 -type boolean + -looplimit -default \uFFEF\ -type integer -help\ + "internal failsafe - experimental" + -crm_mode -default 0 -type boolean + -reverse_mode -default 0 -type boolean + -insert_mode -default 1 -type boolean + -wrap -default 0 -type boolean + -info -default 0 -type boolean -help\ + "When set to 1, return a dictionary (experimental)" + -binarytext -default "" -type string -choices {"" bios ice} + -console -default {stdin stdout stderr} -type list + + @values -min 1 -max 2 + underblock -type string -optional 1 + overblock -type string -optional 0 + }] + } + + + #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] < 1} { + 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 { + #no solo flags - so we assume only an overblock was supplied + set overblock [lindex $args end] + set underblock "" + set argsflags [lrange $args 0 end-1] + + #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\ + -startrow 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\ + -binarytext ""\ + -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 - -startrow - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace + - -transparent - -exposed1 - -exposed2 - -experimental + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -info - -binarytext - -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_startrow [tcl::dict::get $opts -startrow] + 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] + set opt_binarytext [tcl::dict::get $opts -binarytext] + + + + # ---------------------------- + # -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] + if {$opt_startrow > 1} { + set down [expr {$opt_startrow -1}] + set overblock [punk::ansi::move_down $down]$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 mixed $overblock] + } + 1 { + #todo + set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 2 { + #todo + #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 { + #todo + #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] + switch -- $opt_binarytext { + "" { + foreach ln [split $overblock \n] { + lappend inputchunks [list mixed $ln\n] + } + if {[llength $inputchunks]} { + lset inputchunks end 1 [tcl::string::range [lindex $inputchunks end 1] 0 end-1] + } + } + bios { + #16 fg, 8 fg + possible blink + set input "" + set ansisplit [list ""] + set charpair 0 + foreach {ch at} [split $overblock ""] { + #review - does binarytext only apply to cp437??? we need to know the original encoding + set at [encoding convertto cp437 $at] + if {[catch {punk::ansi::colour::byteAnsi $at} code]} { + puts stderr "renderspace err at charpair: $charpair [punk::ansi::ansistring VIEW ${ch}${at}]" + #append input [punk::ansi::a+ brightred White] \uFFef + set code [punk::ansi::a+ brightred White] + set ch \uFFeF + } + append input $code $ch + lappend ansisplit $code $ch + incr charpair + } + #lappend inputchunks [list mixed $input] + lappend inputchunks [list ansisplit $ansisplit] + } + ice { + #16 fg, 16 bg (no blink) + set input "" + foreach {ch at} [split $overblock ""] { + set at [encoding convertto cp437 $at] + append input [punk::ansi::colour::byteAnsiIce $at]$ch + } + lappend inputchunks [list mixed $input] + } + } + } + } + + + + + 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]} { } + set renderedrow "" + while {[llength $inputchunks]} { + #set overtext [lpop inputchunks 0] ;#could be a list 'ansisplit' or text 'plain|mixed' + lassign [lpop inputchunks 0] overtext_type overtext + + #use eq test with emptystring instead of 'string length' - test for emptiness shouldn't cause shimmering if popped inputchunks member if an 'ansisplit' list + if {$overtext eq ""} { + incr loop + continue + } + #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" + set undertext [lindex $outputlines [expr {$row -1}]] + + #renderline pads each underaly line to width with spaces and should track where end of data is + + switch -- $overtext_type { + mixed { + set overtext $replay_codes_overlay$overtext + } + ansisplit { + ledit overtext -1 -1 "" $replay_codes_overlay + } + default { + error "renderspace unsupported overtext type: $overtext_type overtext: $overtext" + } + } + + + ###################### + #debug + #set partinfo "" + #if {$overtext_type eq "ansisplit"} { + # set partinfo [llength $overtext] + #} else { + # set partinfo [string length $overtext] + #} + #if {$renderedrow eq $row} { + # puts -nonewline stderr <$row>$overtext_type$partinfo + #} else { + # puts -nonewline stderr \n<$row>$overtext_type$partinfo + #} + #if {$overtext_type eq "mixed"} { + # puts -nonewline stderr "\n[ansistring VIEW $overtext]\n" + #} + ###################### + + set renderedrow $row + + 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\ + -overtext_type $overtext_type\ + ] + 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 unapplied_ansisplit [tcl::dict::get $rinfo unapplied_ansisplit] + 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_list [list] + + + #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 "" + } + } + # ---- + # review + set col $post_render_col + #just because it's out of range of the renderwidth - doesn't mean a move down should jump to witin the range - 2025 + #---- + + #set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + #set lastdatacol [punk::ansi::printing_length $existingdata] + + #set col [expr {$lastdatacol+1}] + + #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.. + + #todo!!! + # 2025 fix - this does nothing - so what uses it?? create a test! + 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] + #JMN + #ledit inputchunks -1 -1 $overflow_right$unapplied + + set pt_ansi_pt [punk::ansi::ta::split_codes_single $overflow_right] + #join the trailing and leading pt parts of the 2 lists + ledit pt_ansi_pt end end "[lindex $pt_ansi_pt end][lindex $unapplied_ansisplit 0]" + lappend pt_ansi_pt [lrange $unapplied_ansisplit 1 end] + + ledit inputchunks -1 -1 [list ansisplit $pt_ansi_pt] ;#combined overflow_right and unapplied - in ansisplit form + + set overflow_right "" + set unapplied "" + set unapplied_list [list] + set unapplied_ansisplit [list] + + 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 ""]] + ledit outputlines $renderedrow-1 $renderedrow-2 {*}[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 stderr "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + + + #renderspace gives us an overflow when there is a grapheme followed by a non-grapheme + #This gives us some possible(probable) leading ANSI (which is probably SGR, or it would have triggered something else) + #followed by a sequence of 1 or more graphemes and some more unprocessed ANSI (which could be anything: SGR,movement etc) + #we want to strip out this leading run of graphemes + #NOTE: 2025 - comment is obsolete/inaccurate. We only ever get 1 grapheme - as prior were consumed/ignored by renderline + #REVIEW!!! + + #example trigger: textblock::frame -width 80 [ansicat us-pump_up_the_jam-355.ans 355x100] + + 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 + #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 drop_graphemes [list] ;#list of contiguous grapheme indices + set new_unapplied_list [list] + set unapplied_ansisplit [list ""] + set idx 0 + + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + #puts stderr "g$idx:$u" + if {![llength $drop_graphemes] || $idx == [lindex $drop_graphemes end]+1} { + #we are in the first run of uninterrupted graphemes + #drop by doing nothing with it here + lappend drop_graphemes $idx + } else { + lappend new_unapplied_list $u + ledit unapplied_ansisplit end end "[lindex $unapplied_ansisplit end]$u" + } + } else { + lappend new_unapplied_list $u + lappend unapplied_ansisplit $u "" + } + incr idx + } + #debug + if {[llength $drop_graphemes]} { + set idx0 [lindex $drop_graphemes 0] + set dbg "" + if {$idx0 > 0} { + for {set i 0} {$i < $idx0} {incr i} { + #leading SGR + append dbg [lindex $unapplied_list $i] + } + } + foreach idx $drop_graphemes { + append dbg [lindex $unapplied_list $idx] + } + puts stderr "dropped[llength $drop_graphemes]:$dbg\x1b\[m" + } + set unapplied [join $new_unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + set unapplied_list $new_unapplied_list + + #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] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient to re-split (return unapplied_tagged instead of unapplied_ansisplit?) + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] + } 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] ""] + ledit unapplied_list $triggering_grapheme_index $triggering_grapheme_index + set unapplied [join $unapplied_list ""] + #review - inefficient + puts -nonewline stderr . + set unapplied_ansisplit [punk::ansi::ta::split_codes_single $unapplied] + } + } + + } + 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 + set overflow_right_pt_code_pt [punk::ansi::ta::split_codes_single $overflow_right] + if {![llength $nextprefix_list]} { + set nextprefix_list $overflow_right_pt_code_pt + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $overflow_right_pt_code_pt 0]" + lappend nextprefix_list {*}[lrange $overflow_right_pt_code_pt 1 end] + } + } + + #append nextprefix $unapplied + if {![llength $nextprefix_list]} { + set nextprefix_list $unapplied_ansisplit + } else { + #merge tail and head + ledit nextprefix_list end end "[lindex $nextprefix_list end][lindex $unapplied_ansisplit 0]" + lappend nextprefix_list {*}[lrange $unapplied_ansisplit 1 end] + } + + 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 {[llength $nextprefix_list]} { + #set inputchunks [linsert $inputchunks 0 $nextprefix] + #JMN - assume backwards compat ledit available from punk::lib (for tcl <9) + ledit inputchunks -1 -1 [list ansisplit $nextprefix_list] + } + + + 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 + variable optimise_ptruns 5 + + + + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::overtype::renderline + @cmd -name overtype::renderline\ + -summary\ + {Render a line of text/ANSI input over a line of text.}\ + -help\ + {renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode + commandline repl for the Tcl Punk Shell. + It is also a central part of an ansi (micro) virtual terminal-emulator of sorts. + 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. + Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't + affect another. + Calling on the punk::ansi library - it can coalesce codes to keep the size down. + + It is a giant mess of doing exactly what common wisdom says not to do... lots at once. + Renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a + static underlay. + 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. + The overlay couuld be similar - in which case it may often be used to overwrite a column or section of + the underlay. + The overlay could however be a sequence of ANSI-laden text that jumps all over the place. + + 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. + By suppyling the ${$B}-info${$N} 1 option - it can return various fields indicating the state of the render. + The main 3 are: result, overflow_right, and unapplied. + 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. + } + @opts + -etabs -default 0 -type boolean + -width -default \uFFEF -type integer + -expand_right -default 0 -type boolean + -transparent -default 0 -type {literal(0)|literal(1)|regexp} -help\ + "0 to disable transparency processing + 1 to enable space characters in the + overlay to be transparent, or a regex + to match the character(s) required to be + transparent in the overlay." + -startcolumn -default 1 -type integer + -cursor_column -default 1 -type integer -help\ + {First column is 1. Cursor column can be zero or negative} + -cursor_row -default "" -type integer + -insert_mode -default 1 -type boolean + -crm_mode -default 0 -type boolean + -autowrap_mode -default 1 -type boolean + -reverse_mode -default 0 -type boolean + -info -default 0 -type boolean -help\ + "When set to 1, return a dictionary of settings useful for + processing ANSI input in a loop. When zero, the resulting + string will contain the updated line, but not all the + overtext may have been applied." + -exposed1 -default \uFFFD -help\ + {A character of single terminal column width to use + as replacement when first-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the second-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -exposed2 -default \uFFFD -help\ + {A character of single terminal column width to use + as replacement when second-half of an underlying char + is exposed due to overlay positioning/transparency + which obscures the first-half of the char. May be ANSI + coloured as this doesn't affect the display width. + Default is \uFFFD - the unicode replacement char.} + -cursor_restore_attributes -default "" + -cp437 -default 0 -type boolean + -experimental -default {} + -overtext_type -type string -choices {mixed plain ansisplit} -default mixed + @values -min 2 -max 2 + undertext -type string -help\ + "A single line of text which may contain pre-rendered ANSI. + 'pre-rendered' in this context means that it may contain + various static ANSI codes such as SGR colours and attributes + but not motion-control or more complex ANSI sequences. + It is an error to supply a newline (lf) character in the + undertext." + overtext -type string -help\ + "ANSI (or plain text) to overlay onto the undertext. + May contain ANSI movement codes even if they would move the + cursor to another line. If -info is zero, the output will + only display up to the point where the cursor moved off-line. + If -info is 1, the line moved to may be reflected in the + cursor_row element of the result. Overtext may contain an lf + which is effectively a form of 'movement control' to increment + the row. + Other ANSI codes may perform operations such as changing the + insert_mode or reverse_mode - and these are reflected in the + result dictionary when '-info 1' is used, so that the state + can then be applied to subsequent lines." + }] + } + + proc renderline {args} { + #todo - fix 'unapplied' mechanism.This is particularly inefficient for long lines, or data such as binarytext which is not line-based. + #All unapplied data is re-split/reprocessed repeatedly for each line! This is very wasteful and slow. + + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # 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? + + + + #*** !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 {}\ + -overtext_type mixed\ + ] + #-overtext_type plain|mixed|ansisplit + + #-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 - -overtext_type { + 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] + set opt_overtext_type [tcl::dict::get $opts -overtext_type] + 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] + } + + #review - is untabifying sensible at this point?? + if {$opt_overtext_type eq "ansisplit"} { + #todo - something for each pt part? + } else { + #plain|mixed + 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} { + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + #puts -nonewline stderr !$ptlen! + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + #we need to store the gx0 state per column - as characters with or without gx0 can be overlayed anywhere + 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] + } + + + #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 {$opt_overtext_type eq "ansisplit"} { + set overmap $overdata + lset overmap 0 "$startpadding[lindex $overmap 0]" + } else { + if {[punk::ansi::ta::detect $overdata]} { + #TODO!! rework this. + #e.g 200K+ input file with no newlines - we are wastefully calling split_codes_single repeatedly on mostly the same data. + #set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + set overmap [punk::ansi::ta::split_codes_single $overdata] + lset overmap 0 "$startpadding[lindex $overmap 0]" + + } 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 + set overlay_grapheme_control_stacks [list] + #REVIEW - even if we pass in a pre-split overtext (-overtext_type ansisplit) + #we are re-generating the overlay_grapheme_control_stacks list each time + #this is a big issue when overtext is not broken into lines, but is just a big long ansi and/or plain text string. + #todo - return also the unapplied portion of the 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] + #puts -nonewline stderr "!$len!" + + #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 {\x1b\[[0-1];[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?t} $code]} { + #pablodraw 24bit color - convert to standard sgr RGB code + #we could do a more precise 000-255 regexp for each r g b, something like: ((?:[0-1]?[0-9]?[0-9])|(?:2[0-4][0-9])|(?:25[0-5])) + #but that seems more expensive for little likely use (?) review + lassign [regexp -all -inline {\x1b\[([0-1]);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?)t} $code] _ isfg pablo_r pablo_g pablo_b + #todo - if any r g b value > 255 - add as [list other $code] + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + set dup_posns [lsearch -all -exact $o_codestack $rgbcode] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $rgbcode + lappend overlay_grapheme_control_list [list sgr $rgbcode] + } 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 - gx0 should just be a flag like autowrap_mode and insert_mode? + 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 unapplied_ansisplit [list ""] ;#pt code ... pt + + 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_to_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 ""]] + #JMN - backwards compat ledit from punk::lib for tcl <9 + ledit unapplied_list -1 -1 {*}[split $chars ""] + set unapplied [join $unapplied_list ""] + lset unapplied_ansisplit 0 $chars ;#no existing ? + + #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_to_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_to_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_to_unapplied $overlay_grapheme_control_list $gci + break + } else { + incr cursor_row + #don't adjust the overflow_idx + priv::render_to_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_to_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_to_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_to_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} { + 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_to_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 + } elseif {0 && $next_type ne "g"} { + incr idx_over -1 + 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] ;#will get index $i out of range error + lappend understacks [list] ;#REVIEW + 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_to_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 ""]] + #JMN + ledit unapplied_list -1 -1 {*}[split $chars ""] + set unapplied [join $unapplied_list ""] + #ledit unapplied_ansisplit -1 -1 $chars + lset unapplied_ansisplit 0 $chars ;#?? + + 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 { + #JMN + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. leadernorm: [ansistring VIEW -lf 1 $leadernorm] code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + puts stderr "ARGS:" + foreach a $args { + puts stderr " $a" + } + puts stderr ----- + foreach {xpt ycode} $overmap { + puts stderr "t:'$xpt'" + puts stderr "c:[ansistring VIEW $ycode]" + } + #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_to_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_to_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_to_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_to_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_to_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_to_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_to_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_to_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_to_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_to_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] + set unapplied_ansisplit [list ""] ;#remove below if nothing added + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + switch -- $type { + g { + lappend unapplied_list $item + ledit unapplied_ansisplit end end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" + } + } + #incr idx_over + } + set unapplied [join $unapplied_list ""] + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [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} { + 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" + } + } + } + t { + set params [split $param {;}] + if {[llength $params] == 4} { + #pablodraw 24bit color + #see also: https://github.com/ansilove/libansilove/blob/master/src/loaders/ansi.c + lassign $params isfg pablo_r pablo_g pablo_b + #e.g esc\[0\;171\;87\;0t + set stack [lindex $overlay_grapheme_control_stacks $gci] + puts stderr "pablodraw debug [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #foreach s $stack { + # puts stderr " - [ansistring VIEW -lf 1 -vt 1 -nul 1 $s]" + #} + #we expect first param to be 0 for background, 1 for foreground + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + #too late here !! + #lappend stack $rgbcode + #lset overlay_grapheme_control_stacks $gci $stack + + } else { + puts stderr "overtype::renderline unrecognised custom CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + default { + puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + 7ESC { + # + #re_other_single {\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_to_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_to_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_to_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_to_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 && $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_to_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}] + } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + + 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\ + unapplied_ansisplit $unapplied_ansisplit\ + 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 unapplied_ansisplit [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_ansisplit]] + 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::renderline_transparent {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 + } + proc render_to_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + + #----------------------------------------- + #review - this is a lot of copies of the same thing. + # ultimately we want to reduce expensive things like redundant grapheme-splits + # perhaps unapplied_tagged of some sort e.g - {g g code pt } ?? + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar unapplied_ansisplit unapplied_ansisplit ;# pt ?code pt...? + #----------------------------------------- + + + 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 unapplied_ansisplit [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 + lappend unapplied_ansisplit $sgr_merged "" + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + #types g other sgr gx0 + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" + } + } + } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + 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 unapplied_ansisplit unapplied_ansisplit + #-------------- + + 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 unapplied_ansisplit [list ""] ;#remove empty entry at end if nothing added + + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + lappend unapplied_ansisplit $sgr_merged "" + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci end] { + lassign $gc type item + #types g other sgr gx0 + switch -- $type { + g { + lappend unapplied_list $item + lset unapplied_ansisplit end [string cat [lindex $unapplied_ansisplit end] $item] + } + gx0 { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + lappend unapplied_ansisplit "\x1b(0" "" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + lappend unapplied_ansisplit "\x1b(B" "" + } + } + default { + lappend unapplied_list $item + lappend unapplied_ansisplit $item "" + } + } + } + if {[llength $unapplied_ansisplit] == 1 && [lindex $unapplied_ansisplit 0] eq ""} { + set unapplied_ansisplit [list] + } + 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] + #JMN insert via ledit + ledit o $i $i-1 $c + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + #set ustacks [linsert $ustacks $i $sgrstack] + #set gxstacks [linsert $gxstacks $i $gx0stack] + #insert via ledit + ledit ustacks $i $i-1 $sgrstack + ledit gxstacks $i $i-1 $gx0stack + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +tcl::namespace::eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::overtype ::overtype::argdoc +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide overtype [tcl::namespace::eval overtype { + variable version + set version 1.7.4 +}] +return + +#*** !doctools +#[manpage_end] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index 04767a22..45f53981 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -681,12 +681,16 @@ tcl::namespace::eval punk::ansi { } set opt_crm_mode [dict get $opts -crm_mode] - #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines - package require punk::ansi::sauce set binarytext "" - if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { - #no 128 Byte SAUCE record at end of file - set sdict [dict create] + set sdict [dict create] + #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines + if {![catch {package require punk::ansi::sauce}]} { + if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { + #no 128 Byte SAUCE record at end of file + set sdict [dict create] + } + } else { + puts stderr "Warning punk::ansi::sauce package not loaded - unable to detect or use any SAUCE data to aid in display" } if {![dict size $sdict]} { if {[string tolower [file extension $fname]] eq ".bin"} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm new file mode 100644 index 00000000..79ea5901 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi/sauce-0.1.0.tm @@ -0,0 +1,628 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::ansi::sauce 0.1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + + + +tcl::namespace::eval punk::ansi::sauce { + variable PUNKARGS + namespace eval argdoc { + variable PUNKARGS + #non-colour SGR codes + set I "\x1b\[3m" ;# [a+ italic] + set NI "\x1b\[23m" ;# [a+ noitalic] + set B "\x1b\[1m" ;# [a+ bold] + set N "\x1b\[22m" ;# [a+ normal] + set T "\x1b\[1\;4m" ;# [a+ bold underline] + set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] + } + + proc from_file {fname} { + if {[file size $fname] < 128} { + return + } + set fd [open $fname r] + chan conf $fd -translation binary + chan seek $fd -128 end + set srec [read $fd] + set srec_len 128 ;#This is the normal length of a SAUCE record - we may need to set it shorter if truncation detected + if {[catch {set sdict [to_dict $srec]}]} { + #review - have seen truncated SAUCE records < 128 bytes + #we could search for SAUCE00 in the tail and see what records can be parsed? + #specifically publicdomain roysac images sometimes only 99 Bytes of sauce - suspect remaining were null \x0 padded and trimmed + set sauceposn [string first SAUCE00 $srec] + if {$sauceposn <= 0} { + close $fd + return + } + #emit something to give user an indication something isn't right + puts stderr "punk::ansi::sauce::from_file WARNING SAUCE record seems to be truncated - padding rhs with nulls and trying again.." + #SAUCE00 is not at the beginning + #pad the tail with nulls and try again + set srec [string range $srec $sauceposn end] + set srec_len [string length $srec] + set srec ${srec}[string repeat \x0 [expr {128 - [string length $srec]}]] + if {[catch {set sdict [to_dict $srec]}]} { + close $fd + return + } + dict set sdict warning "SAUCE truncation to $srec_len bytes detected" + } + if {[dict exists $sdict comments] && [dict get $sdict comments] > 0} { + set clines [dict get $sdict comments] + #Use srec_len instead of 128 - in case we had truncated source record which we padded and were able to parse + set offset [expr {-1 *($srec_len + ($clines * 64) + 5)}] + chan seek $fd $offset end + set tag [chan read $fd 5] + if {$tag eq "COMNT"} { + #'character' data - shouldn't be null terminated c-style string - but can be + set commentlines [list] + for {set c 0} {$c < $clines} {incr c} { + set rawline [chan read $fd 64] + set str [lib::get_string $rawline] + set ln [format %-64s $str] + + if {![catch {encoding convertfrom cp437 $ln} line]} { + lappend commentlines $line + } else { + catch { + package require punk::ansi + puts stderr "punk::ansi::sauce::from_file failed to decode (from cp437) comment line:[punk::ansi::ansistring VIEW $ln]" + } + lappend commentlines [string repeat " " 64] + } + } + dict set sdict commentlines $commentlines + } + } + close $fd + return $sdict + } + + set datatypes [dict create] + dict set datatypes 0 none + dict set datatypes 1 character + dict set datatypes 2 bitmap + dict set datatypes 3 vector + dict set datatypes 4 audio + dict set datatypes 5 binarytext + dict set datatypes 6 xbin + dict set datatypes 7 archive + dict set datatypes 8 executable + + set filetypes [dict create] + + #Character + dict set filetypes 1 0 [list name "ASCII" description "Plain ASCII text file with no formatting codes or color codes."] + dict set filetypes 1 1 [list name "ANSi" description "A file with ANSi coloring codes and cursor positioning."] + dict set filetypes 1 2 [list name "ANSiMation" description "Like an ANSi file, but it relies on a fixed screensize."] + dict set filetypes 1 3 [list name "RIP script" description "Remote Imaging Protocol Graphics."] + dict set filetypes 1 4 [list name "PCBoard" description "A file with PCBoard color codes and macros, and ANSi codes."] + dict set filetypes 1 5 [list name "Avatar" description "A file with Avatar color codes, and ANSi codes."] + dict set filetypes 1 6 [list name "HTML" description "HyperText Markup Language."] + dict set filetypes 1 7 [list name "Source" description "Source code for some programming language.\nThe file extension should determine the programming language."] + dict set filetypes 1 8 [list name "TundraDraw" description "A TundraDraw file.\nLike ANSi, but with a custom palette."] + + #Bitmap + dict set filetypes 2 0 [list name "GIF" description "CompuServe Graphics Interchange Format"] + dict set filetypes 2 1 [list name "PCX" description "ZSoft Paintbrush PCX"] + dict set filetypes 2 2 [list name "LBM/IFF" description "DeluxePaint LBM/IFF"] + dict set filetypes 2 3 [list name "TGA" description "Targa Truecolor"] + dict set filetypes 2 4 [list name "FLI" description "Autodesk FLI animation"] + dict set filetypes 2 5 [list name "FLC" description "Autodesk FLC animation"] + dict set filetypes 2 6 [list name "BMP" description "Windows or OS/2 Bitmap"] + dict set filetypes 2 7 [list name "GL" description "Grasp GL Animation"] + dict set filetypes 2 8 [list name "DL" description "DL Animation"] + dict set filetypes 2 9 [list name "WPG" description "Wordperfect Bitmap"] + dict set filetypes 2 10 [list name "PNG" description "Portable Network Graphics"] + dict set filetypes 2 11 [list name "JPG/JPeg" description "JPeg image (any subformat)"] + dict set filetypes 2 12 [list name "MPG" description "MPeg video (any subformat)"] + dict set filetypes 2 12 [list name "AVI" description "Audio Video Interleave (any subformat)"] + + #vector + dict set filetypes 3 0 [list name "DXF" description "CAD Drawing eXchange Format"] + dict set filetypes 3 1 [list name "DWG" description "AutoCAD Drawing File"] + dict set filetypes 3 2 [list name "WPG" description "WordPerfect or DrawPerfect vector graphics"] + dict set filetypes 3 3 [list name "3DS" description "3D Studio"] + + #Audio + dict set filetypes 4 0 [list name "MOD" description "4, 6 or 8 channel MOD (Noise Tracker)"] + dict set filetypes 4 1 [list name "669" description "Renaissance 8 channel 669"] + dict set filetypes 4 2 [list name "STM" description "Future Crew 4 channel ScreamTracker"] + dict set filetypes 4 3 [list name "S3M" description "Future Crew variable channel ScreamTracker 3"] + dict set filetypes 4 4 [list name "MTM" description "Renaissance variable channel MultiTracker"] + dict set filetypes 4 5 [list name "FAR" description "Farandole composer"] + dict set filetypes 4 6 [list name "ULT" description "UltraTracker"] + dict set filetypes 4 7 [list name "AMF" description "DMP/DSMI Advanced Module Format"] + dict set filetypes 4 8 [list name "DMF" description "Delusion Digital Music Format (XTracker)"] + dict set filetypes 4 9 [list name "OKT" description "Oktalyser"] + dict set filetypes 4 10 [list name "ROL" description "AdLib ROL file (FM audio)"] + dict set filetypes 4 11 [list name "CMF" description "Creative Music File (FM Audio)"] + dict set filetypes 4 12 [list name "MID" description "MIDI (Musical Instrument Digital Interface)"] + dict set filetypes 4 13 [list name "SADT" description "SAdT composer (FM Audio)"] + dict set filetypes 4 14 [list name "VOC" description "Creative Voice File"] + dict set filetypes 4 15 [list name "WAV" description "Waveform Audio File Format"] + dict set filetypes 4 16 [list name "SMP8" description "Raw, single channel 8 bit sample"] + dict set filetypes 4 17 [list name "SMP8S" description "Raw, stereo 8 bit sample"] + dict set filetypes 4 18 [list name "SMP16" description "Raw, single channel 16 bit sample"] + dict set filetypes 4 19 [list name "SMP16S" description "Raw, stereo 16 bit sample"] + dict set filetypes 4 20 [list name "PATCH8" description "8 Bit patch file"] + dict set filetypes 4 21 [list name "PATCH16" description "16 Bit patch file"] + dict set filetypes 4 22 [list name "XM" description "FastTracker \]\[ module"] + dict set filetypes 4 23 [list name "HSC" description "HSC Tracker (FM Audio)"] + dict set filetypes 4 24 [list name "IT" description "Impulse Tracker"] + + #Archive + dict set filetypes 7 0 [list name "ZIP" description "PKWare Zip"] + dict set filetypes 7 1 [list name "ARJ" description "Archive Robert K. Jung"] + dict set filetypes 7 2 [list name "LZH" description "Haruyasu Yoshizaki (Yoshi)"] + dict set filetypes 7 3 [list name "ARC" description "S.E.A"] + dict set filetypes 7 4 [list name "TAR" description "Unix TAR"] + dict set filetypes 7 5 [list name "ZOO" description "ZOO"] + dict set filetypes 7 6 [list name "RAR" description "RAR"] + dict set filetypes 7 7 [list name "UC2" description "UC2"] + dict set filetypes 7 8 [list name "PAK" description "PAK"] + dict set filetypes 7 9 [list name "SQZ" description "SQZ"] + + + #review + #map sauce encodings to those that exist by default in Tcl 'encoding names' + set encodings [dict create] + dict set encodings 437 cp437 + dict set encodings 720 cp1256 ;#Arabic + dict set encodings 737 cp737 + dict set encodings 775 cp775 + dict set encodings 819 iso8859-1 ;#Latin-1 Supplemental - review + dict set encodings 850 cp850 + dict set encodings 852 cp852 + dict set encodings 855 cp855 + dict set encodings 857 cp857 + #dict set encodings 858 "" ;#??? + dict set encodings 860 cp860 ;#Porguguese + dict set encodings 861 cp861 ;#Icelandic + dict set encodings 862 cp862 ;#Hebrew + dict set encodings 863 cp863 ;#French Canada + dict set encodings 864 cp864 + dict set encodings 865 cp865 + dict set encodings 866 cp866 ;#Cyrillic + dict set encodings 869 cp869 + #dict set encodings 872 "" ;#Cyrillic - cp855? macCyrillic? + #dict set encodings KAM "" ;#cp867,cp895 ? + #dict set encodings MAZ "" ;#cp667 cp790 ? + dict set encodings MIK cp866 ;#Cyrillic + + + + + #todo - fontName - which can also specify e.g code page 437 + ## Font name [1] Font size Resolution [2] Aspect ratio [3] Vertical stretch [6] Description + ## Display [4] Pixel [5] + + set fontnames [dict create] + + ## IBM VGA 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for 80×25 text mode (code page 437) + dict set fontnames "IBM VGA" [list fontsize "9x16" resolution "720x400" aspect_ratio_display "4:3" aspect_ratio_pixel "20:27 (1:1.35)" vertical_stretch "35%" description "Standard hardware font on VGA cards for 80×25 text mode (code page 437)"] + ## IBM VGA ### [8] 9×16 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA 80×25 text mode + # - where ### is placeholder for 437,720,737 etc + + ## IBM VGA50 ### [8] 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Software installed code page font for VGA condensed 80×50 text mode + ## IBM VGA25G ### [8] 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color). + + ## 8×16 640×400 4:3 6:5 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA" or code page variant. + ## IBM VGA50 9×8 [7] 720×400 4:3 20:27 (1:1.35) 35% Standard hardware font on VGA cards for condensed 80×50 text mode (code page 437) + ## 8×8 640×400 4:3 5:6 (1:1.2) 20% Modified stats when using an 8 pixel wide version of "IBM VGA50" or code page variant. + ## IBM VGA25G 8×19 640×480 4:3 1:1 0% Custom font for emulating 80×25 in VGA graphics mode 12 (640×480 16 color) (code page 437). + ## IBM EGA 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for 80×25 text mode (code page 437) + ## IBM EGA43 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Standard hardware font on EGA cards for condensed 80×43 text mode (code page 437) + ## IBM EGA ### [8] 8×14 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA 80×25 text mode + ## IBM EGA43 ### [8] 8×8 640×350 4:3 35:48 (1:1.3714) 37.14% Software installed code page font for EGA condensed 80×43 text mode + ## Amiga Topaz 1 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) + ## Amiga Topaz 1+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 1.x font. (A500, A1000, A2000) + ## Amiga Topaz 2 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) + ## Amiga Topaz 2+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified Amiga Topaz Kickstart 2.x font (A600, A1200, A4000) + ## Amiga P0T-NOoDLE 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original P0T-NOoDLE font. + ## Amiga MicroKnight 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original MicroKnight font. + ## Amiga MicroKnight+ 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Modified MicroKnight font. + ## Amiga mOsOul 8×8 [9] 640×200 4:3 5:12 (1:2.4) 140% Original mOsOul font. + ## C64 PETSCII unshifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original Commodore PETSCII font (PET, VIC-20, C64, CBM-II, Plus/4, C16, C116 and C128) in the unshifted mode. Unshifted mode (graphics) only has uppercase letters and additional graphic characters. This is the normal boot font. + ## C64 PETSCII shifted 8×8 [10] 320×200 4:3 5:6 (1:1.2) 20% Original PETSCII font in shifted mode. Shifted mode (text) has both uppercase and lowercase letters. This mode is actuated by pressing Shift+Commodore key. + ## Atari ATASCII 8×8 [11] 320×192 4:3 4:5 (1:1.25) 25% Original ATASCII font (Atari 400, 800, XL, XE) + + + #expect a 128 Byte sauce record + #Some sauce records may have been padded with null bytes - and been truncated by some process + + proc to_dict {saucerecord} { + variable datatypes + variable filetypes + variable encodings + if {[string length $saucerecord] != 128} { + error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - length != 128" + } + if {![string match "SAUCE*" $saucerecord]} { + error "punk::ansi::sauce::to_dict: Unable to interpret data as a SAUCE record - does not begin with 'SAUCE'" + } + #tcl binary scan: cu - unsigned 8-bit, su - unsigned 16-bit, iu - unsigned 32bit, + set sdict [dict create] + dict set sdict version [string range $saucerecord 5 6] ;#2bytes + + #sauce spec says 'character' type is a string encoded according to code page 437 (IBM PC / OEM ASCII) + # - in the wild - string may be terminated with null and have following garbage + # - 'binary scan $rawchars C* str' to get null-terminated string and pad rhs with spaces to cater for this possibility + #"C" specifier not available in tcl 8.6 + + + #dict set sdict title [string range $saucerecord 7 41] ;#35 bytes 'character' + set rawtitle [string range $saucerecord 7 41] ;#35 bytes 'character' + set str [lib::get_string $rawtitle] + dict set sdict title [format %-35s $str] + + #dict set sdict author [string range $saucerecord 42 61] ;#20 bytes 'character' + set rawauthor [string range $saucerecord 42 61] ;#20 bytes 'character' + set str [lib::get_string $rawauthor] + dict set sdict author [format %-20s $str] + + #dict set sdict group [string range $saucerecord 62 81] ;#20 bytes 'character' + set rawgroup [string range $saucerecord 62 81] ;#20 bytes 'character' + set str [lib::get_string $rawgroup] + dict set sdict group [format %-20s $str] + + + #dict set sdict date [string range $saucerecord 82 89] ;#8 bytes 'character' + set rawdate [string range $saucerecord 82 89] ;#8 bytes 'character' + set str [lib::get_string $rawdate] + dict set sdict date [format %-8s $str] + + + if {[binary scan [string range $saucerecord 90 93] iu v]} { + #4 bytes - unsigned littlendian + dict set sdict filesize $v + } else { + dict set sdict filesize "" + } + if {[binary scan [string range $saucerecord 94 94] cu v]} { + #1 byte - unsigned + dict set sdict datatype $v + if {[dict exists $datatypes [dict get $sdict datatype]]} { + dict set sdict datatype_name [dict get $datatypes [dict get $sdict datatype]] + } else { + dict set sdict datatype_name unrecognised + } + } else { + dict set sdict datatype "" + dict set sdict datatype_name failed ;#unrecognised?? + } + if {[binary scan [string range $saucerecord 95 95] cu v]} { + #1 byte - unsigned + dict set sdict filetype $v + if {[dict exists $filetypes [dict get $sdict datatype] $v]} { + dict set sdict filetype_name [dict get $filetypes [dict get $sdict datatype] $v name] + } else { + dict set sdict filetype_name "" + } + } else { + dict set sdict filetype "" + dict set sdict filetype_name "" + } + if {[binary scan [string range $saucerecord 96 97] su v]} { + dict set sdict tinfo1 $v + } else { + dict set sdict tinfo1 "" + } + + if {[binary scan [string range $saucerecord 98 99] su v]} { + dict set sdict tinfo2 $v + } else { + dict set sdict tinfo2 "" + } + + + if {[binary scan [string range $saucerecord 100 101] su v]} { + dict set sdict tinfo3 $v + } else { + dict set sdict tinfo3 "" + } + if {[binary scan [string range $saucerecord 102 103] su v]} { + dict set sdict tinfo4 $v + } else { + dict set sdict tinfo4 "" + } + if {[binary scan [string range $saucerecord 104 104] cu v]} { + #1 byte - unsigned + dict set sdict comments $v + } else { + dict set sdict comments 0 + } + if {[dict get $sdict datatype_name] in {character binarytext} && [binary scan [string range $saucerecord 105 105] cu v]} { + dict set sdict tflags $v + if {$v & 1} { + dict set sdict ansiflags_ice 1 + } else { + dict set sdict ansiflags_ice 0 + } + set bits [format %08b $v] + set ls [string range $bits 5 6] + switch -- $ls { + "00" { + dict set sdict ansiflags_letterspacing unspecified + } + "01" { + dict set sdict ansiflags_letterspacing 8 + } + "10" { + dict set sdict ansiflags_letterspacing 9 + } + "11" { + dict set sdict ansiflags_letterspacing invalid + } + } + set ar [string range $bits 3 4] + switch -- $ar { + "00" { + dict set sdict ansiflags_aspectratio unspecified + } + "01" { + dict set sdict ansiflags_aspectratio tallpixels + } + "10" { + dict set sdict ansiflags_aspectratio squarepixels + } + "11" { + dict set sdict ansiflags_aspectratio invalid + } + } + } else { + dict set sdict tflags "" + } + set rawzstring [string range $saucerecord 106 127] + set str [lib::get_string $rawzstring] + dict set sdict tinfos $str + + + + switch -- [string tolower [dict get $sdict filetype_name]] { + ansi - ascii - pcboard - avatar { + dict set sdict columns [dict get $sdict tinfo1] + dict set sdict rows [dict get $sdict tinfo2] + dict set sdict fontname [dict get $sdict tinfos] + } + ansimation { + dict set sdict columns [dict get $sdict tinfo1] + #review - fixed screen height? + dict set sdict rows [dict get $sdict tinfo2] + dict set sdict fontname [dict get $sdict tinfos] + } + } + switch -- [dict get $sdict datatype] { + 5 { + #binarytext + #filetype is supposed to represent half the characterwidth (only widths with multiples of 2 can be specified) + #HOWEVER - in the wild we may see width/height specified in tinfo1/tinfo2 with some other value in filetype (eg 1) + #If both tinfo1 and tinfo2 are non zero - we will use them, even though it's not in spec. + set t1 [dict get $sdict tinfo1] + if {$t1 eq ""} { + set t1 0 + } + set t2 [dict get $sdict tinfo2] + if {$t2 eq ""} { + set t2 0 + } + if {$t1 != 0 && $t2 != 0} { + #not to spec - but we will assume these have values for a reason.. + puts stderr "punk::ansi::sauce::to_dict using tinfo1/tinfo2 data for columns/rows (non-compliant SAUCE data)" + dict set sdict columns [expr {2 * $t1}] + dict set sdict rows $t2 + } else { + #proper mechanism to specify columns for binarytext is the datatype field. + + set cols [expr {2*[dict get $sdict filetype]}] + dict set sdict columns $cols + #rows must be calculated from file size + #rows = (filesize - sauceinfosize)/ filetype * 2 * 2 + #(time additional 2 due to character/attribute pairs) + + #todo - calc filesize from total size of file - EOF - comment - sauce rather than rely on stored filesize? + dict set sdict rows [expr {[dict get $sdict filesize]/($cols * 2)}] + } + + } + 6 { + #xbin - only filtype is 0 + #https://web.archive.org/web/20120204063040/http://www.acid.org/info/xbin/x_spec.htm + dict set sdict columns [dict get $sdict tinfo1] + dict set sdict rows [dict get $sdict tinfo2] + dict set sdict fontname [dict get $sdict tinfos] + } + } + if {[dict exists $sdict fontname]} { + set fname [dict get $sdict fontname] + #IBM VGA and IBM EGA variants are all cp437 - unless a 3 letter code specifying otherwise follows + switch -- [string range $fname 0 6] { + "IBM EGA" - "IBM VGA" { + lassign $fname _ibm _ code + set cp "" + if {$code eq ""} { + set cp "cp437" + } else { + if {[dict exists $encodings $code]} { + set cp [dict get $encodings $code] + } + } + if {$cp ne ""} { + dict set sdict codepage $cp + } + } + } + } + return $sdict + } + +} + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::ansi::sauce::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + + + #get_string caters for possible null-terminated strings as these may be seen in the wild even though sauce doesn't specify they should be null-terminated + if {[catch {binary scan x C v}]} { + #fallback for tcl 8.6 + proc get_string {bytes} { + set cstr [lindex [split $bytes \0] 0] + binary scan $cstr a* str + return $str + } + } else { + proc get_string {bytes} { + binary scan $bytes C* str + return $str + } + } + +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +#tcl::namespace::eval punk::ansi::sauce::system { +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::ansi::sauce { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::ansi::sauce" + @package -name "punk::ansi::sauce" -help\ + "Basic support for SAUCE format + Standard Architecture for Universal Comment Extensions + https://www.acid.org/info/sauce/sauce.htm " + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::ansi::sauce + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::ansi::sauce + ANSI SAUCE block processor + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::ansi::sauce::version" + } + proc get_topic_Contributors {} { + set authors {{"Julian Noble" }} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::ansi::sauce::about" + dict set overrides @cmd -name "punk::ansi::sauce::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::ansi::sauce + }] \n] + dict set overrides topic -choices [list {*}[punk::ansi::sauce::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::ansi::sauce::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::ansi::sauce::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::ansi::sauce::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::ansi::sauce +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::ansi::sauce [tcl::namespace::eval punk::ansi::sauce { + variable pkg punk::ansi::sauce + variable version + set version 0.1.0 +}] +return + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index 558f6bde..24f98b6b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -6345,7 +6345,7 @@ tcl::namespace::eval punk::args { } indexexpression { #tcl 9.1+? tip 615 'string is index' - if {$echeck eq "" || [catch {lindex {} $e_check}]} { + if {$e_check eq "" || [catch {lindex {} $e_check}]} { set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm index d7eaf639..ce35138e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -444,6 +444,8 @@ tcl::namespace::eval ::punk::libunknown { proc zipfs_tclPkgUnknown {name args} { #puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" + global dir + variable epoch set pkg_epoch [dict get $epoch pkg current] @@ -609,7 +611,7 @@ tcl::namespace::eval ::punk::libunknown { incr sourced ;#count as sourced even if source fails; keep before actual source action #::tcl::Pkg::source $file #lappend sourced_files $file - tcl_Pkg_source $file + namespace eval :: [list ::punk::libunknown::tcl_Pkg_source $file] } trap {POSIX EACCES} {} { # $file was not readable; silently ignore puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (1)" @@ -640,7 +642,7 @@ tcl::namespace::eval ::punk::libunknown { incr sourced #lappend sourced_files $file #::tcl::Pkg::source $file - tcl_Pkg_source $file + namespace eval :: [list punk::libunknown::tcl_Pkg_source $file] } trap {POSIX EACCES} {} { # $file was not readable; silently ignore puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (2)" @@ -1367,7 +1369,7 @@ tcl::namespace::eval ::punk::libunknown { } } if {[llength $ok_forgets]} { - return [::package:: forget {*}$ok_forgets] + return [uplevel 1 [list ::package:: forget {*}$ok_forgets]] } else { return } @@ -1449,7 +1451,7 @@ tcl::namespace::eval ::punk::libunknown { } } default { - return [::package:: {*}$args] + return [uplevel 1 [list ::package:: {*}$args]] } } } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm new file mode 100644 index 00000000..16cb13a1 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/ns-0.1.0.tm @@ -0,0 +1,302 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2025 +# +# @@ Meta Begin +# Application punk::nav::ns 0.1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + + + +tcl::namespace::eval punk::nav::ns { + variable PUNKARGS + variable ns_current + #allow presetting + if {![info exists ::punk::nav::ns::ns_current]} { + set ns_current :: + } + namespace path {::punk::ns} + + proc ns/ {v {ns_or_glob ""} args} { + variable ns_current ;#change active ns of repl by setting ns_current + + set ns_caller [uplevel 1 {::tcl::namespace::current}] + #puts stderr "ns_cur:$ns_current ns_call:$ns_caller" + + + set types [list all] + set nspathcommands 0 + if {$v eq "/"} { + set types [list children] + } + if {$v eq "///"} { + set nspathcommands 1 + } + + set ns_or_glob [string map {:::: ::} $ns_or_glob] + + #todo - cooperate with repl? + set out "" + if {$ns_or_glob eq ""} { + set is_absolute 1 + set ns_queried $ns_current + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] + } else { + set is_absolute [string match ::* $ns_or_glob] + set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? + if {$is_absolute} { + if {!$has_globchars} { + if {![nsexists $ns_or_glob]} { + error "cannot change to namespace $ns_or_glob" + } + set ns_current $ns_or_glob + set ns_queried $ns_current + tailcall ns/ $v "" + } else { + set ns_queried $ns_or_glob + set out [nslist -types $types -nspathcommands $nspathcommands $ns_or_glob] + } + } else { + if {!$has_globchars} { + set nsnext [nsjoin $ns_current $ns_or_glob] + if {![nsexists $nsnext]} { + error "cannot change to namespace $ns_or_glob" + } + set ns_current $nsnext + set ns_queried $nsnext + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] + } else { + set ns_queried [nsjoin $ns_current $ns_or_glob] + set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] + } + } + } + set ns_display "\n$ns_queried" + if {$ns_current eq $ns_queried} { + if {$ns_current in [info commands $ns_current] } { + if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { + if {[llength $ensemble_info] > 0} { + #this namespace happens to match ensemble command. + #todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. + set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" + } + } + } + } + append out $ns_display + return $out + } + + #create possibly nested namespace structure - but only if not already existant + proc n/new {args} { + variable ns_current + if {![llength $args]} { + error "usage: :/new \[ ...\]" + } + set a1 [lindex $args 0] + set is_absolute [string match ::* $a1] + if {$is_absolute} { + set nspath [nsjoinall {*}$args] + } else { + if {[string match :* $a1]} { + puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" + } + set nspath [nsjoinall $ns_current {*}$args] + } + + set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] + + if {$ns_exists} { + error "Namespace $nspath already exists" + } + #tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] + nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] + n/ $nspath + } + + #nn/ ::/ nsup/ - back up one namespace level + proc nsup/ {v args} { + variable ns_current + if {$ns_current eq "::"} { + puts stderr "Already at global namespace '::'" + } else { + set out "" + set nsq [nsprefix $ns_current] + if {$v eq "/"} { + set out [get_nslist -match [nsjoin $nsq *] -types [list children]] + } else { + set out [get_nslist -match [nsjoin $nsq *] -types [list all]] + } + #set out [nslist [nsjoin $nsq *]] + set ns_current $nsq + append out "\n$ns_current" + return $out + } + } + + + +} + + + +#extra slash implies more verbosity (ie display commands instead of just nschildren) +interp alias {} n/ {} punk::nav::ns::ns/ / +interp alias {} n// {} punk::nav::ns::ns/ // +interp alias {} n/// {} punk::nav::ns::ns/ /// +interp alias {} n/new {} punk::nav::ns::n/new +interp alias {} nn/ {} punk::nav::ns::nsup/ / +interp alias {} nn// {} punk::nav::ns::nsup/ // +if 0 { +#we can't have ::/ without just plain / which is confusing. +interp alias {} :/ {} punk::nav::ns::ns/ / +interp alias {} :// {} punk::nav::ns::ns/ // +interp alias {} :/new {} punk::nav::ns::n/new +interp alias {} ::/ {} punk::nav::ns::nsup/ / +interp alias {} ::// {} punk::nav::ns::nsup/ // +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::nav::ns::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +#tcl::namespace::eval punk::nav::ns::system { +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::nav::ns { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)punk::nav::ns" + @package -name "punk::nav::ns" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::nav::ns + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::nav::ns + description to come.. + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::punk::nav::ns::version" + } + proc get_topic_Contributors {} { + set authors {} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_custom-topic {} { + punk::args::lib::tstr -return string { + A custom + topic + etc + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::nav::ns::about" + dict set overrides @cmd -name "punk::nav::ns::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::nav::ns + }] \n] + dict set overrides topic -choices [list {*}[punk::nav::ns::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::nav::ns::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::nav::ns::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::nav::ns::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::nav::ns +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::nav::ns [tcl::namespace::eval punk::nav::ns { + variable pkg punk::nav::ns + variable version + set version 0.1.0 +}] +return + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index 5b504e58..330018ae 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -63,39 +63,6 @@ package require commandstack #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::packagepreference::class { - #*** !doctools - #[subsection {Namespace punk::packagepreference::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::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 # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -188,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } if {!$is_exact && [llength $vwant] <= 1 } { @@ -238,7 +205,7 @@ tcl::namespace::eval punk::packagepreference { } #return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] try { - set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] + set result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg $lversion-$lversion]] } trap {} {emsg eopts} { #REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry #under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown @@ -282,9 +249,9 @@ tcl::namespace::eval punk::packagepreference { if {[regexp {[A-Z]} $pkg]} { #legacy package names #only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation - if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} { + if {[catch {uplevel 1 [list $COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant]} v]} { try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -294,7 +261,7 @@ tcl::namespace::eval punk::packagepreference { } else { #return [$COMMANDSTACKNEXT require $pkg {*}$vwant] try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -328,14 +295,14 @@ tcl::namespace::eval punk::packagepreference { catch { #$COMMANDSTACKNEXT require $pkg {*}$vwant #j2 - $COMMANDSTACKNEXT require punk::args::moduledoc::$dp + uplevel 1 [list $COMMANDSTACKNEXT require punk::args::moduledoc::$dp] } } #--------------------------------------------------------------- return $require_result } default { - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index 9ae26516..5dc72254 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -738,7 +738,7 @@ proc ::punkboot::check_package_availability {args} { lappend ::test::pkg_missing $pkgrequest } } else { - if {$pkgrequest ni $::test_pkg_broken} { + if {$pkgrequest ni $::test::pkg_broken} { lappend ::test::pkg_broken $pkgrequest } @@ -1481,12 +1481,12 @@ if {$::punkboot::command eq "check"} { } } flush stdout - set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] + set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { lassign $pkg_request pkgname vrequest package require $pkgname {*}$vrequest ;#todo? } - flush stderr + flush stderr #punk::lib::showdict -channel stderr $::punkboot::pkg_availability set missing_out [::punkboot::get_display_missing_packages $::punkboot::pkg_availability] puts stdout $missing_out\n @@ -1566,7 +1566,9 @@ if {$::punkboot::command eq "check"} { set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { lassign $pkg_request pkgname vrequest - catch {package require $pkgname {*}$vrequest} ;#todo + if {[catch {package require $pkgname {*}$vrequest} errM]} { + puts stderr "failed to load $pkgname\n - $errM\n - $::errorInfo" + } } flush stderr #punk::lib::showdict -channel stderr $::punkboot::pkg_availability diff --git a/src/vfs/_vfscommon.vfs/lib/vfszip/pkgIndex.tcl b/src/vfs/_vfscommon.vfs/lib/vfszip/pkgIndex.tcl new file mode 100644 index 00000000..60421d79 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/lib/vfszip/pkgIndex.tcl @@ -0,0 +1,53 @@ +# -*- tcl -*- +# Tcl package index file, version 1.1 +# This file was generated by hand. +# +# This will be autogenerated by configure to use the correct name +# for the vfs dynamic library. + +#package ifneeded vfs 1.5.0 [list source [file join $dir vfs.tcl]] +# +#package ifneeded starkit 1.3.3 [list source [file join $dir starkit.tcl]] +# +## New, for the old, keep version numbers synchronized. +#package ifneeded vfs::mk4 1.10.1 [list source [file join $dir mk4vfs.tcl]] + + +#2025 - provide a fix for 'bad central header' error in zip::open when platform has older vfs library +package ifneeded vfs::zip 1.0.4 [list source [file join $dir zipvfs.tcl]] + +# New +#package ifneeded vfs::ftp 1.0 [list source [file join $dir ftpvfs.tcl]] +#package ifneeded vfs::http 0.6 [list source [file join $dir httpvfs.tcl]] +#package ifneeded vfs::ns 0.5.1 [list source [file join $dir tclprocvfs.tcl]] +#package ifneeded vfs::tar 0.91 [list source [file join $dir tarvfs.tcl]] +#package ifneeded vfs::test 1.0 [list source [file join $dir testvfs.tcl]] +#package ifneeded vfs::urltype 1.0 [list source [file join $dir vfsUrl.tcl]] +#package ifneeded vfs::webdav 0.1 [list source [file join $dir webdavvfs.tcl]] +#package ifneeded vfs::tk 0.5 [list source [file join $dir tkvfs.tcl]] +## +## Virtual filesystems based on the template vfs: +## +#if {[lsearch -exact $::auto_path [file join $dir template]] < 0} { +# lappend ::auto_path [file join $dir template] +#} +#package ifneeded vfs::template::chroot 1.5.2 \ +# [list source [file join $dir template chrootvfs.tcl]] +#package ifneeded vfs::template::collate 1.5.3 \ +# [list source [file join $dir template collatevfs.tcl]] +#package ifneeded vfs::template::version 1.5.2 \ +# [list source [file join $dir template versionvfs.tcl]] +#package ifneeded vfs::template::version::delta 1.5.2 \ +# [list source [file join $dir template deltavfs.tcl]] +#package ifneeded vfs::template::fish 1.5.2 \ +# [list source [file join $dir template fishvfs.tcl]] +#package ifneeded vfs::template::quota 1.5.2 \ +# [list source [file join $dir template quotavfs.tcl]] +#package ifneeded vfs::template 1.5.5 \ +# [list source [file join $dir template templatevfs.tcl]] +## +## Helpers +## +#package ifneeded fileutil::globfind 1.5 \ +# [list source [file join $dir template globfind.tcl]] +#package ifneeded trsync 1.0 [list source [file join $dir template tdelta.tcl]] diff --git a/src/vfs/_vfscommon.vfs/lib/vfszip/zipvfs.tcl b/src/vfs/_vfscommon.vfs/lib/vfszip/zipvfs.tcl new file mode 100644 index 00000000..0a0ef767 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/lib/vfszip/zipvfs.tcl @@ -0,0 +1,937 @@ +# Removed provision of the backward compatible name. Moved to separate +# file/package. +package provide vfs::zip 1.0.4 + +package require vfs + +# Using the vfs, memchan and Trf extensions, we ought to be able +# to write a Tcl-only zip virtual filesystem. What we have below +# is basically that. + +namespace eval vfs::zip {} + +# Used to execute a zip archive. This is rather like a jar file +# but simpler. We simply mount it and then source a toplevel +# file called 'main.tcl'. +proc vfs::zip::Execute {zipfile} { + Mount $zipfile $zipfile + source [file join $zipfile main.tcl] +} + +proc vfs::zip::Mount {zipfile local} { + set fd [::zip::open [::file normalize $zipfile]] + vfs::filesystem mount $local [list ::vfs::zip::handler $fd] + # Register command to unmount + vfs::RegisterMount $local [list ::vfs::zip::Unmount $fd] + return $fd +} + +proc vfs::zip::Unmount {fd local} { + vfs::filesystem unmount $local + ::zip::_close $fd +} + +proc vfs::zip::handler {zipfd cmd root relative actualpath args} { + #::vfs::log [list $zipfd $cmd $root $relative $actualpath $args] + if {$cmd == "matchindirectory"} { + eval [list $cmd $zipfd $relative $actualpath] $args + } else { + eval [list $cmd $zipfd $relative] $args + } +} + +proc vfs::zip::attributes {zipfd} { return [list "state"] } +proc vfs::zip::state {zipfd args} { + vfs::attributeCantConfigure "state" "readonly" $args +} + +# If we implement the commands below, we will have a perfect +# virtual file system for zip files. + +proc vfs::zip::matchindirectory {zipfd path actualpath pattern type} { + #::vfs::log [list matchindirectory $path $actualpath $pattern $type] + + # This call to zip::getdir handles empty patterns properly as asking + # for the existence of a single file $path only + set res [::zip::getdir $zipfd $path $pattern] + #::vfs::log "got $res" + if {![string length $pattern]} { + if {![::zip::exists $zipfd $path]} { return {} } + set res [list $actualpath] + set actualpath "" + } + + set newres [list] + foreach p [::vfs::matchCorrectTypes $type $res $actualpath] { + lappend newres [file join $actualpath $p] + } + #::vfs::log "got $newres" + return $newres +} + +proc vfs::zip::stat {zipfd name} { + #::vfs::log "stat $name" + ::zip::stat $zipfd $name sb + #::vfs::log [array get sb] + # remove socket mode file type (0xc000) to prevent Tcl from reporting Fossil archives as socket types + if {($sb(mode) & 0xf000) == 0xc000} { + set sb(mode) [expr {$sb(mode) ^ 0xc000}] + } + # remove block device bit file type (0x6000) + if {($sb(mode) & 0xf000) == 0x6000} { + set sb(mode) [expr {$sb(mode) ^ 0x6000}] + } + # remove FIFO mode file type (0x1000) + if {($sb(mode) & 0xf000) == 0x1000} { + set sb(mode) [expr {$sb(mode) ^ 0x1000}] + } + # remove character device mode file type (0x2000) + if {($sb(mode) & 0xf000) == 0x2000} { + set sb(mode) [expr {$sb(mode) ^ 0x2000}] + } + # workaround for certain errorneus zip archives + if {($sb(mode) & 0xffff) == 0xffff} { + # change to directory type and set mode to 0777 + directory flag + set sb(mode) 0x41ff + } + array get sb +} + +proc vfs::zip::access {zipfd name mode} { + #::vfs::log "zip-access $name $mode" + if {$mode & 2} { + vfs::filesystem posixerror $::vfs::posix(EROFS) + } + # Readable, Exists and Executable are treated as 'exists' + # Could we get more information from the archive? + if {[::zip::exists $zipfd $name]} { + return 1 + } else { + error "No such file" + } + +} + +proc vfs::zip::open {zipfd name mode permissions} { + #::vfs::log "open $name $mode $permissions" + # return a list of two elements: + # 1. first element is the Tcl channel name which has been opened + # 2. second element (optional) is a command to evaluate when + # the channel is closed. + + switch -- $mode { + "" - + "r" { + if {![::zip::exists $zipfd $name]} { + vfs::filesystem posixerror $::vfs::posix(ENOENT) + } + + ::zip::stat $zipfd $name sb + + if {$sb(ino) < 0} { + vfs::filesystem posixerror $::vfs::posix(EISDIR) + } + +# set nfd [vfs::memchan] +# fconfigure $nfd -translation binary + + seek $zipfd $sb(ino) start +# set data [zip::Data $zipfd sb 0] + +# puts -nonewline $nfd $data + +# fconfigure $nfd -translation auto +# seek $nfd 0 +# return [list $nfd] + # use streaming for files larger than 1MB + if {$::zip::useStreaming && $sb(size) >= 1048576} { + seek $zipfd [zip::ParseDataHeader $zipfd sb] start + if { $sb(method) != 0} { + set nfd [::zip::zstream $zipfd $sb(csize) $sb(size)] + } else { + set nfd [::zip::rawstream $zipfd $sb(size)] + } + return [list $nfd] + } else { + set nfd [vfs::memchan] + fconfigure $nfd -translation binary + + set data [zip::Data $zipfd sb 0] + + puts -nonewline $nfd $data + + fconfigure $nfd -translation auto + seek $nfd 0 + return [list $nfd] + } + } + default { + vfs::filesystem posixerror $::vfs::posix(EROFS) + } + } +} + +proc vfs::zip::createdirectory {zipfd name} { + #::vfs::log "createdirectory $name" + vfs::filesystem posixerror $::vfs::posix(EROFS) +} + +proc vfs::zip::removedirectory {zipfd name recursive} { + #::vfs::log "removedirectory $name" + vfs::filesystem posixerror $::vfs::posix(EROFS) +} + +proc vfs::zip::deletefile {zipfd name} { + #::vfs::log "deletefile $name" + vfs::filesystem posixerror $::vfs::posix(EROFS) +} + +proc vfs::zip::fileattributes {zipfd name args} { + #::vfs::log "fileattributes $args" + switch -- [llength $args] { + 0 { + # list strings + return [list] + } + 1 { + # get value + set index [lindex $args 0] + return "" + } + 2 { + # set value + set index [lindex $args 0] + set val [lindex $args 1] + vfs::filesystem posixerror $::vfs::posix(EROFS) + } + } +} + +proc vfs::zip::utime {fd path actime mtime} { + vfs::filesystem posixerror $::vfs::posix(EROFS) +} + +# Below copied from TclKit distribution + +# +# ZIP decoder: +# +# See the ZIP file format specification: +# http://www.pkware.com/documents/casestudies/APPNOTE.TXT +# +# Format of zip file: +# [ Data ]* [ TOC ]* EndOfArchive +# +# Note: TOC is refered to in ZIP doc as "Central Archive" +# +# This means there are two ways of accessing: +# +# 1) from the begining as a stream - until the header +# is not "PK\03\04" - ideal for unzipping. +# +# 2) for table of contents without reading entire +# archive by first fetching EndOfArchive, then +# just loading the TOC +# + +namespace eval zip { + set zseq 0 + + array set methods { + 0 {stored - The file is stored (no compression)} + 1 {shrunk - The file is Shrunk} + 2 {reduce1 - The file is Reduced with compression factor 1} + 3 {reduce2 - The file is Reduced with compression factor 2} + 4 {reduce3 - The file is Reduced with compression factor 3} + 5 {reduce4 - The file is Reduced with compression factor 4} + 6 {implode - The file is Imploded} + 7 {reserved - Reserved for Tokenizing compression algorithm} + 8 {deflate - The file is Deflated} + 9 {reserved - Reserved for enhanced Deflating} + 10 {pkimplode - PKWARE Date Compression Library Imploding} + 11 {reserved - Reserved by PKWARE} + 12 {bzip2 - The file is compressed using BZIP2 algorithm} + 13 {reserved - Reserved by PKWARE} + 14 {lzma - LZMA (EFS)} + 15 {reserved - Reserved by PKWARE} + } + # Version types (high-order byte) + array set systems { + 0 {dos} + 1 {amiga} + 2 {vms} + 3 {unix} + 4 {vm cms} + 5 {atari} + 6 {os/2} + 7 {macos} + 8 {z system 8} + 9 {cp/m} + 10 {tops20} + 11 {windows} + 12 {qdos} + 13 {riscos} + 14 {vfat} + 15 {mvs} + 16 {beos} + 17 {tandem} + 18 {theos} + } + # DOS File Attrs + array set dosattrs { + 1 {readonly} + 2 {hidden} + 4 {system} + 8 {unknown8} + 16 {directory} + 32 {archive} + 64 {unknown64} + 128 {normal} + } + + proc u_short {n} { return [expr { ($n+0x10000)%0x10000 }] } +} + +proc zip::DosTime {date time} { + set time [u_short $time] + set date [u_short $date] + + # time = fedcba9876543210 + # HHHHHmmmmmmSSSSS (sec/2 actually) + + # data = fedcba9876543210 + # yyyyyyyMMMMddddd + + set sec [expr { ($time & 0x1F) * 2 }] + set min [expr { ($time >> 5) & 0x3F }] + set hour [expr { ($time >> 11) & 0x1F }] + + set mday [expr { $date & 0x1F }] + set mon [expr { (($date >> 5) & 0xF) }] + set year [expr { (($date >> 9) & 0xFF) + 1980 }] + + # Fix up bad date/time data, no need to fail + if {$sec > 59} {set sec 59} + if {$min > 59} {set min 59} + if {$hour > 23} {set hour 23} + if {$mday < 1} {set mday 1} + if {$mday > 31} {set mday 31} + if {$mon < 1} {set mon 1} + if {$mon > 12} {set mon 12} + + set res 0 + catch { + set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \ + $year $mon $mday $hour $min $sec] + set res [clock scan $dt -gmt 1] + } + + return $res +} + +proc zip::ParseDataHeader {fd arr {dataVar ""}} { + upvar 1 $arr sb + + upvar 1 $arr sb + + # APPNOTE A: Local file header + set buf [read $fd 30] + set n [binary scan $buf A4sssssiiiss \ + hdr sb(ver) sb(flags) sb(method) time date \ + crc csize size namelen xtralen] + + if { ![string equal "PK\03\04" $hdr] } { + binary scan $hdr H* x + return -code error "bad header: $x" + } + set sb(ver) [expr {$sb(ver) & 0xffff}] + set sb(flags) [expr {$sb(flags) & 0xffff}] + set sb(method) [expr {$sb(method) & 0xffff}] + set sb(mtime) [DosTime $date $time] + if {!($sb(flags) & (1<<3))} { + set sb(crc) [expr {$crc & 0xffffffff}] + set sb(csize) [expr {$csize & 0xffffffff}] + set sb(size) [expr {$size & 0xffffffff}] + } + + set sb(name) [read $fd [expr {$namelen & 0xffff}]] + set sb(extra) [read $fd [expr {$xtralen & 0xffff}]] + if {$sb(flags) & (1 << 11)} { + set sb(name) [encoding convertfrom utf-8 $sb(name)] + } + set sb(name) [string trimleft $sb(name) "./"] + + # APPNOTE B: File data + # if bit 3 of flags is set the csize comes from the central directory + set offset [tell $fd] + if {$dataVar != ""} { + upvar 1 $dataVar data + set data [read $fd $sb(csize)] + } else { + seek $fd $sb(csize) current + } + + # APPNOTE C: Data descriptor + if { $sb(flags) & (1<<3) } { + binary scan [read $fd 4] i ddhdr + if {($ddhdr & 0xffffffff) == 0x08074b50} { + binary scan [read $fd 12] iii sb(crc) sb(csize) sb(size) + } else { + set sb(crc) $ddhdr + binary scan [read $fd 8] ii sb(csize) sb(size) + } + set sb(crc) [expr {$sb(crc) & 0xffffffff}] + set sb(csize) [expr {$sb(csize) & 0xffffffff}] + set sb(size) [expr {$sb(size) & 0xffffffff}] + } + return $offset +} + +proc zip::Data {fd arr verify} { + upvar 1 $arr sb + ParseDataHeader $fd $arr data + switch -exact -- $sb(method) { + 0 { + # stored; no compression + } + 8 { + # deflated + if {[catch { + set data [vfs::zip -mode decompress -nowrap 1 $data] + } err]} then { + return -code error "error inflating \"$sb(name)\": $err" + } + } + default { + set method $sb(method) + if {[info exists methods($method)]} { + set method $methods($method) + } + return -code error "unsupported compression method + \"$method\" used for \"$sb(name)\"" + } + } + + if { $verify && $sb(method) != 0} { + set ncrc [vfs::crc $data] + if { ($ncrc & 0xffffffff) != $sb(crc) } { + vfs::log [format {%s: crc mismatch: expected 0x%x, got 0x%x} \ + $sb(name) $sb(crc) $ncrc] + } + } + return $data +} + +proc zip::EndOfArchive {fd arr} { + upvar 1 $arr cb + + # [SF Tclvfs Bug 1003574]. Do not seek over beginning of file. + seek $fd 0 end + + # Just looking in the last 512 bytes may be enough to handle zip + # archives without comments, however for archives which have + # comments the chunk may start at an arbitrary distance from the + # end of the file. So if we do not find the header immediately + # we have to extend the range of our search, possibly until we + # have a large part of the archive in memory. We can fail only + # after the whole file has been searched. + + set sz [tell $fd] + if {[info exists ::zip::max_header_seek]} { + if {$::zip::max_header_seek < $sz} { + set sz $::zip::max_header_seek + } + } + set len 512 + set at 512 + while {1} { + if {$sz < $at} {set n -$sz} else {set n -$at} + + seek $fd $n end + set hdr [read $fd $len] + + # We are using 'string last' as we are searching the first + # from the end, which is the last from the beginning. See [SF + # Bug 2256740]. A zip archive stored in a zip archive can + # confuse the unmodified code, triggering on the magic + # sequence for the inner, uncompressed archive. + set pos [string last "PK\05\06" $hdr] + if {$pos < 0} { + if {$at >= $sz} { + return -code error "no header found" + } + set len 540 ; # after 1st iteration we force overlap with last buffer + incr at 512 ; # to ensure that the pattern we look for is not split at + # ; # a buffer boundary, nor the header itself + } else { + break + } + } + + set hdrlen [string length $hdr] + set hdr [string range $hdr [expr $pos + 4] [expr $pos + 21]] + + set pos [expr {wide([tell $fd]) + $pos - $hdrlen}] + + if {$pos < 0} { + set pos 0 + } + + binary scan $hdr ssssiis \ + cb(ndisk) cb(cdisk) \ + cb(nitems) cb(ntotal) \ + cb(csize) cb(coff) \ + cb(comment) + + set cb(ndisk) [u_short $cb(ndisk)] + set cb(nitems) [u_short $cb(nitems)] + set cb(ntotal) [u_short $cb(ntotal)] + set cb(comment) [u_short $cb(comment)] + + # Compute base for situations where ZIP file + # has been appended to another media (e.g. EXE) + set base [expr { $pos - $cb(csize) - $cb(coff) }] + if {$base < 0} { + set base 0 + } + set cb(base) $base + + if {$cb(coff) < 0} { + set cb(base) [expr {wide($cb(base)) - 4294967296}] + set cb(coff) [expr {wide($cb(coff)) + 4294967296}] + } +} + +proc zip::TOC {fd arr} { + upvar #0 zip::$fd cb + upvar #0 zip::$fd.dir cbdir + upvar 1 $arr sb + + set buf [read $fd 46] + + binary scan $buf A4ssssssiiisssssii hdr \ + sb(vem) sb(ver) sb(flags) sb(method) time date \ + sb(crc) sb(csize) sb(size) \ + flen elen clen sb(disk) sb(attr) \ + sb(atx) sb(ino) + + set sb(ino) [expr {$cb(base) + $sb(ino)}] + + if { ![string equal "PK\01\02" $hdr] } { + binary scan $hdr H* x + return -code error "bad central header: $x" + } + + foreach v {vem ver flags method disk attr} { + set sb($v) [expr {$sb($v) & 0xffff}] + } + set sb(crc) [expr {$sb(crc) & 0xffffffff}] + set sb(csize) [expr {$sb(csize) & 0xffffffff}] + set sb(size) [expr {$sb(size) & 0xffffffff}] + set sb(mtime) [DosTime $date $time] + set sb(mode) [expr { ($sb(atx) >> 16) & 0xffff }] + # check atx field or mode field if this is a directory + if { ((( $sb(atx) & 0xff ) & 16) != 0) || (($sb(mode) & 0x4000) != 0) } { + set sb(type) directory + } else { + set sb(type) file + } + set sb(name) [read $fd [u_short $flen]] + set sb(extra) [read $fd [u_short $elen]] + set sb(comment) [read $fd [u_short $clen]] + while {$sb(ino) < 0} { + set sb(ino) [expr {wide($sb(ino)) + 4294967296}] + } + if {$sb(flags) & (1 << 11)} { + set sb(name) [encoding convertfrom utf-8 $sb(name)] + set sb(comment) [encoding convertfrom utf-8 $sb(comment)] + } + set sb(name) [string trimleft $sb(name) "./"] + set parent [file dirname $sb(name)] + if {$parent == "."} {set parent ""} + lappend cbdir([string tolower $parent]) [file tail [string trimright $sb(name) /]] +} + +proc zip::open {path} { + #vfs::log [list open $path] + set fd [::open $path] + + if {[catch { + upvar #0 zip::$fd cb + upvar #0 zip::$fd.toc toc + upvar #0 zip::$fd.dir cbdir + + fconfigure $fd -translation binary ;#-buffering none + + zip::EndOfArchive $fd cb + + seek $fd [expr {$cb(base) + $cb(coff)}] start + + set toc(_) 0; unset toc(_); #MakeArray + + for {set i 0} {$i < $cb(nitems)} {incr i} { + zip::TOC $fd sb + + set origname [string trimright $sb(name) /] + set sb(depth) [llength [file split $sb(name)]] + + set name [string tolower $origname] + set sba [array get sb] + set toc($name) $sba + FAKEDIR toc cbdir [file dirname $origname] + } + foreach {n v} [array get cbdir] { + set cbdir($n) [lsort -unique $v] + } + } err]} { + close $fd + return -code error $err + } + + return $fd +} + +proc zip::FAKEDIR {tocarr cbdirarr origpath} { + upvar 1 $tocarr toc $cbdirarr cbdir + + set path [string tolower $origpath] + if { $path == "."} { return } + + if { ![info exists toc($path)] } { + # Implicit directory + lappend toc($path) \ + name $origpath \ + type directory mtime 0 size 0 mode 0777 \ + ino -1 depth [llength [file split $path]] + + set parent [file dirname $path] + if {$parent == "."} {set parent ""} + lappend cbdir($parent) [file tail $origpath] + } + FAKEDIR toc cbdir [file dirname $origpath] +} + +proc zip::exists {fd path} { + #::vfs::log "$fd $path" + if {$path == ""} { + return 1 + } else { + upvar #0 zip::$fd.toc toc + info exists toc([string tolower $path]) + } +} + +proc zip::stat {fd path arr} { + upvar #0 zip::$fd.toc toc + upvar 1 $arr sb + #vfs::log [list stat $fd $path $arr [info level -1]] + + set name [string tolower $path] + if { $name == "" || $name == "." } { + array set sb { + type directory mtime 0 size 0 mode 0777 + ino -1 depth 0 name "" + } + } elseif {![info exists toc($name)] } { + return -code error "could not read \"$path\": no such file or directory" + } else { + array set sb $toc($name) + } + set sb(dev) -1 + set sb(uid) -1 + set sb(gid) -1 + set sb(nlink) 1 + set sb(atime) $sb(mtime) + set sb(ctime) $sb(mtime) + return "" +} + +# Treats empty pattern as asking for a particular file only +proc zip::getdir {fd path {pat *}} { + #::vfs::log [list getdir $fd $path $pat] + upvar #0 zip::$fd.toc toc + upvar #0 zip::$fd.dir cbdir + + if { $path == "." || $path == "" } { + set path "" + } else { + set path [string tolower $path] + } + + if {$pat == ""} { + if {[info exists cbdir($path)]} { + return [list $path] + } else { + return [list] + } + } + + set rc [list] + if {[info exists cbdir($path)]} { + if {$pat == "*"} { + set rc $cbdir($path) + } else { + foreach f $cbdir($path) { + if {[string match -nocase $pat $f]} { + lappend rc $f + } + } + } + } + return $rc +} + +proc zip::_close {fd} { + variable $fd + variable $fd.toc + variable $fd.dir + unset $fd + unset $fd.toc + unset $fd.dir + ::close $fd +} + +# Implementation of stream based decompression for zip +if {([info commands ::rechan] != "") || ([info commands ::chan] != "")} { + if {![catch {package require Tcl 8.6}]} { + # implementation using [zlib stream inflate] and [rechan]/[chan create] + proc ::zip::zstream_create {fd} { + upvar #0 ::zip::_zstream_zcmd($fd) zcmd + if {$zcmd == ""} { + set zcmd [zlib stream inflate] + } + } + proc ::zip::zstream_delete {fd} { + upvar #0 ::zip::_zstream_zcmd($fd) zcmd + if {$zcmd != ""} { + rename $zcmd "" + set zcmd "" + } + } + + proc ::zip::zstream_put {fd data} { + upvar #0 ::zip::_zstream_zcmd($fd) zcmd + zstream_create $fd + $zcmd put $data + } + + proc ::zip::zstream_get {fd} { + upvar #0 ::zip::_zstream_zcmd($fd) zcmd + zstream_create $fd + return [$zcmd get] + } + + set ::zip::useStreaming 1 + } elseif {![catch {zlib sinflate ::zip::__dummycommand ; rename ::zip::__dummycommand ""}]} { + proc ::zip::zstream_create {fd} { + upvar #0 ::zip::_zstream_zcmd($fd) zcmd + if {$zcmd == ""} { + set zcmd ::zip::_zstream_cmd_$fd + zlib sinflate $zcmd + } + } + proc ::zip::zstream_delete {fd} { + upvar #0 ::zip::_zstream_zcmd($fd) zcmd + if {$zcmd != ""} { + rename $zcmd "" + set zcmd "" + } + } + + proc ::zip::zstream_put {fd data} { + upvar #0 ::zip::_zstream_zcmd($fd) zcmd + zstream_create $fd + $zcmd fill $data + } + + proc ::zip::zstream_get {fd} { + upvar #0 ::zip::_zstream_zcmd($fd) zcmd + zstream_create $fd + set rc "" + while {[$zcmd fill] != 0} { + if {[catch { + append rc [$zcmd drain 4096] + }]} { + break + } + } + return $rc + } + + set ::zip::useStreaming 1 + } else { + set ::zip::useStreaming 0 + } +} else { + set ::zip::useStreaming 0 +} + +proc ::zip::eventClean {fd} { + variable eventEnable + eventSet $fd 0 +} + +proc ::zip::eventWatch {fd a} { + if {[lindex $a 0] == "read"} { + eventSet $fd 1 + } else { + eventSet $fd 0 + } +} + +proc zip::eventSet {fd e} { + variable eventEnable + set cmd [list ::zip:::eventPost $fd] + after cancel $cmd + if {$e} { + set eventEnable($fd) 1 + after 0 $cmd + } else { + catch {unset eventEnable($fd)} + } +} + +proc zip::eventPost {fd} { + variable eventEnable + if {[info exists eventEnable($fd)] && $eventEnable($fd)} { + chan postevent $fd read + eventSet $fd 1 + } +} + +proc ::zip::zstream {ifd clen ilen} { + set start [tell $ifd] + set cmd [list ::zip::zstream_handler $start $ifd $clen $ilen] + if {[catch { + set fd [chan create read $cmd] + }]} { + set fd [rechan $cmd 2] + } + set ::zip::_zstream_buf($fd) "" + set ::zip::_zstream_pos($fd) 0 + set ::zip::_zstream_tell($fd) $start + set ::zip::_zstream_zcmd($fd) "" + return $fd +} + +proc ::zip::zstream_handler {istart ifd clen ilen cmd fd {a1 ""} {a2 ""}} { + upvar #0 ::zip::_zstream_pos($fd) pos + upvar #0 ::zip::_zstream_buf($fd) buf + upvar #0 ::zip::_zstream_tell($fd) tell + upvar #0 ::zip::_zstream_zcmd($fd) zcmd + switch -- $cmd { + initialize { + return [list initialize finalize watch read seek] + } + watch { + eventWatch $fd $a1 + } + seek { + switch $a2 { + 1 - current { incr a1 $pos } + 2 - end { incr a1 $ilen } + } + # to seek back, rewind, i.e. start from scratch + if {$a1 < $pos} { + zstream_delete $fd + seek $ifd $istart + set pos 0 + set buf "" + set tell $istart + } + + while {$pos < $a1} { + set n [expr {$a1 - $pos}] + if {$n > 4096} { set n 4096 } + zstream_handler $istart $ifd $clen $ilen read $fd $n + } + return $pos + } + + read { + set r "" + set n $a1 + if {$n + $pos > $ilen} { set n [expr {$ilen - $pos}] } + + while {$n > 0} { + set chunk [string range $buf 0 [expr {$n - 1}]] + set buf [string range $buf $n end] + incr n -[string length $chunk] + incr pos [string length $chunk] + append r $chunk + + if {$n > 0} { + set c [expr {$istart + $clen - [tell $ifd]}] + if {$c > 4096} { set c 4096 } + if {$c <= 0} { + break + } + seek $ifd $tell start + set data [read $ifd $c] + set tell [tell $ifd] + zstream_put $fd $data + while {[string length [set bufdata [zstream_get $fd]]] > 0} { + append buf $bufdata + } + } + } + return $r + } + close - finalize { + eventClean $fd + if {$zcmd != ""} { + rename $zcmd "" + } + unset pos + } + } +} + +proc ::zip::rawstream_handler {ifd ioffset ilen cmd fd {a1 ""} {a2 ""} args} { + upvar ::zip::_rawstream_pos($fd) pos + switch -- $cmd { + initialize { + return [list initialize finalize watch read seek] + } + watch { + eventWatch $fd $a1 + } + seek { + switch $a2 { + 1 - current { incr a1 $pos } + 2 - end { incr a1 $ilen } + } + if {$a1 < 0} {set a1 0} + if {$a1 > $ilen} {set a1 $ilen} + set pos $a1 + return $pos + } + read { + seek $ifd $ioffset + seek $ifd $pos current + set n $a1 + if {$n + $pos > $ilen} { set n [expr {$ilen - $pos}] } + set fc [read $ifd $n] + incr pos [string length $fc] + return $fc + } + close - finalize { + eventClean $fd + unset pos + } + } +} + +proc ::zip::rawstream {ifd ilen} { + set cname _rawstream_[incr ::zip::zseq] + set start [tell $ifd] + set cmd [list ::zip::rawstream_handler $ifd $start $ilen] + if {[catch { + set fd [chan create read $cmd] + }]} { + set fd [rechan $cmd 2] + } + set ::zip::_rawstream_pos($fd) 0 + return $fd +} + diff --git a/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.tm b/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.tm new file mode 100644 index 00000000..19c21289 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/commandstack-0.4.tm @@ -0,0 +1,518 @@ + + +#JMN 2021 - Public Domain +#cooperative command renaming +# +# REVIEW 2024 - code was originally for specific use in packageTrace +# - code should be reviewed for more generic utility. +# - API is obscure and undocumented. +# - unclear if intention was only for builtins +# - consider use of newer 'info cmdtype' - (but need also support for safe interps) +# - oo dispatch features may be a better implementation - especially for allowing undoing command renames in the middle of a stack. +# - document that replacement command should use 'commandstack::get_next_command ' for delegating to command as it was prior to rename +#changes: +#2024 +# - mungecommand to support namespaced commands +# - fix mistake - hardcoded _originalcommand_package -> _originalcommand_ +#2021-09-18 +# - initial version +# - e.g Support cooperation between packageSuppress and packageTrace which both rename the package command +# - They need to be able to load and unload in any order. +# + +#strive for no other package dependencies here. + + +namespace eval commandstack { + variable all_stacks + variable debug + set debug 0 + variable known_renamers [list ::packagetrace ::packageSuppress] + if {![info exists all_stacks]} { + #don't wipe it + set all_stacks [dict create] + } +} + +namespace eval commandstack::util { + #note - we can't use something like md5 to ID proc body text because we don't want to require additional packages. + #We could store the full text of the body to compare - but we need to identify magic strings from cooperating packages such as packageTrace + #A magic comment was chosen as the identifying method. + #The string IMPLEMENTOR_*! is searched for where the text between _ and ! is the name of the package that implemented the proc. + + #return unspecified if the command is a proc with a body but no magic comment ID + #return unknown if the command doesn't have a proc body to analyze + #otherwise return the package name identified in the magic comment + proc get_IMPLEMENTOR {command} { + #assert - command has already been resolved to a namespace ie fully qualified + if {[llength [info procs $command]]} { + #look for *IMPLEMENTOR_*! + set prefix IMPLEMENTOR_ + set suffix "!" + set body [uplevel 1 [list info body $command]] + if {[string match "*$prefix*$suffix*" $body]} { + set prefixposn [string first "$prefix" $body] + set pkgposn [expr {$prefixposn + [string length $prefix]}] + #set suffixposn [string first $suffix [string range $body $pkgposn $pkgposn+60]] + set suffixposn [string first $suffix $body $pkgposn] + return [string range $body $pkgposn $suffixposn-1] + } else { + return unspecified + } + } else { + if {[info commands tcl::info::cmdtype] ne ""} { + #tcl9 and maybe some tcl 8.7s ? + switch -- [tcl::info::cmdtype $command] { + native { + return builtin + } + default { + return undetermined + } + } + } else { + return undetermined + } + } + } +} +namespace eval commandstack::renamed_commands {} +namespace eval commandstack::temp {} ;#where we create proc initially before renaming into place + +namespace eval commandstack { + namespace export {[a-z]*} + proc help {} { + return { + + } + } + + proc debug {{on_off {}}} { + variable debug + if {$on_off eq ""} { + return $debug + } else { + if {[string is boolean -strict $debug]} { + set debug [expr {$on_off && 1}] + return $debug + } + } + } + + proc get_stack {{command ""}} { + variable all_stacks + if {$command eq ""} { + return $all_stacks + } + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + return [dict get $all_stacks $command] + } else { + return [list] + } + } + + #get the implementation to which the renamer (renamer is usually calling namespace) originally renamed it, or the implementation it now points to. + #review - performance impact. Possible to use oo for faster dispatch whilst allowing stack re-orgs? + #e.g if renaming builtin 'package' - this command is generally called 'a lot' + proc get_next_command {command renamer tokenid} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + #stack is a list of dicts, 1st entry is token { } + set posn [lsearch -index 1 $stack [list $command $renamer $tokenid]] + if {$posn > -1} { + set record [lindex $stack $posn] + return [dict get $record implementation] + } else { + error "(commandstack::get_next_command) ERROR: unable to determine next command for '$command' using token: $command $renamer $tokenid" + } + } else { + return $command + } + } + proc basecall {command args} { + variable all_stacks + set command [uplevel 1 [list namespace which $command]] + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {[llength $stack]} { + set rec1 [lindex $stack 0] + tailcall [dict get $rec1 implementation] {*}$args + } else { + tailcall $command {*}$args + } + } else { + tailcall $command {*}$args + } + } + + + #review. + # defaults to calling namespace - but can be arbitrary string + proc rename_command {args} { + #todo: consider -forcebase 1 or similar to allow this rename to point to bottom of stack (original command) bypassing existing renames + # - need to consider that upon removing, that any remaining rename that was higher on the stack should not also be diverted to the base - but rather to the next lower in the stack + # + if {[lindex $args 0] eq "-renamer"} { + set renamer [lindex $args 1] + set arglist [lrange $args 2 end] + } else { + set renamer "" + set arglist $args + } + if {[llength $arglist] != 3} { + error "commandstack::rename_command usage: rename_command ?-renamer ? command procargs procbody" + } + lassign $arglist command procargs procbody + + set command [uplevel 1 [list namespace which $command]] + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + variable all_stacks + variable known_renamers + variable renamer_command_tokens ;#monotonically increasing int per :: representing number of renames ever done. + if {$renamer eq ""} { + set renamer [uplevel 1 [list namespace current]] + } + if {$renamer ni $known_renamers} { + lappend known_renamers $renamer + dict set renamer_command_tokens [list $renamer $command] 0 + } + + #TODO - reduce emissions to stderr - flag for debug? + + #e.g packageTrace and packageSuppress packages use this convention. + set nextinfo [uplevel 1 [list\ + apply {{command renamer procbody} { + #todo - munge dash so we can make names in renamed_commands separable + # {- _dash_} ? + set mungedcommand [string map {:: _ns_} $command] + set mungedrenamer [string map {:: _ns_} $renamer] + set tokenid [lindex [dict incr renamer_command_tokens [list $renamer $command]] 1] + set next_target ::commandstack::renamed_commands::${mungedcommand}-original-$mungedrenamer-$tokenid ;#default is to assume we are the only one playing around with it, but we'll check for known associates too. + set do_rename 0 + if {[llength [info procs $command]] || [llength [info commands $next_target]]} { + #$command is not the standard builtin - something has replaced it, could be ourself. + set next_implementor [::commandstack::util::get_IMPLEMENTOR $command] + set munged_next_implementor [string map {:: _ns_} $next_implementor] + #if undetermined/unspecified it could be the latest renamer on the stack - but we can't know for sure something else didn't rename it. + if {[dict exists $::commandstack::all_stacks $command]} { + set comstacks [dict get $::commandstack::all_stacks $command] + } else { + set comstacks [list] + } + set this_renamer_previous_entries [lsearch -all -index 3 $comstacks $renamer] ;#index 3 is value for second dict entry - (value for key 'renamer') + if {[llength $this_renamer_previous_entries]} { + if {$next_implementor eq $renamer} { + #previous renamer was us. Rather than assume our job is done.. compare the implementations + #don't rename if immediate predecessor is same code. + #set topstack [lindex $comstacks end] + #set next_impl [dict get $topstack implementation] + set current_body [info body $command] + lassign [commandstack::lib::split_body $current_body] _ current_code + set current_code [string trim $current_code] + set new_code [string trim $procbody] + if {$current_code eq $new_code} { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command with same procbody - Aborting rename." + puts stderr [::commandstack::show_stack $command] + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command - but appears to be with new code - proceeding." + puts stdout "----------" + puts stdout "$current_code" + puts stdout "----------" + puts stdout "$new_code" + puts stdout "----------" + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + puts stderr "(commandstack::rename_command) WARNING - renamer '$renamer' has already renamed the '$command' command, but is not immediate predecessor - proceeding anyway... (untested)" + puts stderr + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } elseif {$next_implementor in $::commandstack::known_renamers} { + set next_target ::commandstack::renamed_commands::${mungedcommand}-${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {builtin}} { + #native/builtin could still have been renamed + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } elseif {$next_implementor in {unspecified undetermined}} { + #could be a standard tcl proc, or from application or package + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } else { + puts stderr "(commandstack::rename_command) Warning - pkg:'$next_implementor' has renamed the '$command' command. Attempting to cooperate. (untested)" + set next_target ::commandstack::renamed_commands::${mungedcommand}_${munged_next_implementor}-$mungedrenamer-$tokenid + set do_rename 1 + } + } else { + #_originalcommand_ + #assume builtin/original + set next_implementor original + #rename $command $next_target + set do_rename 1 + } + #There are of course other ways in which $command may have been renamed - but we can't detect. + set token [list $command $renamer $tokenid] + return [dict create next_target $next_target next_implementor $next_implementor token $token do_rename $do_rename] + } } $command $renamer $procbody] + ] + + + variable debug + if {$debug} { + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + puts stderr "(commandstack::rename_command) Subsequent rename of command '$command'. (previous renames: [llength $stack]). Renaming to [dict get $nextinfo next_target]" + } else { + #assume this is the original + puts stderr "(commandstack::rename_command) 1st detected rename of command '$command'. Renaming to [dict get $nextinfo next_target]" + } + } + + #token is always first dict entry. (Value needs to be searched with lsearch -index 1 ) + #renamer is always second dict entry (Value needs to be searched with lsearch -index 3) + set new_record [dict create\ + token [dict get $nextinfo token]\ + renamer $renamer\ + next_implementor [dict get $nextinfo next_implementor]\ + next_getter [list ::commandstack::get_next_command {*}[dict get $nextinfo token]]\ + implementation [dict get $nextinfo next_target]\ + ] + if {![dict get $nextinfo do_rename]} { + #review + puts stderr "no rename performed" + return [dict create implementation ""] + } + catch {rename ::commandstack::temp::testproc ""} + set nextinit [string map [list %command% $command %renamer% $renamer %next_getter% [dict get $new_record next_getter] %original_implementation% [dict get $new_record implementation]] { + #IMPLEMENTOR_%renamer%! (mechanism: 'commandstack::rename_command -renamer %renamer% %command% ) + set COMMANDSTACKNEXT_ORIGINAL %original_implementation% ;#informational/debug for overriding proc. + set COMMANDSTACKNEXT [%next_getter%] + ## + }] + set final_procbody "$nextinit$procbody" + #build the proc at a temp location so that if it raises an error we don't adjust the stack or replace the original command + #(e.g due to invalid argument specifiers) + proc ::commandstack::temp::testproc $procargs $final_procbody + uplevel 1 [list rename $command [dict get $nextinfo next_target]] + uplevel 1 [list rename ::commandstack::temp::testproc $command] + dict lappend all_stacks $command $new_record + + + return $new_record + } + + #todo - concept of 'pop' for renamer. Remove topmost entry specific to the renamer + #todo - removal by token to allow renamer to have multiple entries for one command but to remove one that is not the topmost + #todo - removal of all entries pertaining to a particular renamer + #todo - allow restore to bottom-most implementation (original) - regardless of what renamers have cooperated in the stack? + + #remove by token, or by commandname if called from same context as original rename_command + #If only a commandname is supplied, and there were multiple renames from the same context (same -renamer) only the topmost is removed. + #A call to remove_rename with no token or renamer, and from a namespace context which didn't perform a rename will not remove anything. + #similarly a nonexistant token or renamer will not remove anything and will just return the current stack + proc remove_rename {token_or_command} { + if {[llength $token_or_command] == 3} { + #is token + lassign $token_or_command command renamer tokenid + } elseif {[llength $token_or_command] == 2} { + #command and renamer only supplied + lassign $token_or_command command renamer + set tokenid "" + } elseif {[llength $token_or_command] == 1} { + #is command name only + set command $token_or_command + set renamer [uplevel 1 [list namespace current]] + set tokenid "" + } + set command [uplevel 1 [list namespace which $command]] + variable all_stacks + variable known_renamers + if {$renamer ni $known_renamers} { + error "(commandstack::remove_rename) ERROR: renamer $renamer not in list of known_renamers '$known_renamers' for command '$command'. Ensure remove_rename called from same context as rename_command was, or explicitly supply exact token or { }" + } + if {[dict exists $all_stacks $command]} { + set stack [dict get $all_stacks $command] + if {$tokenid ne ""} { + #token_or_command is a token as returned within the rename_command result dictionary + #search first dict value + set doomed_posn [lsearch -index 1 $stack $token_or_command] + } else { + #search second dict value + set matches [lsearch -all -index 3 $stack $renamer] + set doomed_posn [lindex $matches end] ;#we don't have a full token - pop last entry for this renamer + } + if {$doomed_posn ne "" && $doomed_posn > -1} { + set doomed_record [lindex $stack $doomed_posn] + if {[llength $stack] == ($doomed_posn + 1)} { + #last on stack - put the implemenation from the doomed_record back as the actual command + uplevel #0 [list rename $command ""] + uplevel #0 [list rename [dict get $doomed_record implementation] $command] + } elseif {[llength $stack] > ($doomed_posn + 1)} { + #there is at least one more record on the stack - rewrite it to point where the doomed_record pointed + set rewrite_posn [expr {$doomed_posn + 1}] + set rewrite_record [lindex $stack $rewrite_posn] + + if {[dict get $rewrite_record next_implementor] ne $renamer} { + puts stderr "(commandstack::remove_rename) WARNING: next record on the commandstack didn't record '$renamer' as the next_implementor - not deleting implementation [dict get $rewrite_record implementation]" + } else { + uplevel #0 [list rename [dict get $rewrite_record implementation] ""] + } + dict set rewrite_record next_implementor [dict get $doomed_record next_implementor] + #don't update next_getter - it always refers to self + dict set rewrite_record implementation [dict get $doomed_record implementation] + lset stack $rewrite_posn $rewrite_record + dict set all_stacks $command $stack + } + set stack [lreplace $stack $doomed_posn $doomed_posn] + dict set all_stacks $command $stack + + } + return $stack + } + return [list] + } + + proc show_stack {{commandname_glob *}} { + variable all_stacks + if {![regexp {[?*]} $commandname_glob]} { + #if caller is attempting exact match - use the calling context to resolve in case they didn't supply namespace + set commandname_glob [uplevel 1 [list namespace which $commandname_glob]] + } + if {[package provide punk::lib] ne "" && [package provide punk] ne ""} { + #punk pipeline also needed for patterns + return [punk::lib::pdict -channel none all_stacks $commandname_glob/@*/@*.@*] + } else { + set result "" + set matchedkeys [dict keys $all_stacks $commandname_glob] + #don't try to calculate widest on empty list + if {[llength $matchedkeys]} { + set widest [tcl::mathfunc::max {*}[lmap v $matchedkeys {tcl::string::length $v}]] + set indent [string repeat " " [expr {$widest + 3}]] + set indent2 "${indent} " ;#8 spaces for " i = " where i is 4 wide + set padkey [string repeat " " 20] + foreach k $matchedkeys { + append result "$k = " + set i 0 + foreach stackmember [dict get $all_stacks $k] { + if {$i > 0} { + append result "\n$indent" + } + append result [string range "$i " 0 4] " = " + set j 0 + dict for {k v} $stackmember { + if {$j > 0} { + append result "\n$indent2" + } + set displaykey [string range "$k$padkey" 0 20] + append result "$displaykey = $v" + incr j + } + incr i + } + append result \n + } + } + return $result + } + } + + #review + #document when this is to be called. Wiping stacks without undoing renames seems odd. + proc Delete_stack {command} { + variable all_stacks + if {[dict exists $all_stacks $command]} { + dict unset all_stacks $command + return 1 + } else { + return 1 + } + } + + #can be used to temporarily put a stack aside - should manually rename back when done. + #review - document how/when to use. example? intention? + proc Rename_stack {oldname newname} { + variable all_stacks + if {[dict exists $all_stacks $oldname]} { + if {[dict exists $all_stacks $newname]} { + error "(commandstack::rename_stack) cannot rename $oldname to $newname - $newname already exists in stack" + } else { + #set stackval [dict get $all_stacks $oldname] + #dict unset all_stacks $oldname + #dict set all_stacks $newname $stackval + dict set all_stacks $newname [lindex [list [dict get $all_stacks $oldname] [dict unset all_stacks $oldname]] 0] + } + } + } +} + + + + + + + + +namespace eval commandstack::lib { + proc splitx {str {regexp {[\t \r\n]+}}} { + #snarfed from tcllib textutil::splitx to avoid the dependency + # Bugfix 476988 + if {[string length $str] == 0} { + return {} + } + if {[string length $regexp] == 0} { + return [::split $str ""] + } + if {[regexp $regexp {}]} { + return -code error "splitting on regexp \"$regexp\" would cause infinite loop" + } + + set list {} + set start 0 + while {[regexp -start $start -indices -- $regexp $str match submatch]} { + foreach {subStart subEnd} $submatch break + foreach {matchStart matchEnd} $match break + incr matchStart -1 + incr matchEnd + lappend list [string range $str $start $matchStart] + if {$subStart >= $start} { + lappend list [string range $str $subStart $subEnd] + } + set start $matchEnd + } + lappend list [string range $str $start end] + return $list + } + proc split_body {procbody} { + set marker "##" + set header "" + set code "" + set found_marker 0 + foreach ln [split $procbody \n] { + if {!$found_marker} { + if {[string trim $ln] eq $marker} { + set found_marker 1 + } else { + append header $ln \n + } + } else { + append code $ln \n + } + } + if {$found_marker} { + return [list $header $code] + } else { + return [list "" $procbody] + } + } +} + +package provide commandstack [namespace eval commandstack { + set version 0.4 +}] + + diff --git a/src/vfs/_vfscommon.vfs/modules/overtype-1.7.4.tm b/src/vfs/_vfscommon.vfs/modules/overtype-1.7.4.tm index 95f7d05f..e4ea54d7 100644 --- a/src/vfs/_vfscommon.vfs/modules/overtype-1.7.4.tm +++ b/src/vfs/_vfscommon.vfs/modules/overtype-1.7.4.tm @@ -2765,6 +2765,21 @@ tcl::namespace::eval overtype { set o_codestack [lremove $o_codestack {*}$dup_posns] lappend o_codestack $code lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b\[[0-1];[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?;[0-9][0-9]?[0-9]?t} $code]} { + #pablodraw 24bit color - convert to standard sgr RGB code + #we could do a more precise 000-255 regexp for each r g b, something like: ((?:[0-1]?[0-9]?[0-9])|(?:2[0-4][0-9])|(?:25[0-5])) + #but that seems more expensive for little likely use (?) review + lassign [regexp -all -inline {\x1b\[([0-1]);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?);([0-9][0-9]?[0-9]?)t} $code] _ isfg pablo_r pablo_g pablo_b + #todo - if any r g b value > 255 - add as [list other $code] + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + set dup_posns [lsearch -all -exact $o_codestack $rgbcode] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $rgbcode + lappend overlay_grapheme_control_list [list sgr $rgbcode] } elseif {[regexp {\x1b7|\x1b\[s} $code]} { #experiment #cursor_save - for the replays review. @@ -4290,6 +4305,32 @@ tcl::namespace::eval overtype { } } } + t { + set params [split $param {;}] + if {[llength $params] == 4} { + #pablodraw 24bit color + #see also: https://github.com/ansilove/libansilove/blob/master/src/loaders/ansi.c + lassign $params isfg pablo_r pablo_g pablo_b + #e.g esc\[0\;171\;87\;0t + set stack [lindex $overlay_grapheme_control_stacks $gci] + puts stderr "pablodraw debug [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #foreach s $stack { + # puts stderr " - [ansistring VIEW -lf 1 -vt 1 -nul 1 $s]" + #} + #we expect first param to be 0 for background, 1 for foreground + if {$isfg} { + set rgbcode "\x1b\[38\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } else { + set rgbcode "\x1b\[48\;2\;$pablo_r\;$pablo_g\;${pablo_b}m" + } + #too late here !! + #lappend stack $rgbcode + #lset overlay_grapheme_control_stacks $gci $stack + + } else { + puts stderr "overtype::renderline unrecognised custom CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } default { puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index 04767a22..45f53981 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -681,12 +681,16 @@ tcl::namespace::eval punk::ansi { } set opt_crm_mode [dict get $opts -crm_mode] - #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines - package require punk::ansi::sauce set binarytext "" - if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { - #no 128 Byte SAUCE record at end of file - set sdict [dict create] + set sdict [dict create] + #if SAUCE data is present - it may give an indication of encoding as well as number of columns/lines + if {![catch {package require punk::ansi::sauce}]} { + if {[catch {punk::ansi::sauce::from_file $fname} sdict]} { + #no 128 Byte SAUCE record at end of file + set sdict [dict create] + } + } else { + puts stderr "Warning punk::ansi::sauce package not loaded - unable to detect or use any SAUCE data to aid in display" } if {![dict size $sdict]} { if {[string tolower [file extension $fname]] eq ".bin"} { diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ansi/sauce-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi/sauce-0.1.0.tm index 8e5f3572..79ea5901 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi/sauce-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi/sauce-0.1.0.tm @@ -79,11 +79,9 @@ tcl::namespace::eval punk::ansi::sauce { set commentlines [list] for {set c 0} {$c < $clines} {incr c} { set rawline [chan read $fd 64] - if {![catch {binary scan $rawline C* str} errM]} { - set ln [format %-64s $str] - } else { - set ln [string repeat " " 64] - } + set str [lib::get_string $rawline] + set ln [format %-64s $str] + if {![catch {encoding convertfrom cp437 $ln} line]} { lappend commentlines $line } else { @@ -271,40 +269,30 @@ tcl::namespace::eval punk::ansi::sauce { #sauce spec says 'character' type is a string encoded according to code page 437 (IBM PC / OEM ASCII) # - in the wild - string may be terminated with null and have following garbage # - 'binary scan $rawchars C* str' to get null-terminated string and pad rhs with spaces to cater for this possibility + #"C" specifier not available in tcl 8.6 + #dict set sdict title [string range $saucerecord 7 41] ;#35 bytes 'character' set rawtitle [string range $saucerecord 7 41] ;#35 bytes 'character' - if {![catch {binary scan $rawtitle C* str} errM]} { - dict set sdict title [format %-35s $str] - } else { - dict set sdict title [string repeat " " 35] - } + set str [lib::get_string $rawtitle] + dict set sdict title [format %-35s $str] #dict set sdict author [string range $saucerecord 42 61] ;#20 bytes 'character' set rawauthor [string range $saucerecord 42 61] ;#20 bytes 'character' - if {![catch {binary scan $rawauthor C* str} errM]} { - dict set sdict author [format %-20s $str] - } else { - dict set sdict author [string repeat " " 20] - } + set str [lib::get_string $rawauthor] + dict set sdict author [format %-20s $str] #dict set sdict group [string range $saucerecord 62 81] ;#20 bytes 'character' set rawgroup [string range $saucerecord 62 81] ;#20 bytes 'character' - if {![catch {binary scan $rawgroup C* str} errM]} { - dict set sdict group [format %-20s $str] - } else { - dict set sdict group [string repeat " " 20] - } - + set str [lib::get_string $rawgroup] + dict set sdict group [format %-20s $str] #dict set sdict date [string range $saucerecord 82 89] ;#8 bytes 'character' - set rawdata [string range $saucerecord 82 89] ;#8 bytes 'character' - if {![catch {binary scan $rawdate C* str} errM]} { - dict set sdict date [format %-8s $str] - } else { - dict set sdict date [string repeat " " 8] - } + set rawdate [string range $saucerecord 82 89] ;#8 bytes 'character' + set str [lib::get_string $rawdate] + dict set sdict date [format %-8s $str] + if {[binary scan [string range $saucerecord 90 93] iu v]} { #4 bytes - unsigned littlendian @@ -407,13 +395,8 @@ tcl::namespace::eval punk::ansi::sauce { dict set sdict tflags "" } set rawzstring [string range $saucerecord 106 127] - #Null terminated string use C to terminate at first null - if {[binary scan $rawzstring C* str]} { - dict set sdict tinfos $str - } else { - dict set sdict tinfos "" - } - + set str [lib::get_string $rawzstring] + dict set sdict tinfos $str @@ -503,6 +486,23 @@ tcl::namespace::eval punk::ansi::sauce { tcl::namespace::eval punk::ansi::sauce::lib { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase tcl::namespace::path [tcl::namespace::parent] + + + #get_string caters for possible null-terminated strings as these may be seen in the wild even though sauce doesn't specify they should be null-terminated + if {[catch {binary scan x C v}]} { + #fallback for tcl 8.6 + proc get_string {bytes} { + set cstr [lindex [split $bytes \0] 0] + binary scan $cstr a* str + return $str + } + } else { + proc get_string {bytes} { + binary scan $bytes C* str + return $str + } + } + } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm index 558f6bde..24f98b6b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm @@ -6345,7 +6345,7 @@ tcl::namespace::eval punk::args { } indexexpression { #tcl 9.1+? tip 615 'string is index' - if {$echeck eq "" || [catch {lindex {} $e_check}]} { + if {$e_check eq "" || [catch {lindex {} $e_check}]} { set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs]] $msg lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm index d7eaf639..ce35138e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm @@ -444,6 +444,8 @@ tcl::namespace::eval ::punk::libunknown { proc zipfs_tclPkgUnknown {name args} { #puts "-> zipfs_tclPkgUnknown $name $args EXPERIMENTAL" + global dir + variable epoch set pkg_epoch [dict get $epoch pkg current] @@ -609,7 +611,7 @@ tcl::namespace::eval ::punk::libunknown { incr sourced ;#count as sourced even if source fails; keep before actual source action #::tcl::Pkg::source $file #lappend sourced_files $file - tcl_Pkg_source $file + namespace eval :: [list ::punk::libunknown::tcl_Pkg_source $file] } trap {POSIX EACCES} {} { # $file was not readable; silently ignore puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (1)" @@ -640,7 +642,7 @@ tcl::namespace::eval ::punk::libunknown { incr sourced #lappend sourced_files $file #::tcl::Pkg::source $file - tcl_Pkg_source $file + namespace eval :: [list punk::libunknown::tcl_Pkg_source $file] } trap {POSIX EACCES} {} { # $file was not readable; silently ignore puts stderr "zipfs_tclPkgUnknown file unreadable '$file' while trying to load $name (2)" @@ -1367,7 +1369,7 @@ tcl::namespace::eval ::punk::libunknown { } } if {[llength $ok_forgets]} { - return [::package:: forget {*}$ok_forgets] + return [uplevel 1 [list ::package:: forget {*}$ok_forgets]] } else { return } @@ -1449,7 +1451,7 @@ tcl::namespace::eval ::punk::libunknown { } } default { - return [::package:: {*}$args] + return [uplevel 1 [list ::package:: {*}$args]] } } } diff --git a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm index 5b504e58..330018ae 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/packagepreference-0.1.0.tm @@ -63,39 +63,6 @@ package require commandstack #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::packagepreference::class { - #*** !doctools - #[subsection {Namespace punk::packagepreference::class}] - #[para] class definitions - #if {[tcl::info::commands [tcl::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 # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -188,7 +155,7 @@ tcl::namespace::eval punk::packagepreference { #although we could shortcircuit using vsatisfies to return the ver #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. #e.g a package require logger further down the commandstack - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } if {!$is_exact && [llength $vwant] <= 1 } { @@ -238,7 +205,7 @@ tcl::namespace::eval punk::packagepreference { } #return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] try { - set result [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] + set result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg $lversion-$lversion]] } trap {} {emsg eopts} { #REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry #under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown @@ -282,9 +249,9 @@ tcl::namespace::eval punk::packagepreference { if {[regexp {[A-Z]} $pkg]} { #legacy package names #only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation - if {[catch {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} { + if {[catch {uplevel 1 [list $COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant]} v]} { try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -294,7 +261,7 @@ tcl::namespace::eval punk::packagepreference { } else { #return [$COMMANDSTACKNEXT require $pkg {*}$vwant] try { - set require_result [$COMMANDSTACKNEXT require $pkg {*}$vwant] + set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] } trap {} {emsg eopts} { return -options $eopts $emsg } @@ -328,14 +295,14 @@ tcl::namespace::eval punk::packagepreference { catch { #$COMMANDSTACKNEXT require $pkg {*}$vwant #j2 - $COMMANDSTACKNEXT require punk::args::moduledoc::$dp + uplevel 1 [list $COMMANDSTACKNEXT require punk::args::moduledoc::$dp] } } #--------------------------------------------------------------- return $require_result } default { - return [$COMMANDSTACKNEXT {*}$args] + return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] } }