From bc9bacd82bbae434e38609cce10e3c15c0eb0d95 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 10 Nov 2025 02:09:57 +1100 Subject: [PATCH] tclcore doc updates, punk::args fixes, cmdtrace --- src/modules/argparsingtest-999999.0a1.0.tm | 27 +- src/modules/poshinfo-999999.0a1.0.tm | 2 +- src/modules/proctrace-999999.0a1.0.tm | 396 ++ src/modules/proctrace-buildversion.txt | 3 + src/modules/punk-0.1.tm | 799 +-- src/modules/punk/aliascore-999999.0a1.0.tm | 3 +- src/modules/punk/ansi-999999.0a1.0.tm | 368 +- src/modules/punk/args-999999.0a1.0.tm | 495 +- .../args/moduledoc/tclcore-999999.0a1.0.tm | 492 +- src/modules/punk/console-999999.0a1.0.tm | 56 +- src/modules/punk/fileline-999999.0a1.0.tm | 9 +- src/modules/punk/fileline-buildversion.txt | 2 +- src/modules/punk/lib-999999.0a1.0.tm | 619 ++- src/modules/punk/lib-buildversion.txt | 2 +- src/modules/punk/libunknown-0.1.tm | 24 +- src/modules/punk/mix/util-999999.0a1.0.tm | 2 +- src/modules/punk/netbox-999999.0a1.0.tm | 1368 ++--- src/modules/punk/netbox/man-999999.0a1.0.tm | 189 +- src/modules/punk/ns-999999.0a1.0.tm | 1896 ++++++- src/modules/punk/repl-999999.0a1.0.tm | 33 +- .../punk/repl/codethread-999999.0a1.0.tm | 104 +- src/modules/punk/safe-999999.0a1.0.tm | 16 +- src/modules/punk/trie-999999.0a1.0.tm | 87 +- src/modules/punkcheck-0.1.0.tm | 25 +- .../files/testscript_parsing.tcl | 68 + .../lib/index_functions.test | 22 +- .../lib-0.1.3_testsuites/lib/parse.test | 43 + .../parse.test#..+lib+parse.test.fauxlink | 0 src/modules/textblock-999999.0a1.0.tm | 41 +- src/vendormodules/overtype-1.7.2.tm | 4892 +++++++++++++++++ 30 files changed, 9885 insertions(+), 2198 deletions(-) create mode 100644 src/modules/proctrace-999999.0a1.0.tm create mode 100644 src/modules/proctrace-buildversion.txt create mode 100644 src/modules/test/punk/#modpod-lib-999999.0a1.0/files/testscript_parsing.tcl create mode 100644 src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/parse.test create mode 100644 src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/tests/parse.test#..+lib+parse.test.fauxlink create mode 100644 src/vendormodules/overtype-1.7.2.tm diff --git a/src/modules/argparsingtest-999999.0a1.0.tm b/src/modules/argparsingtest-999999.0a1.0.tm index a6a7d014..492bd94c 100644 --- a/src/modules/argparsingtest-999999.0a1.0.tm +++ b/src/modules/argparsingtest-999999.0a1.0.tm @@ -314,34 +314,13 @@ namespace eval argparsingtest { @values } proc test1_punkargs_by_id {args} { - set argd [punk::args::get_by_id ::argparsingtest::test1_punkargs_by_id $args] + set argd [punk::args::parse $args withid ::argparsingtest::test1_punkargs_by_id] return [tcl::dict::get $argd opts] } - punk::args::define { - @id -id ::argparsingtest::test1_punkargs2 - @cmd -name argtest4 -help "test of punk::args::parse comparative performance" - @leaders -min 0 -max 0 - @opts -anyopts 0 - -return -default string -type string - -frametype -default \uFFEF -type string - -show_edge -default \uFFEF -type string - -show_seps -default \uFFEF -type string - -join -type none -multiple 1 - -x -default "" -type string - -y -default b -type string - -z -default c -type string - -1 -default 1 -type boolean - -2 -default 2 -type integer - -3 -default 3 -type integer - @values -min 0 -max 0 - } - proc test1_punkargs2 {args} { - set argd [punk::args::parse $args withid ::argparsingtest::test1_punkargs2] - return [tcl::dict::get $argd opts] } - proc test1_punkargs2_parsecache {args} { - set argd [punk::args::parse $args -cache 1 withid ::argparsingtest::test1_punkargs2] + proc test1_punkargs_parsecache {args} { + set argd [punk::args::parse $args -cache 1 withid ::argparsingtest::test1_punkargs_by_id] return [tcl::dict::get $argd opts] } diff --git a/src/modules/poshinfo-999999.0a1.0.tm b/src/modules/poshinfo-999999.0a1.0.tm index aafd491e..be12d4f2 100644 --- a/src/modules/poshinfo-999999.0a1.0.tm +++ b/src/modules/poshinfo-999999.0a1.0.tm @@ -211,7 +211,7 @@ tcl::namespace::eval poshinfo { globs -multiple 1 -default * -help "" } proc themes {args} { - set argd [punk::args::get_by_id ::poshinfo::themes $args] + set argd [punk::args::parse $args withid ::poshinfo::themes] set return_as [dict get $argd opts -as] set formats [dict get $argd opts -format] ;#multiple if {"yaml" in $formats} { diff --git a/src/modules/proctrace-999999.0a1.0.tm b/src/modules/proctrace-999999.0a1.0.tm new file mode 100644 index 00000000..e94b1395 --- /dev/null +++ b/src/modules/proctrace-999999.0a1.0.tm @@ -0,0 +1,396 @@ +# -*- 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 proctrace 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +package require Tcl 8.6- + +################## +## Module Name -- proctrace.tcl +## Original Author -- Emmanuel Frecon +## Description: +## +## This module is meant to be a last resort debugging facility. It will +## arrange for being able to trace execution either at the entry of +## procedure, either of all commands within procedures. The defaults are to +## trace all procedures, except the one from a few packages known to slow +## execution down. See beginning of library for an explanation of the +## options. +## +################## + + +tcl::namespace::eval ::proctrace { + variable PUNKARGS + + namespace eval vars { + # File to trace execution to (if no file is specified, tracing will + # occur on the standard error) + variable -file "" + # List of pattern to match against the name of current and future + # procedures. Only the procedures matching the patterns in this list + # will be considered for tracing. + variable -allowed {*} + # List of patterns to match against the name of procedure that should + # not be considered for tracing. This is a subset of the ones allowed. + variable -denied {::tcl::* ::aes::* ::logger::*} + # A boolean, turn it on to trace the execution of each command block + # within the procedures. + variable -detailed off + + variable fd stderr; # File descriptor where to trace + variable version 0.2; # Current package version. + variable enabled 1; # Is tracing enabled + } + + # Automatically export all procedures starting with lower case and + # create an ensemble for an easier API. + namespace export {[a-z]*} + namespace ensemble create +} + +# ::proctrace::init -- Init and start tracing +# +# Arrange to trace the execution of code either at the entry of procedure, +# either of all commands within procedures. This command takes a number of +# dash led options, these are described a the beginning of the library. +# +# Arguments: +# args List of dash-led options and arguments. +# +# Results: +# None. +# +# Side Effects: +# Will start tracing, which means a LOT of output! +proc ::proctrace::init { args } { + # Detect all options available to the procedure, out of the variables that + # are dash-led. + set opts [list] + foreach o [info vars vars::-*] { + set i [string last "::-" $o] + lappend opts [string trimleft [string range $o $i end] :] + } + + # "parse" the options, i.e. set the values if they should exist... + foreach {k v} $args { + if { $k in $opts } { + set vars::$k $v + } else { + return -code error "$k unknown options, should be [join $opts ,\ ]" + } + } + + # Open the file for output, if relevant. + if { ${vars::-file} ne "" } { + set vars::fd [open ${vars::-file} w] + } + + # Arrange to reroute procedure declaration through our command so we can + # automagically install execution traces. + rename ::proc ::proctrace::RealProc + interp alias {} ::proc {} ::proctrace::Proc + + # Catch up with the current set of existing procedure to make sure we can + # also capture execution within procedure that would have been created + # before ::proctrace::init was called. + foreach p [AllProcs] { + if { [Tracable $p]} { + Follow $p 2 + } + } +} + +proc ::proctrace::terminate {} {set ::proctrace::vars::enabled 0} +proc ::proctrace::resume {} {set ::proctrace::vars::enabled 1} + + +# ::proctrace::AllProcs -- List all declared procedures +# +# Returns a list of all declared procedures, in all namespaces currently +# defined in the interpreter. The implementation recursively list all +# procedures in all sub-namespaces. +# +# Arguments: +# base Namespace at which to start. +# +# Results: +# List of all procedure in current and descendant namespaces. +# +# Side Effects: +# None. +proc ::proctrace::AllProcs { { base "::" } } { + # Get list of procedures in current namespace. + set procs [info procs [string trimright ${base} :]::*] + # Recurse in children namespaces. + foreach ns [namespace children $base] { + set procs [concat $procs [AllProcs $ns]] + } + return $procs +} + + +# ::proctrace::Follow -- Install traces +# +# Install traces to be able to get notified whenever procedures are +# entered or commands within procedures are executed. +# +# Arguments: +# name Name (fully-qualified) of procedure. +# lvl Call stack level at which to execute trace installation +# +# Results: +# None. +# +# Side Effects: +# Arrange for Trace procedure to be called +proc ::proctrace::Follow { name {lvl 1}} { + if { [string is true ${vars::-detailed}] } { + uplevel $lvl [list trace add execution $name enter [list ::proctrace::Trace $name]] + uplevel $lvl [list trace add execution $name enterstep [list ::proctrace::Trace $name]] + } else { + uplevel $lvl [list trace add execution $name enter [list ::proctrace::Trace $name]] + } +} + + +# ::proctrace::Proc -- Capturing procedure +# +# This is our re-implementation of the proc command. It calls the original +# command and also arranges to install traces if appropriate. +# +# Arguments: +# name Name of procedure +# arglist List of arguments to procedure +# body Procedure body. +# +# Results: +# None. +# +# Side Effects: +# Creates a new procedure, possibly arrange for tracing its execution. +proc ::proctrace::Proc { name arglist body } { + uplevel 1 [list ::proctrace::RealProc $name $arglist $body] + if { [Tracable $name]} { + Follow $name 2 + } +} + +variable tinfo +# ::proctrace::Trace -- Perform trace +# +# Trace procedure/command execution. +# +# Arguments: +# target Name of procedure +# command Command being executed +# op Operation (should be enter or enterstep, not used) +# +# Results: +# None. +# +# Side Effects: +# Trace execution on globally allocated file descriptor. +proc ::proctrace::Trace { target command op } { + if {!$::proctrace::vars::enabled} {return} + variable tinfo + if {$op eq "enter"} { + dict set tinfo($target) firstline -1 + dict set tinfo($target) procoffset 0 + dict set tinfo($target) level [expr {[info level]+1}] + dict set tinfo($target) subcmds 0 + puts $vars::fd "ENTER $target >> $command" + return + } else { + if {[tcl::info::level] != [tcl::dict::get $tinfo($target) level]} { + return + } + } + puts $vars::fd "STEP $target >> $command" + flush $vars::fd +} + +# ::proctrace::Tracable -- Should procedure be traced +# +# Decide if a procedure should be traced according to the -allowed and +# -denied options that are global to this library. +# +# Arguments: +# name Fully-qualified procedure name +# +# Results: +# 1 if the procedure should be traced, 0 otherwise. +# +# Side Effects: +# None. +proc ::proctrace::Tracable { name } { + # Traverse -allow(ance) list to allow procedure. + set allow 0 + foreach ptn ${vars::-allowed} { + if { [string match $ptn $name] } { + set allow 1 + break + } + } + + # Possibly negate previous allowance through matching the name against the + # patterns in the -denied list. + foreach ptn ${vars::-denied} { + if { [string match $ptn $name] } { + set allow 0 + break + } + } + + # Return final decision. + return $allow +} + +package provide proctrace $::proctrace::vars::version + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval proctrace::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +#tcl::namespace::eval proctrace::system { +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval proctrace { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)proctrace" + @package -name "proctrace" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return proctrace + } + 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 proctrace + description to come.. + } \n] + } + proc get_topic_License {} { + return "" + } + proc get_topic_Version {} { + return "$::proctrace::version" + } + proc get_topic_Contributors {} { + set authors {{Emmanuel Frecon}} + 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 "::proctrace::about" + dict set overrides @cmd -name "proctrace::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About proctrace + }] \n] + dict set overrides topic -choices [list {*}[proctrace::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [proctrace::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 ::proctrace::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::proctrace::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 ::proctrace +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide proctrace [tcl::namespace::eval proctrace { + variable pkg proctrace + variable version + set version 999999.0a1.0 +}] +return + diff --git a/src/modules/proctrace-buildversion.txt b/src/modules/proctrace-buildversion.txt new file mode 100644 index 00000000..ad438736 --- /dev/null +++ b/src/modules/proctrace-buildversion.txt @@ -0,0 +1,3 @@ +0.2 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 5045579b..2b2118cf 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -398,8 +398,8 @@ if {![llength [info commands ::ansistring]]} { namespace import punk::ansi::ansistring } #require aliascore after punk::lib & punk::ansi are loaded -package require punk::aliascore ;#mostly punk::lib aliases -punk::aliascore::init -force 1 +#package require punk::aliascore ;#mostly punk::lib aliases +#punk::aliascore::init -force 1 package require punk::repl::codethread package require punk::config @@ -533,25 +533,6 @@ namespace eval punk { proc ::punk::K {x y} { return $x} - #todo ansigrep? e.g grep using ansistripped value - proc grepstr1 {pattern data} { - set data [string map {\r\n \n} $data] - set lines [split $data \n] - set matches [lsearch -all -regexp $lines $pattern] - set max [lindex $matches end] - set w1 [string length $max] - set result "" - set H [a+ green bold overline] - set R \x1b\[m - foreach m $matches { - set ln [lindex $lines $m] - set ln [regsub -all $pattern $ln $H&$R] - append result [format %${w1}s $m] " $ln" \n - } - set result [string trimright $result \n] - return $result - } - #---------------------- #todo - fix overtype #create test @@ -559,330 +540,6 @@ namespace eval punk { #---------------------- - punk::args::define { - @id -id ::punk::grepstr - @cmd -name punk::grepstr\ - -summary\ - "Grep for regex pattern in plaintext of supplied (possibly ANSI) string."\ - -help\ - "The grepstr command can find strings in ANSI text even if there are interspersed - ANSI colour codes etc. Even if a word has different coloured/styled letters, the - regex can match the plaintext. (Search is performed on ansistripped text, and then - the matched sections are highlighted and overlayed on the original styled/colourd - input. - - If the input string has ANSI movement codes - the resultant text may not be directly - searchable because the parts of a word may be separated by various codes and other - plain text. To search such an input string, the string should first be 'rendered' to - a form where the ANSI only represents SGR styling (and perhaps other non-movement - codes) using something like overtype::renderline or overtype::rendertext." - - @leaders -min 0 -max 0 - @opts - -returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels { - "matched"\ - " Return only lines that matched." - "breaksandmatches"\ - " Return configured --break= lines in between non-consecutive matches" - "all"\ - " Return all lines. - This has a similar effect to the 'grep' trick of matching on 'pattern|$' - (The $ matches all lines that have an end; ie all lines, but there is no - associated character to which to apply highlighting) - except that when instead using -returnlines all with --line-number, the * - indicator after the linenumber will only be highlighted for lines with matches, - and the following matchcount will indicate zero for non-matching lines." - } - -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num - -C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\ - "Print num lines of leading and trailing context surrounding each match." - -A|--after-context= -parsekey "--after-context" -default 0 -type integer -typesynopsis num - --break= -type string -default "-- %c%\U2260" -help\ - "When returning matched lines and there is a break in consecutive output, - display the break with the given string. %c% is a placeholder for the - number of lines skipped. - Use empty-string for an empty line as a break display. - grepstr --break= needle $haystacklines - - The unix grep utility commonly uses -- for this indicator. - grepstr --break=-- needle $haystacklines - - Customisation example: - grepstr -n \"--break=(skipped %c% lines)\" needle $haystacklines - " - -ansistrip -type none -help\ - "Strip all ansi codes from the input string before processing. - This is not necessary for regex matching purposes, as the matching is always - performed on the ansistripped characters anyway, but by stripping ANSI, the - result only has the ANSI supplied by the -highlight option." - - #-n|--line-number as per grep utility, except that we include a * for matches - -n|--line-number -type none -help\ - "Each output line is preceded by its relative line number in the file, starting at line 1. - For lines that matched the regex, the line number will be suffixed with a * indicator - with the same highlighting as the matched string(s). - The number of matches in the line immediately follows the * - For lines with no matches the * indicator is present with no highlighting and suffixed - with zeros." - -i|--ignore-case -type none -help\ - "Perform case insensitive matching." - -highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\ - "list of ANSI SGR style codes as supported by and documented in punk::ansi::a?" - -- -type none - @values - pattern -type string -help\ - {regex pattern to match in plaintext portion of ANSI string - The pattern may contain bracketed capturing groups, which - will be highlighted in the result. If there is no capturing - group, the entire match will be highlighted. - - Note that if we were to attempt to highlight curly braces based - on the regexp {\{|\}} then the inserted ansi would come between - the backslash and brace in cases where a curly brace is escaped - ie \{ or \} - Depending on how the output is used, this can break the syntactic - structure causing problems. - Instead a pair of regexes such as - {^\{|[^\\](\{+)} - {[^\\](\}+)} - should be used to - exclude braces that are escaped. - (note the capturing groups around each curly brace) - } - string -type string - } - proc grepstr {args} { - lassign [dict values [punk::args::parse $args withid ::punk::grepstr]] leaders opts values received - set pattern [dict get $values pattern] - set data [dict get $values string] - set do_strip 0 - if {[dict exists $received -ansistrip]} { - set data [punk::ansi::ansistrip $data] - } - set highlight [dict get $opts -highlight] - set opt_returnlines [dict get $opts -returnlines] - set context [dict get $opts --context] ;#int - set beforecontext [dict get $opts --before-context] - set beforecontext [expr {max($beforecontext,$context)}] - set aftercontext [dict get $opts --after-context] - set aftercontext [expr {max($aftercontext,$context)}] - set break [dict get $opts --break] - set ignorecase [dict exists $received --ignore-case] - if {$ignorecase} { - set nocase "-nocase" - } else { - set nocase "" - } - - - if {[dict exists $received --line-number]} { - set do_linenums 1 ;#display lineindex+1 - } else { - set do_linenums 0 - } - - if {[llength $highlight] == 0} { - set H "" - set R "" - } else { - set H [a+ {*}$highlight] - set R \x1b\[m - } - - set data [string map {\r\n \n} $data] - if {[punk::ansi::ta::detect $data]} { - set raw_has_ansi 1 - set plain [punk::ansi::ansistrip $data] - } else { - set raw_has_ansi 0 - set plain $data - } - set plainlines [split $plain \n] - set lines [split $data \n] - set matched_line_indices [lsearch -all {*}$nocase -regexp $plainlines $pattern] - if {$opt_returnlines eq "all"} { - set returnlines [punk::lib::range 0 [llength $lines]-1] - } else { - set returnlines $matched_line_indices - } - set max [lindex $returnlines end] - if {[string is integer -strict $max]} { - #if max index is 9 - linenum will be 10, (99->100 etc) - so add one in case we're on such a boundary. - incr max - } - set w1 [string length $max] - set result "" - set placeholder \UFFEF ;#review - set resultlines [dict create] - foreach lineindex $returnlines { - set ln [lindex $lines $lineindex] - set col1 "" - if {$do_linenums} { - set col1 [format "%${w1}s " [expr {$lineindex+1}]] - } - if {$lineindex in $matched_line_indices} { - set plain_ln [lindex $plainlines $lineindex] - #first - determine the number of capturing groups (subexpressions) - #option 1: test the regexp with a single match - #set testparts [regexp {*}$nocase -inline -- $pattern $plain_ln] ;#get fullmatch capturegroup... - #set numgroups [expr {[llength $testparts] -1}] - #option 2: use the regexp -about flag - set numgroups [lindex [regexp -about $pattern] 0] - - set allparts [regexp -all {*}$nocase -indices -inline -- $pattern $plain_ln] - #allparts includes each full match as well as each capturing group - #early versions of tcl 8.6 still didn't support 'lsearch -stride' - avoid for now. - set matchcount [expr {[llength $allparts] / ($numgroups + 1)}] - #set matchcount [llength $allparts] - - if {$matchcount == 0} { - #This probably can't happen (?) - #If it does.. it's more likely to be an issue with our line index than with regexp - puts stderr "Unexpected regex mismatch in grepstr (shouldn't happen) regex: $pattern lineindex: $lineindex" - set matchshow "??? $ln" - dict set resultlines $lineindex $matchshow - continue - } - - # ------------------------------------ - if {$numgroups > 0} { - # restrict ourself to just the capture groups, excluding the full match (if there are capture groups) - set highlight_ranges [list] - set i 0 - #{-1 -1} returned for non-matching group when there are capture-group alternatives - #e.g {(a)|(b)} - foreach range $allparts { - if {($i % ($numgroups+1)) != 0} { - lassign $range a b - if {$range ne {-1 -1} & $a <= $b} { - lappend highlight_ranges $range - } - } - incr i - } - } else { - #No capture group in the regex, each index range is just a full match - set highlight_ranges $allparts - } - # ------------------------------------ - - #puts stderr "numgroups : $numgroups" - #puts stderr "grepstr pattern : $pattern" - #puts stderr "grepstr allparts: $allparts" - #puts stderr "highlight_ranges: $highlight_ranges" - if {$do_linenums} { - append col1 $H*$R[format %03s $matchcount] - } - - if {$raw_has_ansi} { - set overlay "" - set i 0 - foreach hrange $highlight_ranges { - lassign $hrange s e - set prelen [expr {$s - $i}] - #append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]$R - append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e] - set i [expr {$e + 1}] - } - set tail [string range $plain_ln $e+1 end] - append overlay [string repeat $placeholder [string length $tail]] - #puts "$overlay" - #puts "$ln" - #set rendered [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay] - set rendered [overtype::renderspace -transparent $placeholder -insert_mode 0 $ln $overlay] - } else { - set rendered "" - set i 0 - foreach hrange $highlight_ranges { - lassign $hrange s e - set prelen [expr {$s - $i}] - #append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e] - append rendered [string range $plain_ln $i $s-1] $H [string range $plain_ln $s $e] $R - set i [expr {$e + 1}] - } - append rendered [string range $plain_ln $e+1 end] - } - - if {$do_linenums} { - set matchshow "$col1 $rendered" - } else { - set matchshow $rendered - } - - #--------------------------------------------------------------- - set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1] - set s [expr {$lineindex-$beforecontext-1}] - if {$s < -1} {set s -1} - foreach p $prelines { - incr s - #append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n - if {![dict exists $resultlines $s]} { - if {$do_linenums} { - set show "[format "%${w1}s " [expr {$s+1}]]- $p" - } else { - set show $p - } - dict set resultlines $s $show - } - } - #--------------------------------------------------------------- - dict set resultlines $lineindex $matchshow - #--------------------------------------------------------------- - set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext] - set s $lineindex - foreach p $postlines { - incr s - if {![dict exists $resultlines $s]} { - if {$do_linenums} { - set show "[format "%${w1}s " [expr {$s+1}]]- $p" - } else { - set show $p - } - dict set resultlines $s $show - } - } - #--------------------------------------------------------------- - } else { - if {$do_linenums} { - append col1 "*000" - set show "$col1 $ln" - } else { - set show $ln - } - dict set resultlines $lineindex $show - } - - } - set ordered_resultlines [lsort -integer [dict keys $resultlines]] - set result "" - set i -1 - set do_break 0 - if {$opt_returnlines eq "breaksandmatches"} { - set do_break 1 - } - if {$do_break} { - foreach r $ordered_resultlines { - incr i - if {$r > $i} { - set c [expr {$r - $i}] - append result [string map [list %c% $c] $break] \n - } - append result [dict get $resultlines $r] \n - set i $r - } - if {$i<[llength $lines]-1} { - set c [expr {[llength $lines]-1-$i}] - append result [string map [list %c% $c] $break] \n - } - } else { - foreach r $ordered_resultlines { - append result [dict get $resultlines $r] \n - } - } - set result [string trimright $result \n] - return $result - } - proc stacktrace {} { set stack "Stack trace:\n" for {set i 1} {$i < [info level]} {incr i} { @@ -909,38 +566,6 @@ namespace eval punk { return $stack } - #review - there are various type of uuid - we should use something consistent across platforms - #twapi is used on windows because it's about 5 times faster - but is this more important than consistency? - #twapi is much slower to load in the first place (e.g 75ms vs 6ms if package names already loaded) - so for oneshots tcllib uuid is better anyway - #(counterpoint: in the case of punk - we currently need twapi anyway on windows) - #does tcllib's uuid use the same mechanisms on different platforms anyway? - proc ::punk::uuid {} { - set has_twapi 0 - if 0 { - if {"windows" eq $::tcl_platform(platform)} { - if {![catch { - set loader [zzzload::pkg_wait twapi] - } errM]} { - if {$loader in [list failed loading]} { - catch {puts stderr "Unexpected problem during thread-load of pkg twapi - zzload::pkg_wait returned $loader"} - } - } else { - package require twapi - } - if {[package provide twapi] ne ""} { - set has_twapi 1 - } - } - } - if {!$has_twapi} { - if {[catch {package require uuid} errM]} { - error "Unable to load a package for uuid on this platform. Try installing tcllib's uuid (any platform) - or twapi for windows" - } - return [uuid::uuid generate] - } else { - return [twapi::new_uuid] - } - } namespace eval argdoc { punk::args::define { @id -id ::punk::get_runchunk @@ -4183,7 +3808,7 @@ namespace eval punk { #pipealias should capture the namespace context of the pipeline so that commands are resolved in the namespace in which the pipealias is created proc pipealias {targetcmd args} { set cmdcopy [punk::valcopy $args] - set nscaller [uplevel 1 [list namespace current]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] } proc pipealias_extract {targetcmd} { @@ -4194,7 +3819,7 @@ namespace eval punk { #although the pipealias2 'concat' alias is cleaner in that the original pipeline can be extracted using list commands - it runs much slower proc pipealias2 {targetcmd args} { set cmdcopy [punk::valcopy $args] - set nscaller [uplevel 1 [list namespace current]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] } @@ -4224,9 +3849,9 @@ namespace eval punk { if {$pipecmd in [info commands $pipecmd]} { #puts "==nscaller: '[uplevel 1 [list namespace current]]'" #uplevel 1 [list ::namespace import $pipecmd] - set existing_path [uplevel 1 [list ::namespace path]] + set existing_path [uplevel 1 [list ::tcl::namespace::path]] if {$cmdns ni $existing_path} { - uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] + uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]] } tailcall $pipecmd {*}$args } @@ -4394,9 +4019,9 @@ namespace eval punk { debug.punk.pipe.compile {match_assign creating proc $pipecmd} 2 uplevel 1 [list ::proc $pipecmd args $script] - set existing_path [uplevel 1 [list ::namespace path]] + set existing_path [uplevel 1 [list ::tcl::namespace::path]] if {$cmdns ni $existing_path} { - uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] + uplevel 1 [list ::tcl::namespace::path [concat $existing_path $cmdns]] } tailcall $pipecmd {*}$args } @@ -5090,7 +4715,7 @@ namespace eval punk { } debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 - set ns [uplevel 1 {::namespace current}] + set ns [uplevel 1 {::tcl::namespace::current}] if {!$add_argsdata} { debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 #puts stderr " script: $script" @@ -5399,7 +5024,7 @@ namespace eval punk { } set UnknownPending($name) pending set ret [catch { - auto_load $name [uplevel 1 {::namespace current}] + auto_load $name [uplevel 1 {::tcl::namespace::current}] } msg opts] unset UnknownPending($name) if {$ret != 0} { @@ -5492,162 +5117,163 @@ namespace eval punk { } if {$isrepl || (([info level] == 1) && (([info script] eq "" ) ) && ([info exists tcl_interactive] && $tcl_interactive))} { - if {![info exists auto_noexec]} { - set new [auto_execok $name] - if {$new ne ""} { - set redir "" - if {[namespace which -command console] eq ""} { - set redir ">&@stdout <@stdin" - } + if {![info exists auto_noexec]} { + set new [auto_execok $name] + if {$new ne ""} { + set redir "" + if {[namespace which -command console] eq ""} { + set redir ">&@stdout <@stdin" + } - #windows experiment todo - use twapi and named pipes - #twapi::namedpipe_server {\\.\pipe\something} - #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones - #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc - # - if {[string first " " $new] > 0} { - set c1 $name - } else { - set c1 $new - } + #windows experiment todo - use twapi and named pipes + #twapi::namedpipe_server {\\.\pipe\something} + #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones + #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc + # - # -- --- --- --- --- - set idlist_stdout [list] - set idlist_stderr [list] - #set shellrun::runout "" - #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks - #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] - #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + if {[string first " " $new] > 0} { + set c1 $name + } else { + set c1 $new + } - if {[punk::config::configure running auto_exec_mechanism] eq "experimental"} { - #TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it - #not a trivial task + # -- --- --- --- --- + set idlist_stdout [list] + set idlist_stderr [list] + #set shellrun::runout "" + #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] - #This runs external executables in a context in which they are not attached to a terminal - #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output - #ctrl-c propagation also needs to be considered + if {[punk::config::configure running auto_exec_mechanism] eq "experimental"} { + #TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it + #not a trivial task - set teehandle punksh - uplevel 1 [list ::catch \ - [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] + #This runs external executables in a context in which they are not attached to a terminal + #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output + #ctrl-c propagation also needs to be considered + + set teehandle punksh + uplevel 1 [list ::catch \ + [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] - if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { - dict set ::tcl::UnknownOptions -code error - set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" + if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" + } else { + #no point returning "exitcode 0" if that's the only non-error return. + #It is misleading. Better to return empty string. + set ::tcl::UnknownResult "" + } } else { - #no point returning "exitcode 0" if that's the only non-error return. - #It is misleading. Better to return empty string. - set ::tcl::UnknownResult "" + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + } - } else { - set repl_runid [punk::get_repl_runid] - #set ::punk::last_run_display [list] - - set redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] - #we can't detect stdout/stderr output from the exec - #for now emit an extra \n on stderr - #todo - there is probably no way around this but to somehow exec in the context of a completely separate console - #This is probably a tricky problem - especially to do cross-platform - # - # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit - if {[dict get $::tcl::UnknownOptions -code] == 0} { - set c green - set m "ok" - } else { - set c yellow - set m "errorCode $::errorCode" + + foreach id $idlist_stdout { + shellfilter::stack::remove stdout $id } - set chunklist [list] - lappend chunklist [list "info" "[a $c]$m[a] " ] - if {$repl_runid != 0} { - tsv::lappend repl runchunks-$repl_runid {*}$chunklist + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id } - - } - - foreach id $idlist_stdout { - shellfilter::stack::remove stdout $id - } - foreach id $idlist_stderr { - shellfilter::stack::remove stderr $id - } - # -- --- --- --- --- + # -- --- --- --- --- - #uplevel 1 [list ::catch \ - # [concat exec $redir $new [lrange $args 1 end]] \ - # ::tcl::UnknownResult ::tcl::UnknownOptions] - - #puts "===exec with redir:$redir $::tcl::UnknownResult ==" - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult - } - } + #uplevel 1 [list ::catch \ + # [concat exec $redir $new [lrange $args 1 end]] \ + # ::tcl::UnknownResult ::tcl::UnknownOptions] - if {$name eq "!!"} { - set newcmd [history event] - } elseif {[regexp {^!(.+)$} $name -> event]} { - set newcmd [history event $event] - } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { - set newcmd [history event -1] - catch {regsub -all -- $old $newcmd $new newcmd} - } - if {[info exists newcmd]} { - tclLog $newcmd - history change $newcmd 0 - uplevel 1 [list ::catch $newcmd \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult - } - - set ret [catch {set candidates [info commands $name*]} msg] - if {$name eq "::"} { - set name "" - } - if {$ret != 0} { - dict append opts -errorinfo \ - "\n (expanding command prefix \"$name\" in unknown)" - return -options $opts $msg - } - # Filter out bogus matches when $name contained - # a glob-special char [Bug 946952] - if {$name eq ""} { - # Handle empty $name separately due to strangeness - # in [string first] (See RFE 1243354) - set cmds $candidates - } else { - set cmds [list] - foreach x $candidates { - if {[string first $name $x] == 0} { - lappend cmds $x + #puts "===exec with redir:$redir $::tcl::UnknownResult ==" + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } } - } - #punk - disable prefix match search - set default_cmd_search 0 - if {$default_cmd_search} { - if {[llength $cmds] == 1} { - uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ + if {$name eq "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name -> event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if {[info exists newcmd]} { + tclLog $newcmd + history change $newcmd 0 + uplevel 1 [list ::catch $newcmd \ ::tcl::UnknownResult ::tcl::UnknownOptions] dict incr ::tcl::UnknownOptions -level return -options $::tcl::UnknownOptions $::tcl::UnknownResult } - if {[llength $cmds]} { - return -code error "ambiguous command name \"$name\": [lsort $cmds]" + + set ret [catch {set candidates [info commands $name*]} msg] + if {$name eq "::"} { + set name "" } - } else { - #punk hacked version - report matches but don't run - if {[llength $cmds]} { - return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" + if {$ret != 0} { + dict append opts -errorinfo \ + "\n (expanding command prefix \"$name\" in unknown)" + return -options $opts $msg + } + # Filter out bogus matches when $name contained + # a glob-special char [Bug 946952] + if {$name eq ""} { + # Handle empty $name separately due to strangeness + # in [string first] (See RFE 1243354) + set cmds $candidates + } else { + set cmds [list] + foreach x $candidates { + if {[string first $name $x] == 0} { + lappend cmds $x + } + } } - } + #punk - disable prefix match search + set default_cmd_search 0 + if {$default_cmd_search} { + if {[llength $cmds] == 1} { + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + if {[llength $cmds]} { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" + } + } else { + #punk hacked version - report matches but don't run + if {[llength $cmds]} { + return -code error "unknown command name \"$name\": possible match(es) [lsort $cmds]" + } + + } } @@ -5803,10 +5429,10 @@ namespace eval punk { if {[string length $ns] && ![namespace exists $ns]} { error "unknown_assign_dispatch: namespace '$ns' not found. (Note that pipeline lhs variables cannot be namespaced)" } else { - set nscaller [uplevel 1 [list ::namespace current]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] #jmn set rhsmapped [punk::pipe::lib::pipecmd_namemapping $equalsrhs] - set commands [uplevel 1 [list ::info commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk + set commands [uplevel 1 [list ::tcl::info::commands $pattern=$rhsmapped]] ;#uplevel - or else we are checking from perspective of this namespace ::punk #we must check for exact match of the command in the list - because command could have glob chars. if {"$pattern=$rhsmapped" in $commands} { puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" @@ -6015,7 +5641,7 @@ namespace eval punk { } proc ispipematch {args} { - expr {[lindex [uplevel 1 [list pipematch {*}$args]] 0] eq "ok"} + expr {[lindex [uplevel 1 [list ::punk::pipematch {*}$args]] 0] eq "ok"} } #pipe initiator which will never raise an error *except for pipesyntax* , but always returns {ok {result something}} or {error {mismatch something}} or, for tcl errors {error {reason something}} @@ -6255,7 +5881,7 @@ namespace eval punk { } } lappend binding [list switchargs $args] - apply [list $binding $pipescript [uplevel 1 {::namespace current}]] + apply [list $binding $pipescript [uplevel 1 {::tcl::namespace::current}]] } proc pipedata {data args} { @@ -7085,7 +6711,7 @@ namespace eval punk { #apply [list $binding $pipescript [uplevel 1 ::namespace current]] foreach item $listval { set bindlist [list {*}$binding [list item $item]] - if {[apply [list $bindlist $itemcond [uplevel 1 ::namespace current]] ]} { + if {[apply [list $bindlist $itemcond [uplevel 1 ::tcl::namespace::current]] ]} { lappend filtered_list $item } } @@ -7553,7 +7179,7 @@ namespace eval punk { proc ooinspect {obj} { - set obj [uplevel 1 [list namespace which -command $obj]] + set obj [uplevel 1 [list ::tcl::namespace::which -command $obj]] set isa [lmap type {object class metaclass} { if {![info object isa $type $obj]} continue set type @@ -7696,7 +7322,7 @@ namespace eval punk { foreach {k v} $flags { if {$k ni [dict keys $defaults]} { #error "inspect: unknown option $k. Known options: [dict keys $defaults]. If data contains flaglike elements, consider calling with end-of-opts marker. e.g inspect --" - punk::args::get_by_id ::punk::inspect $args + punk::args::parse $args -errorstyle minimal withid ::punk::inspect } } set opts [dict merge $defaults $flags] @@ -7824,6 +7450,16 @@ namespace eval punk { + proc help {args} { + set chunks [uplevel 1 [list ::punk::help_chunks {*}$args]] + foreach chunk $chunks { + lassign $chunk chan text + puts -nonewline $chan $text + } + puts -nonewline stdout \n + } + #return list of {chan chunk} elements + namespace eval argdoc { punk::args::define { @id -id ::punk::help_chunks @@ -7838,14 +7474,6 @@ namespace eval punk { arg -type any -optional 1 -multiple 1 } } - proc help {args} { - set chunks [uplevel 1 [list ::punk::help_chunks {*}$args]] - foreach chunk $chunks { - lassign $chunk chan text - puts -nonewline $chan $text - } - } - #return list of {chan chunk} elements proc help_chunks {args} { set argd [punk::args::parse $args withid ::punk::help_chunks] lassign [dict values $argd] leaders opts values received @@ -7877,7 +7505,7 @@ namespace eval punk { } set title "[a+ brightgreen] Help System: " set cmdinfo [list] - lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\n\n\n\n"] + lappend cmdinfo [list help "?${I}topic${NI}?" "This help.\nTo see available subitems type:\nhelp topics\n\nFor an unrecognised ${I}topic${NI}\nhelp will look for basic\ninfo for it as a command.\n"] set t [textblock::class::table new -minwidth 51 -show_seps 0] foreach row $cmdinfo { $t add_row $row @@ -7993,35 +7621,40 @@ namespace eval punk { catch { append text \n "Tcl build-info: [::tcl::build-info]" } - if {[punk::lib::check::has_tclbug_script_var]} { - append warningblock \n "minor warning: punk::lib::check::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" - } - if {[punk::lib::check::has_tclbug_safeinterp_compile]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_safeinterp returned true!" \n - append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/1095bf7f75]" - append warningblock [a] + #generate warningblocks for each triggered Tcl bug in namespace ::punk::lib::check + set bugcheck_procs [info procs ::punk::lib::check::has_tclbug*] + foreach bp $bugcheck_procs { + set buginfo [$bp] + if {[dict get $buginfo bug]} { + set level unknown + if {[dict exists $buginfo level]} { + set level [dict get $buginfo level] + } + switch -- $level { + minor {set highlight [punk::ansi::a+ cyan]} + medium {set highlight [punk::ansi::a+ yellow]} + major {set highlight [punk::ansi::a+ red bold]} + default {set highlight ""} + } + append warningblock \n $highlight "warning level: $level $bp triggered." + if {[dict exists $buginfo description]} { + set indent " " + append warningblock \n "[punk::lib::indent [dict get $buginfo description] $indent]" + } + if {[dict exists $buginfo bugref] && [dict get $buginfo bugref] ne ""} { + set bugref [dict get $buginfo bugref] + append warningblock \n "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/$bugref]" + } + append warningblock [a] + } } + if {[catch {lsearch -stride 2 {a b} b}]} { + #has_tclbug_lsearch_strideallinline will have reported bug false because it couldn't test it. set indent " " append warningblock \n "[a+ web-red]warning: lsearch does not seem to support -stride option" \n append warningblock "${indent}(Consider upgrading to a late release of tcl 8.6 or tcl 9+ )" \n append warningblock [a] - } else { - if {[punk::lib::check::has_tclbug_lsearch_strideallinline]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_lsearch_strideallinline returned true!" \n - append warningblock "${indent}(lsearch using -stride -all -inline -subindices does not return values corresponding to subindex when a single -index value is used)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/5a1aaa201d]" - append warningblock [a] - } - } - if {[punk::lib::check::has_tclbug_list_quoting_emptyjoin]} { - set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::check::has_tclbug_list_quoting returned true!" \n - append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n - append warningblock "${indent}see [punk::ansi::hyperlink https://core.tcl-lang.org/tcl/tktview/e38dce74e2]" } lappend chunks [list stdout $text] } @@ -8231,7 +7864,7 @@ namespace eval punk { } default { set text "" - set cinfo [uplevel 1 [list punk::ns::cmdwhich [lindex $topicparts 0]]] + set cinfo [uplevel 1 [list ::punk::ns::cmdwhich [lindex $topicparts 0]]] set wtype [dict get $cinfo whichtype] if {$wtype eq "notfound"} { set externalinfo [auto_execok [lindex $topicparts 0]] @@ -8246,7 +7879,7 @@ namespace eval punk { } else { set text "[dict get $cinfo which] [lrange $topicparts 1 end]" append text \n "Base type: $wtype" - set synopsis [uplevel 1 [list punk::ns::synopsis {*}$topicparts]] + set synopsis [uplevel 1 [list ::punk::ns::synopsis {*}$topicparts]] set synshow "" foreach sline [split $synopsis \n] { if {[regexp {\s*#.*} $sline]} { @@ -8276,12 +7909,16 @@ namespace eval punk { #this hides windows cmd's mode command - probably no big deal - anyone who needs it will know how to exec it. interp alias {} mode {} punk::mode - proc aliases {{glob *}} { - tailcall punk::ns::aliases $glob - } - proc alias {{aliasorglob ""} args} { - tailcall punk::ns::alias $aliasorglob {*}$args - } + + + #proc aliases {{glob *}} { + # tailcall punk::ns::aliases $glob + #} + + ##review + #proc alias {{aliasorglob ""} args} { + # tailcall punk::ns::alias $aliasorglob {*}$args + #} #pipeline-toys - put in lib/scriptlib? @@ -8492,24 +8129,24 @@ namespace eval punk { } - proc repl {startstop} { - switch -- $startstop { - stop { - if {[punk::repl::codethread::is_running]} { - puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter" - set ::repl::done 1 - } - } - start { - if {[punk::repl::codethread::is_running]} { - repl::start stdin - } - } - default { - error "repl unknown action '$startstop' - must be start or stop" - } - } - } + #proc repl {startstop} { + # switch -- $startstop { + # stop { + # if {[punk::repl::codethread::is_running]} { + # puts stdout "Attempting repl stop. Try ctrl-c or exit command to leave interpreter" + # set ::repl::done 1 + # } + # } + # start { + # if {[punk::repl::codethread::is_running]} { + # repl::start stdin + # } + # } + # default { + # error "repl unknown action '$startstop' - must be start or stop" + # } + # } + #} } diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index 33370d4d..0adb4f39 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -116,12 +116,12 @@ tcl::namespace::eval punk::aliascore { pdict ::punk::lib::pdict\ plist {::punk::lib::pdict -roottype list}\ showlist {::punk::lib::showdict -roottype list}\ - grepstr ::punk::grepstr\ rehash ::punk::rehash\ showdict ::punk::lib::showdict\ ansistrip ::punk::ansi::ansistrip\ stripansi ::punk::ansi::ansistrip\ ansiwrap ::punk::ansi::ansiwrap\ + grepstr ::punk::ansi::grepstr\ colour ::punk::console::colour\ color ::punk::console::colour\ ansi ::punk::console::ansi\ @@ -138,6 +138,7 @@ tcl::namespace::eval punk::aliascore { eg ::punk::ns::eg\ aliases ::punk::ns::aliases\ alias ::punk::ns::alias\ + use ::punk::ns::pkguse\ ] #*** !doctools diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 540f3307..31719b23 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -148,16 +148,14 @@ tcl::namespace::eval punk::ansi::class { method render_to_input_line {args} { if {[llength $args] < 1} { #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - #punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args - punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" + punk::args::parse $args -cache 1 withid "::punk::ansi::class::class_ansi render_to_input_line" return } set x [lindex $args end] set arglist [lrange $args 0 end-1] if {[llength $arglist] %2 != 0} { #puts stderr "render_to_input_line usage: ?-dimensions WxH? ?-minus charcount? x" - #punk::args::get_by_id "::punk::ansi::class::class_ansi render_to_input_line" $args - punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" + punk::args::parse $args -cache 1 withid "::punk::ansi::class::class_ansi render_to_input_line" return } set opts [tcl::dict::create\ @@ -171,7 +169,7 @@ tcl::namespace::eval punk::ansi::class { } default { puts stderr "render_to_input_line unexpected argument '$k' usage: ?-dimensions WxH? ?-minus charcount? x" - punk::args::parse $args withid "::punk::ansi::class::class_ansi render_to_input_line" + punk::args::parse $args -cache 1 withid "::punk::ansi::class::class_ansi render_to_input_line" return } } @@ -197,7 +195,8 @@ tcl::namespace::eval punk::ansi::class { if {$opt_minus ne "0"} { set chunk [tcl::string::range $chunk 0 end-$opt_minus] } - set rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] + #set rendered [overtype::renderspace -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] + set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" $chunk] set marker "" for {set i 1} {$i <= $w} {incr i} { if {$i % 10 == 0} { @@ -212,13 +211,15 @@ tcl::namespace::eval punk::ansi::class { set xline [lindex $rlines $x]\n set xlinev [ansistring VIEWSTYLE $xline] set xlinev [tcl::string::map $maplf $xlinev] - set xlinedisplay [overtype::renderspace -wrap 1 -width $w -height 1 "" $xlinev] + #set xlinedisplay [overtype::renderspace -wrap 1 -width $w -height 1 "" $xlinev] + set xlinedisplay [overtype::renderspace -cp437 1 -wrap 1 -width $w -height 1 "" $xlinev] ::append rendered \n $xlinedisplay set chunk [ansistring VIEWSTYLE $chunk] set chunk [tcl::string::map $maplf $chunk] #keep chunkdisplay narrower - leave at 80 or it will get unwieldy for larger image widths - set chunkdisplay [overtype::renderspace -wrap 1 -width 80 -height 1 "" $chunk] + #set chunkdisplay [overtype::renderspace -wrap 1 -width 80 -height 1 "" $chunk] + set chunkdisplay [overtype::renderspace -cp437 1 -wrap 1 -width 80 -height 1 "" $chunk] set renderheight [llength [split $rendered \n]] set chunkdisplay_lines [split $chunkdisplay \n] set chunkdisplay_tail [lrange $chunkdisplay_lines end-$renderheight end] @@ -925,6 +926,347 @@ tcl::namespace::eval punk::ansi { return $result } + + lappend PUNKARGS [list { + @id -id ::punk::ansi::grepstr + @cmd -name punk::ansi::grepstr\ + -summary\ + "Grep for regex pattern in plaintext of supplied (possibly ANSI) string."\ + -help\ + "The grepstr command can find strings in ANSI text even if there are interspersed + ANSI colour codes etc. Even if a word has different coloured/styled letters, the + regex can match the plaintext. (Search is performed on ansistripped text, and then + the matched sections are highlighted and overlayed on the original styled/colourd + input. + + If the input string has ANSI movement codes - the resultant text may not be directly + searchable because the parts of a word may be separated by various codes and other + plain text. To search such an input string, the string should first be 'rendered' to + a form where the ANSI only represents SGR styling (and perhaps other non-movement + codes) using something like overtype::renderline or overtype::rendertext." + + @leaders -min 0 -max 0 + @opts + -returnlines -type string -typesynopsis matched|all -default breaksandmatches -choicecolumns 1 -choices {matched all breaksandmatches} -choicelabels { + "matched"\ + " Return only lines that matched." + "breaksandmatches"\ + " Return configured --break= lines in between non-consecutive matches" + "all"\ + " Return all lines. + This has a similar effect to the 'grep' trick of matching on 'pattern|$' + (The $ matches all lines that have an end; ie all lines, but there is no + associated character to which to apply highlighting) + except that when instead using -returnlines all with --line-number, the * + indicator after the linenumber will only be highlighted for lines with matches, + and the following matchcount will indicate zero for non-matching lines." + } + -B|--before-context= -parsekey "--before-context" -default 0 -type integer -typesynopsis num + -C|--context= -parsekey "--context" -default 0 -type integer -typesynopsis num -help\ + "Print num lines of leading and trailing context surrounding each match." + -A|--after-context= -parsekey "--after-context" -default 0 -type integer -typesynopsis num + --break= -type string -default "-- %c%\U2260" -help\ + "When returning matched lines and there is a break in consecutive output, + display the break with the given string. %c% is a placeholder for the + number of lines skipped. + Use empty-string for an empty line as a break display. + grepstr --break= needle $haystacklines + + The unix grep utility commonly uses -- for this indicator. + grepstr --break=-- needle $haystacklines + + Customisation example: + grepstr -n \"--break=(skipped %c% lines)\" needle $haystacklines + " + -ansistrip -type none -help\ + "Strip all ansi codes from the input string before processing. + This is not necessary for regex matching purposes, as the matching is always + performed on the ansistripped characters anyway, but by stripping ANSI, the + result only has the ANSI supplied by the -highlight option." + + #-n|--line-number as per grep utility, except that we include a * for matches + -n|--line-number -type none -help\ + "Each output line is preceded by its relative line number in the file, starting at line 1. + For lines that matched the regex, the line number will be suffixed with a * indicator + with the same highlighting as the matched string(s). + The number of matches in the line immediately follows the * + For lines with no matches the * indicator is present with no highlighting and suffixed + with zeros." + -i|--ignore-case -type none -help\ + "Perform case insensitive matching." + -highlight -type list -typesynopsis ansinames -default {green bold Black underline overline} -help\ + "list of ANSI SGR style codes as supported by and documented in punk::ansi::a?" + -- -type none + @values + pattern -type string -help\ + {regex pattern to match in plaintext portion of ANSI string + The pattern may contain bracketed capturing groups, which + will be highlighted in the result. If there is no capturing + group, the entire match will be highlighted. + + Note that if we were to attempt to highlight curly braces based + on the regexp {\{|\}} then the inserted ansi would come between + the backslash and brace in cases where a curly brace is escaped + ie \{ or \} + Depending on how the output is used, this can break the syntactic + structure causing problems. + Instead a pair of regexes such as + {^\{|[^\\](\{+)} + {[^\\](\}+)} + should be used to + exclude braces that are escaped. + (note the capturing groups around each curly brace) + } + string -type string + }] + + proc grepstr {args} { + lassign [dict values [punk::args::parse $args withid ::punk::ansi::grepstr]] leaders opts values received + set pattern [dict get $values pattern] + set data [dict get $values string] + set do_strip 0 + if {[dict exists $received -ansistrip]} { + set data [punk::ansi::ansistrip $data] + } + set highlight [dict get $opts -highlight] + set opt_returnlines [dict get $opts -returnlines] + set context [dict get $opts --context] ;#int + set beforecontext [dict get $opts --before-context] + set beforecontext [expr {max($beforecontext,$context)}] + set aftercontext [dict get $opts --after-context] + set aftercontext [expr {max($aftercontext,$context)}] + set break [dict get $opts --break] + set ignorecase [dict exists $received --ignore-case] + if {$ignorecase} { + set nocase "-nocase" + } else { + set nocase "" + } + + + if {[dict exists $received --line-number]} { + set do_linenums 1 ;#display lineindex+1 + } else { + set do_linenums 0 + } + + if {[llength $highlight] == 0} { + set H "" + set R "" + } else { + set H [a+ {*}$highlight] + set R \x1b\[m + } + + #REVIEW + set data [string map {\r\n \n} $data] + + if {[punk::ansi::ta::detect $data]} { + set raw_has_ansi 1 + set plain [punk::ansi::ansistrip $data] + } else { + set raw_has_ansi 0 + set plain $data + } + set plainlines [split $plain \n] + set lines [split $data \n] + set matched_line_indices [lsearch -all {*}$nocase -regexp $plainlines $pattern] + if {$opt_returnlines eq "all"} { + if {[llength $lines] > 0} { + set return_line_indices [punk::lib::range 0 [llength $lines]-1] + } else { + set return_line_indices 0 + } + } else { + set return_line_indices $matched_line_indices + } + set max [lindex $return_line_indices end] + if {[string is integer -strict $max]} { + #if max index is 9 - linenum will be 10, (99->100 etc) - so add one in case we're on such a boundary. + incr max + } + set w1 [string length $max] + set result "" + set placeholder \UFFEF ;#review + set resultlines [dict create] + foreach lineindex $return_line_indices { + set ln [lindex $lines $lineindex] + set col1 "" + if {$do_linenums} { + set col1 [format "%${w1}s " [expr {$lineindex+1}]] + } + if {$lineindex in $matched_line_indices} { + set plain_ln [lindex $plainlines $lineindex] + #first - determine the number of capturing groups (subexpressions) + #option 1: test the regexp with a single match + #set testparts [regexp {*}$nocase -inline -- $pattern $plain_ln] ;#get fullmatch capturegroup... + #set numgroups [expr {[llength $testparts] -1}] + #option 2: use the regexp -about flag + set numgroups [lindex [regexp -about $pattern] 0] + + set allparts [regexp -all {*}$nocase -indices -inline -- $pattern $plain_ln] + #allparts includes each full match as well as each capturing group + #early versions of tcl 8.6 still didn't support 'lsearch -stride' - avoid for now. + set matchcount [expr {[llength $allparts] / ($numgroups + 1)}] + #set matchcount [llength $allparts] + + if {$matchcount == 0} { + #This probably can't happen (?) + #If it does.. it's more likely to be an issue with our line index than with regexp + puts stderr "Unexpected regex mismatch in grepstr (shouldn't happen) regex: $pattern lineindex: $lineindex" + set matchshow "??? $ln" + dict set resultlines $lineindex $matchshow + continue + } + + # ------------------------------------ + if {$numgroups > 0} { + # restrict ourself to just the capture groups, excluding the full match (if there are capture groups) + set highlight_ranges [list] + set i 0 + #{-1 -1} returned for non-matching group when there are capture-group alternatives + #e.g {(a)|(b)} + foreach range $allparts { + if {($i % ($numgroups+1)) != 0} { + lassign $range a b + if {$range ne {-1 -1} & $a <= $b} { + lappend highlight_ranges $range + } + } + incr i + } + } else { + #No capture group in the regex, each index range is just a full match + set highlight_ranges $allparts + } + # ------------------------------------ + + #puts stderr "numgroups : $numgroups" + #puts stderr "grepstr pattern : $pattern" + #puts stderr "grepstr allparts: $allparts" + #puts stderr "highlight_ranges: $highlight_ranges" + if {$do_linenums} { + append col1 $H*$R[format %03s $matchcount] + } + + if {$raw_has_ansi} { + set overlay "" + set i 0 + foreach hrange $highlight_ranges { + lassign $hrange s e + set prelen [expr {$s - $i}] + #append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e]$R + append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e] + set i [expr {$e + 1}] + } + set tail [string range $plain_ln $e+1 end] + append overlay [string repeat $placeholder [string length $tail]] + #puts "$overlay" + #puts "$ln" + #set rendered [overtype::renderline -transparent $placeholder -insert_mode 0 $ln $overlay] + set rendered [overtype::renderspace -transparent $placeholder -insert_mode 0 $ln $overlay] + } else { + set rendered "" + set i 0 + foreach hrange $highlight_ranges { + lassign $hrange s e + set prelen [expr {$s - $i}] + #append overlay [string repeat $placeholder $prelen] $H[string range $plain_ln $s $e] + append rendered [string range $plain_ln $i $s-1] $H [string range $plain_ln $s $e] $R + set i [expr {$e + 1}] + } + append rendered [string range $plain_ln $e+1 end] + } + + if {$do_linenums} { + set matchshow "$col1 $rendered" + } else { + set matchshow $rendered + } + + #--------------------------------------------------------------- + set prelines [lrange $lines $lineindex-$beforecontext $lineindex-1] + set s [expr {$lineindex-$beforecontext-1}] + if {$s < -1} {set s -1} + foreach p $prelines { + incr s + #append result "[format %${w1}s [expr {$s+1}]]- " " " $p \n + if {![dict exists $resultlines $s]} { + if {$do_linenums} { + set show "[format "%${w1}s " [expr {$s+1}]]- $p" + } else { + set show $p + } + dict set resultlines $s $show + } + } + #--------------------------------------------------------------- + dict set resultlines $lineindex $matchshow + #--------------------------------------------------------------- + set postlines [lrange $lines $lineindex+1 $lineindex+$aftercontext] + set s $lineindex + foreach p $postlines { + incr s + if {![dict exists $resultlines $s]} { + if {$do_linenums} { + set show "[format "%${w1}s " [expr {$s+1}]]- $p" + } else { + set show $p + } + dict set resultlines $s $show + } + } + #--------------------------------------------------------------- + } else { + if {$do_linenums} { + append col1 "*000" + set show "$col1 $ln" + } else { + set show $ln + } + dict set resultlines $lineindex $show + } + + } + set ordered_resultlines [lsort -integer [dict keys $resultlines]] + set result "" + set i -1 + set do_break 0 + if {$opt_returnlines eq "breaksandmatches"} { + set do_break 1 + } + if {$do_break} { + foreach r $ordered_resultlines { + incr i + if {$r > $i} { + set c [expr {$r - $i}] + append result [string map [list %c% $c] $break] \n + } + append result [dict get $resultlines $r] \n + set i $r + } + if {$i<[llength $lines]-1} { + set c [expr {[llength $lines]-1-$i}] + append result [string map [list %c% $c] $break] \n + } + } else { + foreach r $ordered_resultlines { + append result [dict get $resultlines $r] \n + } + } + #important not to just strip all \n from tail + if {[string index $result end] eq "\n"} { + set result [string range $result 0 end-1] + } + return $result + } + + + + + + + # -------------------------------- # Taken from term::ansi::code::ctrl # -------------------------------- @@ -952,7 +1294,7 @@ tcl::namespace::eval punk::ansi { } unset _ # ------------------------------ - #REVIEW - see forward/backward map in term::ansi::code::macros::cd::groptim - what are they for?? + #REVIEW - see forward/backward map in term::ansi::code::macros::cd::groptim proc groptim {string} { variable grforw variable grback @@ -2567,10 +2909,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu switch -- $pfx { web - Web - WEB { set tail [tcl::string::tolower [tcl::string::trim [tcl::string::range $i 4 end] -]] - set cont [string range $tail end-11 end] + set cont [tcl::string::range $tail end-11 end] switch -- $cont { -contrasting - -contrastive { - set cname [string range $tail 0 end-12] + set cname [tcl::string::range $tail 0 end-12] } default { set cname $tail @@ -3793,7 +4135,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu proc ansiwrap {args} { if {[llength $args] < 1} { #throw to args::parse to get friendly error/usage display - punk::args::parse $args withid ::punk::ansi::ansiwrap + punk::args::parse $args -cache 1 withid ::punk::ansi::ansiwrap return } #we know there are no valid codes that start with - @@ -6135,7 +6477,7 @@ tcl::namespace::eval punk::ansi::ta { } #perl: ta_strip - punk::args::set_alias ::punk::ansi::ta::strip ::punk::ansi::ansistrip + punk::args::set_idalias ::punk::ansi::ta::strip ::punk::ansi::ansistrip proc strip {text} { #*** !doctools #[call [fun strip] [arg text]] diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 12d29adb..18b9ba2e 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -303,7 +303,7 @@ tcl::namespace::eval ::punk::args::helpers { proc example {args} { #only use punk::args::parse on the unhappy path if {[llength $args] == 0} { - punk::args::parse $args withid ::punk::args::helpers::example + punk::args::parse $args -cache 1 withid ::punk::args::helpers::example return } set str [lindex $args end] @@ -350,11 +350,11 @@ tcl::namespace::eval ::punk::args::helpers { } if {$opt_title ne ""} { - set title "[a+ term-black Term-silver]$opt_title[a]" + set title "[punk::ansi::a+ term-black Term-silver]$opt_title[a]" } else { set title "" } - set str [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [a+ Term-grey white] -ansiborder [a+ term-black Term-silver] -titlealign $opt_titlealign -title $title -boxlimits {hl} -type block $str]] + set str [punk::ansi::ansiwrap Term-grey [textblock::frame -ansibase [punk::ansi::a+ Term-grey white] -ansiborder [punk::ansi::a+ term-black Term-silver] -titlealign $opt_titlealign -title $title -boxlimits {hl} -type block $str]] #puts stderr ------------------- #puts $str #puts stderr ------------------- @@ -368,21 +368,21 @@ tcl::namespace::eval ::punk::args::helpers { #highlight comments first - so that we can also highlight braces within comments to help with detecting unbalanced braces/square brackets in comments #result lines often indicated in examples by \u2192 → #however - it's not present on each line of output, instead indents are used - so we can't so easily highlight all appropriate rows(?) - set str [punk::grepstr -return all -highlight {Term-grey term-darkgreen} {^\s*#.*} $str] ;#Note, will not highlight comments at end of line - like this one - set str [punk::grepstr -return all -highlight {Term-grey term-darkgreen} {;\s*(#.*)} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-darkgreen} {^\s*#.*} $str] ;#Note, will not highlight comments at end of line - like this one + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-darkgreen} {;\s*(#.*)} $str] #Note that if we were to highlight based on the regexp {\{|\}} then the inserted ansi would come between # the backslash and brace in \{ or \} - this breaks the syntactic structure causing problems. - set str [punk::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str] - set str [punk::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str] - set str [punk::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {^\{|[^\\](\{+)} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey tk-darkblue} {[^\\](\}+)} $str] + set str [punk::ansi::grepstr -return all -highlight {Term-grey term-orange1} {\[|\]} $str] #puts stderr ------------------- #puts $str #puts stderr ------------------- } } - set result [textblock::bookend_lines $str [a] "[a defaultbg] [a]"] + set result [textblock::bookend_lines $str [punk::ansi::a] "[punk::ansi::a defaultbg] [punk::ansi::a]"] return $result } lappend PUNKARGS [list { @@ -464,13 +464,21 @@ tcl::namespace::eval ::punk::args::helpers { # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args { - package require punk::assertion - #if 'package forget' was called on this package (e.g when loading test::punk::args) then assert may already exist in the namespace - #namespace import will fail if target exists - catch { - namespace import ::punk::assertion::assert + if {[catch { + package require punk::assertion + }]} { + proc assert {args} { + #failed to load package 'punk::assertion' + } + } else { + #if 'package forget' was called on this package (e.g when loading test::punk::args) then assert may already exist in the namespace + #namespace import will fail if target exists + catch { + namespace import ::punk::assertion::assert + } + punk::assertion::active 1 } - punk::assertion::active 1 + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. @@ -661,26 +669,23 @@ tcl::namespace::eval punk::args { Defaults to string. If no other restrictions are required, choosing -type any does the least validation. recognised types: - any - (unvalidated - accepts anything) - unknown + any, unknown (unvalidated - accepts anything) none (used for flags/switches only. Indicates this is a 'solo' flag ie accepts no value) Not valid as a member of a clause's typenamelist. - int - integer + int, integer number list + regex, regexp indexexpression indexset (as accepted by punk::lib::is_indexset) dict double float - bool - boolean + bool, boolean char file directory @@ -999,7 +1004,7 @@ tcl::namespace::eval punk::args { undefine $id 0 } set is_dynamic [rawdef_is_dynamic $args] - set defspace [uplevel 1 {::namespace current}] + set defspace [uplevel 1 {::tcl::namespace::current}] dict set rawdef_cache_about $args [dict create -id $id -dynamic $is_dynamic -defspace $defspace] dict set id_cache_rawdef $id $args return $id @@ -1051,59 +1056,6 @@ tcl::namespace::eval punk::args { } } - proc idquery_info {id} { - variable id_cache_rawdef - variable rawdef_cache_about - if {[dict exists $id_cache_rawdef $id]} { - set sep [string repeat - 40] - set rawdef [dict get $id_cache_rawdef $id] - if {[dict exists $rawdef_cache_about $rawdef]} { - set idinfo [dict get $rawdef_cache_about $rawdef] - } else { - set idinfo "" - } - set result "raw definition:" - append result \n $sep - append result \n $rawdef - append result \n $sep - append result \n "id info:" - append result \n $idinfo - append result \n $sep - variable rawdef_cache_argdata - #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) - #check for and report if id is present multiple times - set argdata_records [list] - dict for {k v} $rawdef_cache_argdata { - if {[dict get $v id] eq $id} { - if {$k eq $rawdef} { - lappend argdata_records [list 1 $k $v] - } else { - lappend argdata_records [list 0 $k $v] - } - } - } - append result \n "argdata cache:" - if {![llength $argdata_records]} { - append result \n "(not present)" - } else { - append result \n "present [llength $argdata_records] time(s)" - foreach r $argdata_records { - lassign $r match k v - if {$match} { - append result \n " - present with same rawdef key" - } else { - append result \n " - present with different rawdef key" - append result \n " [punk::lib::indent $k { }]" - } - } - if {[llength $argdata_records] > 1} { - append result \n "*more than one record was not expected - review*" - } - } - append result \n $sep - return $result - } - } proc define2 {args} { dict get [resolve {*}$args] id @@ -1162,10 +1114,6 @@ tcl::namespace::eval punk::args { punk::args::parse {} -errorstyle minimal withid ::punk::args::define return } - #if {[lindex $args 0] eq "-dynamic"} { - # set is_dynamic [lindex $args 1] - # set textargs [lrange $args 2 end] - #} #experimental set LVL 2 @@ -1188,7 +1136,7 @@ tcl::namespace::eval punk::args { set block [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $block]] } else { puts stderr "punk::args::resolve calling tstr for id:$id with no known definition space (-defspace empty)" - set block [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $block]] + set block [uplevel $LVL [list ::punk::args::lib::tstr -return string -eval 1 -allowcommands $block]] } } lappend optionspecs $block @@ -1217,43 +1165,95 @@ tcl::namespace::eval punk::args { } else { if {[tcl::dict::exists $argdefcache_unresolved $cache_key]} { + #cached - so first round of substitution already done set pt_params [tcl::dict::get $argdefcache_unresolved $cache_key] lassign $pt_params ptlist paramlist set optionspecs "" + #subst is only being called on the parameters (contents of ${..}) foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] + if {$defspace ne ""} { + append optionspecs $pt [namespace eval $defspace [list ::subst $param]] + } else { + puts stderr "punk::args::resolve (cached) (dynamic) calling subst in [uplevel $LVL [list namespace current]] (no defspace available!)" + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } } } else { set normargs [list] foreach a $textargs { lappend normargs [tcl::string::map {\r\n \n} $a] } - set optionspecs [join $normargs \n] - #dynamic - double substitution required. - #e.g - # set DYN_CHOICES {${[::somewhere::get_choice_list]}} - # set RED [punk::ansi::a+ bold red] - # set RST [punk::ansi::a] - # punk::args::define { - # -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" - #} - if {$defspace ne ""} { - set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] - #JJJ - review - #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -paramindents none $optionspecs]] + + set optionspecs [list] + foreach block $normargs { + if {[string first \$\{ $block] >= 0} { + if {$defspace ne ""} { + set block [namespace eval $defspace [list ::punk::args::lib::tstr -return string -eval 1 -allowcommands -undent 1 $block]] + } else { + puts stderr "punk::args::resolve (dynamic) calling tstr for id:$id with no known definition space (-defspace empty)" + set block [uplevel $LVL [list punk::args::lib::tstr -return string -eval 1 -allowcommands $block]] + } + } + lappend optionspecs $block } + ##dynamic - double substitution required. + ##e.g + ## set DYN_CHOICES {${[::somewhere::get_choice_list]}} + ## set RED [punk::ansi::a+ bold red] + ## set RST [punk::ansi::a] + ## punk::args::define { + ## -arg -choices {${$DYN_CHOICES}} -help "${$RED}important info${$RST}" + ##} + + + set optionspecs [join $optionspecs \n] #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) if {[string first \$\{ $optionspecs] > 0} { set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel lassign $pt_params ptlist paramlist set optionspecs "" foreach pt $ptlist param $paramlist { - append optionspecs $pt [uplevel $LVL [list ::subst $param]] + if {$defspace ne ""} { + append optionspecs $pt [namespace eval $defspace [list ::subst $param]] + } else { + append optionspecs $pt [uplevel $LVL [list ::subst $param]] + } } + #key is the raw def, value is the 2 element list of textparts, paramparts tcl::dict::set argdefcache_unresolved $cache_key $pt_params + } else { + #wasn't really a 'dynamic' definition - no 2nd round parameter substitution in definition + puts stderr "punk::args::resolve - bad @dynamic tag for id:$id - no 2nd round substitution required" } + + + #set optionspecs [join $normargs \n] + #if {$defspace ne ""} { + # set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands $optionspecs]] + # #JJJ - review + # #set optionspecs [namespace eval $defspace [list punk::args::lib::tstr -return string -eval 1 -allowcommands -paramindents none $optionspecs]] + #} + ##REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + #if {[string first \$\{ $optionspecs] > 0} { + # set pt_params [punk::args::lib::tstr -return list -eval 0 $optionspecs] ;#-eval 0 - no need to uplevel + # lassign $pt_params ptlist paramlist + # set optionspecs "" + # foreach pt $ptlist param $paramlist { + # append optionspecs $pt [uplevel $LVL [list ::subst $param]] + # } + # tcl::dict::set argdefcache_unresolved $cache_key $pt_params + #} } #rawdef_cache_argdata should be limited in some fashion or will be a big memory leak??? + #optionspecs is the complete dynamically resolved value - we're caching how that parses into args + + #This means each time a dynamic call has different results we accumulate data.. this seems potentially unsustainable in some cases - REVIEW. + #in many cases we use @dynamic only to ensure latest data, even though that may change rarely - eg for ensemble /object updates + #In that case - caching makes sense. + #For some other functions, the dynamic parts may change every time - which makes caching wasteful as old values are never reused. + #we should probably cache dynamic argdata based on id, and only keep 1 or 2 entries per id. + + #At the very least, these keys aren't really 'raw' - so we should use a different dict? if {[tcl::dict::exists $rawdef_cache_argdata [list $optionspecs]]} { #resolved cache version exists return [tcl::dict::get $rawdef_cache_argdata [list $optionspecs]] @@ -1872,7 +1872,7 @@ tcl::namespace::eval punk::args { tcl::dict::set tmp_leaderspec_defaults $k $v } -choiceinfo - -choicelabels { - if {[llength $v] %2 != 0} { + if {![punk::args::lib::string_is_dict $v]} { error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" } tcl::dict::set tmp_leaderspec_defaults $k $v @@ -2007,7 +2007,7 @@ tcl::namespace::eval punk::args { tcl::dict::set tmp_valspec_defaults $k $v } -choiceinfo - -choicegroups { - if {[llength $v] % 2 != 0} { + if {![punk::args::lib::string_is_dict $v]} { error "punk::args::resolve - key '$k' requires a dictionary value as an argument. got $v id:$DEF_definition_id" } tcl::dict::set tmp_valspec_defaults $k $v @@ -2474,8 +2474,8 @@ tcl::namespace::eval punk::args { tcl::dict::set spec_merged $spec $specval } -validationtransform { - #string is dict only 8.7/9+ - if {[llength $specval] % 2} { + #string is dict only 8.7/9+ - use wrapper to support 8.6 also + if {![punk::args::lib::string_is_dict $specval]} { error "punk::args::resolve - invalid value for key '$spec' in specifications for argument '$argname' - value must be a dictionary @id:$DEF_definition_id" } dict for {tk tv} $specval { @@ -2806,7 +2806,7 @@ tcl::namespace::eval punk::args { ] if {[llength $args] < 1} { #must have at least id - punk::args::parse $args withid ::punk::args::resolved_def + punk::args::parse $args -cache 1 withid ::punk::args::resolved_def return } set patterns [list] @@ -3205,24 +3205,77 @@ tcl::namespace::eval punk::args { variable id_cache_rawdef tcl::dict::exists $id_cache_rawdef $id } - proc aliases {} { + proc idaliases {} { variable aliases punk::lib::showdict $aliases } - proc set_alias {alias id} { + proc set_idalias {alias id} { variable aliases dict set aliases $alias $id } - proc unset_alias {alias} { + proc unset_idalias {alias} { variable aliases dict unset aliases $alias } - proc get_alias {alias} { + proc get_idalias {alias} { variable aliases if {[dict exists $aliases $alias]} { return [tcl::dict::get $aliases $alias] } } + proc id_query {id} { + variable id_cache_rawdef + variable rawdef_cache_about + if {[dict exists $id_cache_rawdef $id]} { + set sep [string repeat - 40] + set rawdef [dict get $id_cache_rawdef $id] + if {[dict exists $rawdef_cache_about $rawdef]} { + set idinfo [dict get $rawdef_cache_about $rawdef] + } else { + set idinfo "" + } + set result "raw definition:" + append result \n $sep + append result \n $rawdef + append result \n $sep + append result \n "id info:" + append result \n $idinfo + append result \n $sep + variable rawdef_cache_argdata + #lsearch -stride not avail (or buggy) in some 8.6 interps - search manually for now (2025). todo - modernize some time after Tcl 9.0/9.1 more widespread.(2027?) + #check for and report if id is present multiple times + set argdata_records [list] + dict for {k v} $rawdef_cache_argdata { + if {[dict get $v id] eq $id} { + if {$k eq $rawdef} { + lappend argdata_records [list 1 $k $v] + } else { + lappend argdata_records [list 0 $k $v] + } + } + } + append result \n "argdata cache:" + if {![llength $argdata_records]} { + append result \n "(not present)" + } else { + append result \n "present [llength $argdata_records] time(s)" + foreach r $argdata_records { + lassign $r match k v + if {$match} { + append result \n " - present with same rawdef key" + } else { + append result \n " - present with different rawdef key" + append result \n " [punk::lib::indent $k { }]" + } + } + if {[llength $argdata_records] > 1} { + append result \n "*more than one record was not expected - review*" + } + } + append result \n $sep + return $result + } + } proc real_id {id} { variable id_cache_rawdef @@ -3452,7 +3505,7 @@ tcl::namespace::eval punk::args { #process list of 2-element lists if {[info exists ${pkgns}::PUNKARGS_aliases]} { foreach adef [set ${pkgns}::PUNKARGS_aliases] { - punk::args::set_alias {*}$adef + punk::args::set_idalias {*}$adef } } } errMsg]} { @@ -4968,7 +5021,7 @@ tcl::namespace::eval punk::args { arglist -type list -optional 0 -help\ "Arguments to parse - supplied as a single list" - @opts + @opts -prefix 0 -form -type list -default * -help\ "Restrict parsing to the set of forms listed. Forms are the orthogonal sets of arguments a @@ -5014,7 +5067,7 @@ tcl::namespace::eval punk::args { set tailtype "" ;#withid|withdef if {[llength $args] < 3} { #error "punk::args::parse - invalid call. < 3 args" - punk::args::parse $args withid ::punk::args::parse + punk::args::parse $args -cache 1 withid ::punk::args::parse } set opts_and_vals $args set parseargs [lpop opts_and_vals 0] @@ -5125,15 +5178,22 @@ tcl::namespace::eval punk::args { variable parse_cache set key [list $parseargs $deflist [dict get $opts -form]] if {[dict exists $parse_cache $key]} { - set result [dict get $parse_cache $key] + set cached [dict get $parse_cache $key] + if {[dict get $cached type] eq "result"} { + return [dict get $cached value] + } else { + #return the error 'elist' + return {*}[dict get $cached value] + } } else { set result [punk::args::get_dict $deflist $parseargs -form [dict get $opts -form]] - dict set parse_cache $key $result + dict set parse_cache $key [dict create type "result" value $result] + return $result } - return $result } } trap {PUNKARGS VALIDATION} {msg erroropts} { set opt_errorstyle [dict get $opts -errorstyle] + set matched_errorstyle [tcl::prefix::match -error "" {enhanced standard basic minimal debug} $opt_errorstyle] #samples from get_dict (review: -argspecs can be *large* especially for multi-form argument definitions) #return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname -argspecs $argspecs]] $msg @@ -5143,9 +5203,10 @@ tcl::namespace::eval punk::args { set ecode [dict get $erroropts -errorcode] #punk ecode is of form PUNKARGS VALIDATION {description..} -key val ... set msg [string map [list %caller% [Get_caller]] $msg] - switch -- $opt_errorstyle { + switch -- $matched_errorstyle { minimal { - return -options [list -code error -errorcode $ecode] $msg + #return -options [list -code error -errorcode $ecode] $msg + set elist [list -options [list -code error -errorcode $ecode] $msg] } basic { #No table layout - unix manpage style @@ -5155,7 +5216,8 @@ tcl::namespace::eval punk::args { if {$argspecs ne ""} { set msg [arg_error $msg $argspecs -aserror 0 -return string -badarg $badarg -form [dict get $opts -form]] } - return -options [list -code error -errorcode $ecode] $msg + #return -options [list -code error -errorcode $ecode] $msg + set elist [list -options [list -code error -errorcode $ecode] $msg] } standard { set customdict [lrange $ecode 3 end] @@ -5164,7 +5226,8 @@ tcl::namespace::eval punk::args { if {$argspecs ne ""} { set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] } - return -options [list -code error -errorcode $ecode] $msg + #return -options [list -code error -errorcode $ecode] $msg + set elist [list -options [list -code error -errorcode $ecode] $msg] } enhanced { set estack [info errorstack] ;#save it before we do anything to replace it (like the catch below) @@ -5182,23 +5245,31 @@ tcl::namespace::eval punk::args { if {$argspecs ne ""} { set msg [arg_error $msg $argspecs -aserror 0 -badarg $badarg -form [dict get $opts -form]] append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg + #return -options [list -code error -errorcode $ecode] $msg + set elist [list -options [list -code error -errorcode $ecode] $msg] } else { #why? todo? append msg \n "(enhanced error information unavailable)" append msg \n "::errorCode summary: $ecode_summary" - return -options [list -code error -errorcode $ecode] $msg + #return -options [list -code error -errorcode $ecode] $msg + set elist [list -options [list -code error -errorcode $ecode] $msg] } } debug { puts stderr "errorstyle debug not implemented" - return -options [list -code error -errorcode $ecode] $msg + #return -options [list -code error -errorcode $ecode] $msg + set elist [list -options [list -code error -errorcode $ecode] $msg] } default { puts stderr "errorstyle $opt_errorstyle not recognised: expected one of minimal basic standard enhanced debug" - return -options [list -code error -errorcode $ecode] $msg + #return -options [list -code error -errorcode $ecode] $msg + set elist [list -options [list -code error -errorcode $ecode] $msg] } } + + set key [list $parseargs $deflist [dict get $opts -form]] + dict set parse_cache $key [dict create type "error" value $elist] + return {*}$elist } trap {PUNKARGS} {msg erropts} { append msg \n "Unexpected PUNKARGS error" return -options [list -code error -errorcode $ecode] $msg @@ -5312,7 +5383,7 @@ tcl::namespace::eval punk::args { } stringstartswith { set pfx [lindex $tp_alternative 1] - if {[string match "$pfx*" $v} { + if {[string match "$pfx*" $v]} { set alloc_ok 1 set alloc_ok 1 ledit all_remaining end end @@ -5325,7 +5396,7 @@ tcl::namespace::eval punk::args { } stringendswith { set sfx [lindex $tp_alternative 1] - if {[string match "*$sfx" $v} { + if {[string match "*$sfx" $v]} { set alloc_ok 1 set alloc_ok 1 ledit all_remaining end end @@ -6263,6 +6334,16 @@ tcl::namespace::eval punk::args { lset clause_results $c_idx $a_idx 1 break } + regex - regexp { + #todo - allow -min and -max to specify number of allowed subexpressions(capture groups) present in regex? + if {[catch {regexp -about $e_check} re_about_msg]} { + set msg "$argclass $argname for %caller% requires type regexp. $re_about_msg. Received: '$e_check'" + lset clause_results $c_idx $a_idx [list errorcode [list PUNKARGS VALIDATION [list typemismatch $type] -badarg $argname -argspecs $argspecs] msg $msg] + } else { + lset clause_results $c_idx $a_idx 1 + break + } + } indexexpression { if {[catch {lindex {} $e_check}]} { set msg "$argclass $argname for %caller% requires type indexexpression. An index as used in Tcl list commands. Received: '$e_check'" @@ -6553,11 +6634,14 @@ tcl::namespace::eval punk::args { } } dict { - if {[llength $e_check] %2 != 0} { + #to maintain support for tcl 8.6 - can't directly use 'string is dict' + if {![punk::args::lib::string_is_dict $e_check]} { set msg "$argclass '$argname' for %caller% requires type 'dict' - must be key value pairs. Received: '$e_check'" lset clause_results $c_idx $a_idx [list err [list typemismatch $type] msg $msg] continue } + #if {[llength $e_check] %2 != 0} { + #} if {[tcl::dict::size $thisarg_checks]} { if {[dict exists $thisarg_checks -minsize]} { set minsizes [dict get $thisarg_checks -minsize] @@ -7420,7 +7504,7 @@ tcl::namespace::eval punk::args { proc get_dict {deflist rawargs args} { #see arg_error regarding considerations around unhappy-path performance - if {[llength $args] % 2 != 0} { + if {![punk::args::lib::string_is_dict $args]} { error "punk::args::get_dict args must be a dict of option value pairs" } set defaults [dict create\ @@ -9186,11 +9270,26 @@ tcl::namespace::eval punk::args { #lappend vlist_check_validate $c_check } else { #unhappy path + + #if prefixes allowed, first see if c_check is an ambiguous prefix + #This is preferable to listing all (possibly many) choices in the error message. if {$choiceprefix} { set prefixmsg " (or a unique prefix of a value)" + #review - case + if {$nocase} { + set longermatches [lsearch -all -inline -nocase $allchoices "$c_check*"] + } else { + set longermatches [lsearch -all -inline $allchoices "$c_check*"] + } + if {[llength $longermatches]} { + set msg "$argclass '$argname' for %caller% seems to be an ambiguous prefix. Try one of:\n [join $longermatches "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" + return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg + } } else { set prefixmsg "" } + + #review: $c vs $c_check for -badval? set msg "$argclass '$argname' for %caller% must be one of the listed values:\n [join $allchoices "\n "]\n$casemsg$prefixmsg. Received: '$c_check'" return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choiceviolation $c choices $allchoices] -badarg $argname -badval $c_check -argspecs $argspecs]] $msg @@ -9465,26 +9564,13 @@ tcl::namespace::eval punk::args { #synopsis potentially called repeatedly with same args? use -cache 1 set argd [punk::args::parse $args -cache 1 withid ::punk::args::synopsis] - if {[catch {package require punk::ansi} errM]} { - set has_punkansi 0 - } else { - set has_punkansi 1 - } - if {$has_punkansi} { - set I [punk::ansi::a+ italic] - set NI [punk::ansi::a+ noitalic] - #for inner question marks marking optional type - set IS [punk::ansi::a+ italic strike] - set NIS [punk::ansi::a+ noitalic nostrike] - #set RST [punk::ansi::a] - set RST "\x1b\[m" - } else { - set I "" - set NI "" - set IS "" - set NIS "" - set RST "" - } + #non-colour SGR such as bold/italic/strike - so we don't need to worry about NOCOLOR settings + set I "\x1b\[3m" ;#[punk::ansi::a+ italic] + set NI "\x1b\[23m" ;# [punk::ansi::a+ noitalic] + #for inner question marks marking optional type + set IS "\x1b\[3\;9m" ;#[punk::ansi::a+ italic strike] + set NIS "\x1b\[23\;29m" ;#[punk::ansi::a+ noitalic nostrike] + set RST "\x1b\[m" ;#[punk::ansi::a] ##set form * ##if {[lindex $args 0] eq "-form"} { @@ -9503,8 +9589,7 @@ tcl::namespace::eval punk::args { set form [dict get $opts -form] set opt_return [dict get $opts -return] set cmditems [dict get $values cmditem] - set id [lindex $cmditems 0] - set cmdargs [lrange $cmditems 1 end] + set cmdargs [lassign $cmditems id] set spec [get_spec $id] @@ -9969,6 +10054,9 @@ tcl::namespace::eval punk::args { } summary { set summary "" + if {![dict exists $received -noheader]} { + set summary "# [Dict_getdef $spec cmd_info -summary ""]\n" + } set FORMS [dict get $SYND FORMS] dict for {form arglist} $FORMS { append summary $id @@ -10001,7 +10089,13 @@ tcl::namespace::eval punk::args { append summary \n } set summary [string trim $summary \n] - return $summary + #only return as summary if full synopsis is wider + #(e.g single option can commonly be shorter than "?options (1 defined)?" + if {[textblock::width $summary] < [textblock::width $syn]} { + return $summary + } else { + return [string trim $syn \n] + } } dict { return $SYND @@ -10022,7 +10116,7 @@ tcl::namespace::eval punk::args { synopsis -multiple 0 -optional 0 }] proc synopsis_summary {args} { - set argd [punk::args::parse $args withid ::punk::args::synopsis_summary] + set argd [punk::args::parse $args -cache 1 withid ::punk::args::synopsis_summary] set synopsis [dict get $argd values synopsis] set summary "" foreach sline [split $synopsis \n] { @@ -10092,7 +10186,7 @@ tcl::namespace::eval punk::args { in the choices list. Subcommands not assigned to a groupname will appear first in an untitled subtable." - -columns -default 4 -type integer -help\ + -columns -default 2 -type integer -help\ "Max number of columns for all subtables in the choices display area" @values -min 1 -max 1 @@ -10114,7 +10208,7 @@ tcl::namespace::eval punk::args { } set defaults [dict create\ -groupdict {}\ - -columns 4\ + -columns 2\ ] set optlist [dict merge $defaults $optlist] dict for {k v} $optlist { @@ -10131,7 +10225,42 @@ tcl::namespace::eval punk::args { #warning - circular package dependency if we try to use this function on punk::ns! package require punk::ns - set subdict [punk::ns::ensemble_subcommands -return dict $ensemble] + set subdict [uplevel 1 [list punk::ns::ensemble_subcommands -return dict $ensemble]] + set unkhandler [uplevel 1 [list ::tcl::namespace::ensemble configure $ensemble -unknown]] + + # ---------------------------------------------------------------------------------------------------------------------------- + #resolution for unknown if performed via another ensemble (eg see punk::lib::ensemble::extend and "ensemble extend" on wiki) + #we cannot sensibly determine subcommands for arbitrary -unknown scripts - but we can for this known (common?) method + # Note that an ensemble might have been extended this way more than once. + set resolve_unknowns 1 + set next_handler $unkhandler + while {$resolve_unknowns} { + #ensure bogus isn't in already known subcommands + set n 1 + set bogus "" + set known_subs [dict keys $subdict] + while {$bogus in $known_subs} { + incr n + set bogus "" + } + if {![catch {uplevel 1 [list {*}$next_handler] $ensemble $bogus} unk_resolver]} { + lassign $unk_resolver unk_ensemble + if {[uplevel 1 [list ::tcl::namespace::ensemble exists $unk_ensemble]]} { + set unkdict [uplevel 1 [list punk::ns::ensemble_subcommands -return dict $unk_ensemble]] + set subdict [dict merge $unkdict $subdict] + set next_handler [uplevel 1 [list ::tcl::namespace::ensemble configure $unk_ensemble -unknown]] + if {$next_handler eq ""} { + set resolve_unknowns 0 + } + } else { + set resolve_unknowns 0 + } + } else { + set resolve_unknowns 0 + } + } + # ---------------------------------------------------------------------------------------------------------------------------- + set allsubs [dict keys $subdict] # ---------------------------------------------- # manually defined group members may have subcommands that are obsoleted/missing @@ -10187,6 +10316,8 @@ tcl::namespace::eval punk::args { lappend others $sc } } + #sometimes the subdict we get from the namespace ensemble map is not sorted + set others [lsort $others] #don't use full cmdinfo if $cmd is a single element if {[llength $cmd] == 1} { @@ -10218,12 +10349,15 @@ tcl::namespace::eval punk::args { $cmd\ [dict get $cinfo origin]\ ] + set N [punk::ansi::a+ normal] + set RST [punk::ansi::a] foreach checkid $id_checks { if {[punk::args::id_exists $checkid]} { dict lappend choiceinfodict $sc {doctype punkargs} dict lappend choiceinfodict $sc [list subhelp {*}$checkid] #dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::ns::synopsis $checkid][punk::ansi::a] - dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::args::synopsis $checkid][punk::ansi::a] + #dict set choicelabelsdict $sc [punk::ansi::a+ normal][punk::args::synopsis $checkid][punk::ansi::a] + dict set choicelabelsdict $sc ${N}[punk::args::synopsis -return summary $checkid]${RST} break } } @@ -10253,8 +10387,12 @@ tcl::namespace::eval punk::args { #} } + set help "" + if {$unkhandler ne ""} { + set help [list -help "[punk::ansi::a+ bold]WARNING: -unknown handler exists. Not all options may be displayed.[punk::ansi::a]"] + } set argdef "" - append argdef "subcommand -choicegroups \{" \n + append argdef "subcommand $help -choicegroups \{" \n append argdef " \"\" \{$others\}" \n dict for {g members} $opt_groupdict { append argdef " \"$g\" \{$members\}" \n @@ -10303,7 +10441,8 @@ tcl::namespace::eval punk::args::lib { #tcl86 compat for string is dict - but without -strict or -failindex options if {[catch {string is dict {}} errM]} { proc string_is_dict {args} { - #ignore opts + #compatibility for tcl pre 9.0 + #ignores opts set str [lindex $args end] if {[catch {llength $str} len]} { return 0 @@ -10315,6 +10454,7 @@ tcl::namespace::eval punk::args::lib { } } else { proc string_is_dict {args} { + #tcl 9+ version string is dict {*}$args } } @@ -10525,8 +10665,9 @@ tcl::namespace::eval punk::args::lib { dict set opts -allowcommands 1 } if {[llength $arglist] % 2 != 0} { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args + if {[info commands ::punk::args::parse] ne ""} { + #punk::args::get_by_id ::punk::args::lib::tstr $args + punk::args::parse $args withid ::punk::args::lib::tstr return } else { error "punk::args::lib::tstr expected option/value pairs prior to last argument" @@ -10539,8 +10680,9 @@ tcl::namespace::eval punk::args::lib { dict set opts $fullk $v } default { - if {[info commands ::punk::args::get_by_id] ne ""} { - punk::args::get_by_id ::punk::args::lib::tstr $args + if {[info commands ::punk::args::parse] ne ""} { + #punk::args::get_by_id ::punk::args::lib::tstr $args + punk::args::parse $args withid ::punk::args::lib::tstr return } else { error "punk::args::lib::tstr unknown option $k. Known options: [dict keys $opts]" @@ -10549,7 +10691,7 @@ tcl::namespace::eval punk::args::lib { } } set opt_allowcommands [dict get $opts -allowcommands] - set opt_paramindents [dict get $opts -paramindents] + set opt_paramindents [dict get $opts -paramindents] set test_paramindents [tcl::prefix::match -error "" {none line position} $opt_paramindents] if {$test_paramindents ni {none line position}} { error "punk::args::lib::tstr option -paramindents invalid value '$opt_paramindents'. Must be one of none, line, position or an unambiguous abbreviation thereof." @@ -10576,7 +10718,6 @@ tcl::namespace::eval punk::args::lib { set templatestring [punk::args::lib::indent $templatestring $opt_indent] } - #set parts [_tstr_split $templatestring] if {[string first \$\{ $templatestring] < 0} { set parts [list $templatestring] } else { @@ -10787,42 +10928,6 @@ tcl::namespace::eval punk::args::lib { } return $parts } - #based on punk::ansi::ta::_perlish_split - proc _tstr_split {text} { - if {$text eq ""} { - return {} - } - set list [list] - set start 0 - #ideally re should allow curlies within but we will probably need a custom parser to do it - #(js allows nested string interpolation) - #set re {\$\{[^\}]*\}} - set re {\$\{(?:(?!\$\{).)*\}} - - #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code - - #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW - while {[regexp -start $start -indices -- $re $text match]} { - lassign $match matchStart matchEnd - #puts "->start $start ->match $matchStart $matchEnd" - if {$matchEnd < $matchStart} { - puts "e:$matchEnd < s:$matchStart" - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] - incr start - if {$start >= [tcl::string::length $text]} { - break - } - continue - } - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] - set start [expr {$matchEnd+1}] - #? - if {$start >= [tcl::string::length $text]} { - break - } - } - return [lappend list [tcl::string::range $text $start end]] - } #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. proc indent {text {prefix " "}} { diff --git a/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm b/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm index 328804ca..9d8f4f37 100644 --- a/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/moduledoc/tclcore-999999.0a1.0.tm @@ -1535,8 +1535,11 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { lappend PUNKARGS [list { @id -id ::fconfigure - @cmd -name "Built-in: chan configure" -help\ - "Query or set the configuration options of the channel named ${$I}channel${$NI} + @cmd -name "Built-in: chan configure"\ + -summary\ + {Query/set channel configuration options}\ + -help\ + {Query or set the configuration options of the channel named ${$I}channel${$NI} If no ${$I}optionName${$NI} or ${$I}value${$NI} arguments are supplied, the command returns a list containing alternating option names and values for the channel. If ${$I}optionName${$NI} is supplied but no ${$I}value${$NI} then the @@ -1577,12 +1580,106 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { ${$I}newSize${$NI} must be a number of no more than one million, allowing buffers of up to one million bytes in size. ${$B}-encoding${$N} ${$I}name${$NI} - + This option is used to specify the encoding of the channel as one of the + named encodings returned by ${$B}encoding names${$N}, so that the data can be + converted to and from Unicode for use in Tcl. For instance, in order for + Tcl to read characters from a Japanese file in ${$B}shiftjis${$N} and properly + process and display the contents, the encoding would be set to ${$B}shiftjis${$N}. + Thereafter, when reading from the channel, the bytes in the Japanese file + would be converted to Unicode as they are read. Writing is also supported + - as Tcl strings are written to the channel they will automatically be + converted to the specified encoding on output. + + If a file contains pure binary data (for instance, a JPEG image), the + encoding for the channel should be configured to be ${$B}iso8859-1${$N}. Tcl will + then assign no interpretation to the data in the file and simply read or + write raw bytes. The Tcl ${$B}binary${$N} command can be used to manipulate this + byte-oriented data. It is usually better to set the ${$B}-translation${$B} option to + ${$B}binary${$N} when you want to transfer binary data, as this turns off the other + automatic interpretations of the bytes in the stream as well. + + The default encoding for newly opened channels is the same platform- and + locale-dependent system encoding used for interfacing with the operating + system, as returned by encoding system. ${$B}-eofchar${$N} ${$I}char${$NI} - + This option supports DOS file systems that use Control-z (\x1A) as an end + of file marker. If char is not an empty string, then this character signals + end-of-file when it is encountered during input. Otherwise (the default) + there is no special end of file character marker. The acceptable range for + ${$B}-eofchar${$N} values is \x01 - \x7f; attempting to set ${$B}-eofchar${$N} to a value + outside of this range will generate an error. ${$B}-profile${$N} ${$I}profile${$NI} - - ${$B}-translation${$N} ${$I}translation${$NI}" + Specifies the encoding profile to be used on the channel. The encoding + transforms in use for the channel's input and output will then be subject + to the rules of that profile. Any failures will result in a channel error. + See ${$B}PROFILES${$N} in the ${$B}encoding(n)${$N} documentation for details about encoding + profiles. + ${$B}-translation${$N} ${$I}translation${$NI} + ${$B}-translation${$N} {${$I}inTranslation${$NI} ${$I}outTranslation${$NI}} + In Tcl scripts the end of a line is always represented using a single + newline character (\n). However, in actual files and devices the end of a + line may be represented differently on different platforms, or even for + different devices on the same platform. For example, under UNIX newlines + are used in files, whereas carriage-return-linefeed sequences are normally + used in network connections. On input (i.e., with ${$B}chan gets${$N} and ${$B}chan read${$N}) + the Tcl I/O system automatically translates the external end-of-line + representation into newline characters. Upon output (i.e., with ${$B}chan puts${$N}), + the I/O system translates newlines to the external end-of-line representation. + The default translation mode, ${$B}auto${$N}, handles all the common cases + automatically, but the ${$B}-translation${$N} option provides explicit control over the + end of line translations. + + The value associated with -translation is a single item for read-only and + write-only channels. The value is a two-element list for read-write channels; + the read translation mode is the first element of the list, and the write + translation mode is the second element. As a convenience, when setting the + translation mode for a read-write channel you can specify a single value that + will apply to both reading and writing. When querying the translation mode of + a read-write channel, a two-element list will always be returned. The + following values are currently supported: + + ${$B}auto${$N} + As the input translation mode, ${$B}auto${$N} treats any of newline (${$B}lf${$N}), carriage + return (${$B}cr${$N}), or carriage return followed by a newline (${$B}crlf${$N}) as the end of + line representation. The end of line representation can even change from + line-to-line, and all cases are translated to a newline. As the output + translation mode, ${$B}auto${$N} chooses a platform specific representation; for + sockets on all platforms Tcl chooses ${$B}crlf${$N}, for all Unix flavors, it + chooses ${$B}lf${$N}, and for the various flavors of Windows it chooses ${$B}crlf${$N}. The + default setting for ${$B}-translation${$N} is ${$B}auto${$N} for both input and output. + + ${$B}binary${$N} + Like ${$B}lf${$N}, no end-of-line translation is performed, but in addition, sets + ${$B}-eofchar${$N} to the empty string to disable it, and sets ${$B}-encoding${$N} to + ${$B}iso8859-1${$N}. With this one setting, a channel is fully configured for binary + input and output: Each byte read from the channel becomes the Unicode + character having the same value as that byte, and each character written + to the channel becomes a single byte in the output. This makes it possible + to work seamlessly with binary data as long as each character in the data + remains in the range of 0 to 255 so that there is no distinction between + binary data and text. For example, A JPEG image can be read from a such a + channel, manipulated, and then written back to such a channel. + + ${$B}cr${$N} + The end of a line in the underlying file or device is represented by a + single carriage return character. As the input translation mode, ${$B}cr${$N} mode + converts carriage returns to newline characters. As the output translation + mode, ${$B}cr${$N} mode translates newline characters to carriage returns. + + ${$B}crlf${$N} + The end of a line in the underlying file or device is represented by a + carriage return character followed by a linefeed character. As the input + translation mode, ${$B}crlf${$N} mode converts carriage-return-linefeed sequences to + newline characters. As the output translation mode, ${$B}crlf${$N} mode translates + newline characters to carriage-return-linefeed sequences. This mode is + typically used on Windows platforms and for network connections. + + ${$B}lf${$N} + The end of a line in the underlying file or device is represented by a + single newline (linefeed) character. In this mode no translations occur + during either input or output. This mode is typically used on UNIX + platforms. + } @form -form {getall} @values -min 1 -max 1 @@ -2859,7 +2956,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::mkdir - @cmd -name "Built-in: tcl::file::mkdir" -help\ + @cmd -name "Built-in: tcl::file::mkdir"\ + -summary\ + {Create one or more directories.}\ + -help\ "Creates each directory specified. For each pathname ${$I}dir${$NI} specified, this command will create all non-existing parent directories as well as ${$I}dir${$NI} itself. If an existing directory is specified, then no action is taken and no @@ -2872,7 +2972,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::mtime - @cmd -name "Built-in: tcl::file::mtime" -help\ + @cmd -name "Built-in: tcl::file::mtime"\ + -summary\ + {Get/set file modification time.}\ + -help\ "Returns a decimal string giving the time at which file ${$I}name${$NI} was last modified. If ${$I}time${$NI} is specified, it is a modification time to set for the file (equivalent to Unix ${$B}touch${$N}). The time is measured in the standard POSIX fashion as seconds @@ -2889,14 +2992,41 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { #pathtype lappend PUNKARGS [list { @id -id ::tcl::file::readable - @cmd -name "Built-in: tcl::file::readable" -help\ + @cmd -name "Built-in: tcl::file::readable"\ + -summary\ + {Test file readable by current user.}\ + -help\ "Returns ${$B}1${$N} if the file ${$I}name${$NI} is readable by the current user, ${$B}0${$N} otherwise." @values -min 1 -max 1 name -optional 0 -type string } "@doc -name Manpage: -url [manpage_tcl file]"] - #readlink + + lappend PUNKARGS [list { + @id -id ::tcl::file::readlink + @cmd -name "Built-in: tcl::file::readlink"\ + -summary\ + {Get target of symbolic link.}\ + -help\ + "Returns the value of the symbolic link given by ${$I}name${$NI} (i.e. the name of the file it points to). + If ${$I}name${$NI} is not a symbolic link or its value cannot be read, then an error is returned. + On systems that do not support symbolic links this option is undefined." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]"] + #rename (2 forms) - #rootname + lappend PUNKARGS [list { + @id -id ::tcl::file::rootname + @cmd -name "Built-in: tcl::file::rootname"\ + -summary\ + {Name without dot and extension}\ + -help\ + "Returns all of the characters in ${$I}name${$NI} up to but not including the last “.” character in + the last component of name. If the last component of ${$I}name${$NI} does not contain a dot, then + returns ${$I}name${$NI}." + @values -min 1 -max 1 + name -optional 0 -type string + } "@doc -name Manpage: -url [manpage_tcl file]"] #separator #size #split @@ -2911,7 +3041,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { lappend PUNKARGS [list { @id -id ::tcl::file::writable - @cmd -name "Built-in: tcl::file::writable" -help\ + @cmd -name "Built-in: tcl::file::writable"\ + -summary\ + {Test file writable by current user.}\ + -help\ "Returns ${$B}1${$N} if the file ${$I}name${$NI} is writable by the current user, ${$B}0${$N} otherwise." @values -min 1 -max 1 name -optional 0 -type string @@ -8645,10 +8778,13 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::compare - @cmd -name "Built-in: tcl::string::compare" -help\ + @cmd -name "Built-in: tcl::string::compare"\ + -summary\ + "Compare lexicographical order of 2 strings."\ + -help\ "Perform a character-by-character comparison of strings string1 and string2. - Returns -1, 0, or 1, dpending on whether string1 is lexicographically - lessthan, equal to, or greater than string2" + Returns -1, 0, or 1, depending on whether string1 is lexicographically + less than, equal to, or greater than string2" -nocase -type none -help\ "If -nocase is specified, then the strings are compared in a case insensitive manner." @@ -8667,7 +8803,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { @cmd -name "Built-in: tcl::string::equal"\ -summary\ - "Compare strings."\ + "Compare strings for equality."\ -help\ "Perform a character-by-character comparison of strings string1 and string2. Returns 1 if string1 and string2 are identical, or 0 when not." @@ -8686,7 +8822,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::first - @cmd -name "Built-in: tcl::string::first" -help\ + @cmd -name "Built-in: tcl::string::first"\ + -summary\ + "Index of first match."\ + -help\ "Search ${$I}haystackString${$NI} for a sequence of characters that exactly match the characters in ${$I}needleString${$NI}. If found, return the index of the first character in the first such match within ${$I}haystackString${$NI}. If there is no match, then return -1. If startIndex is @@ -8709,7 +8848,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::index - @cmd -name "Built-in: tcl::string::index" -help\ + @cmd -name "Built-in: tcl::string::index"\ + -summary\ + "Return character at ${$I}charIndex${$NI}."\ + -help\ "Returns the ${$I}charIndex${$NI}'th character of the ${$I}string${$NI} argument. A ${$I}charIndex${$NI} of 0 corresponds to the first character of the string. ${$I}charIndex${$NI} may be specified as described in the STRING INDICES section." @@ -8720,7 +8862,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::insert - @cmd -name "Built-in: tcl::string::insert" -help\ + @cmd -name "Built-in: tcl::string::insert"\ + -summary\ + "Return copy of string with insertion at ${$I}index${$NI}."\ + -help\ "Returns a copy of string with insertString inserted at the index'th character. If index is start-relative, the first character inserted in the returned string will be at the specified index. @@ -8741,7 +8886,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::last - @cmd -name "Built-in: tcl::string::last" -help\ + @cmd -name "Built-in: tcl::string::last"\ + -summary\ + "Index of last match."\ + -help\ "Search ${$I}haystackString${$NI} for a sequence of characters that exactly match the characters in ${$I}needleString${$NI}. If found, return the index of the first character in the last such match within ${$I}haystackString${$NI}. If there is no match, then return -1. If lastIndex is @@ -8763,7 +8911,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::length - @cmd -name "Built-in: tcl::string::length" -help\ + @cmd -name "Built-in: tcl::string::length"\ + -summary\ + "Number of characters in string."\ + -help\ "Returns a decimal string giving the number of characters in ${$I}string${$NI}. Note that this is not necessarily the same as the number of bytes used to store the string. If the value is a byte array value (such as those returned from reading a binary encoded channel), @@ -8774,7 +8925,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::map - @cmd -name "Built-in: tcl::string::map" -help\ + @cmd -name "Built-in: tcl::string::map"\ + -summary\ + "Replace substrings based on mapping dict."\ + -help\ "Replaces substrings in string based on the key-value pairs in ${$I}mapping${$NI}. ${$I}mapping${$NI} is a list of key value key value ... as in the form returned by ${$B}array get${$N}. Each instance of a key in the string will be replaced with its corresponding value. If ${$B}-nocase${$N} is @@ -8801,7 +8955,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::match - @cmd -name "Built-in: tcl::string::match" -help\ + @cmd -name "Built-in: tcl::string::match"\ + -summary\ + "Test if glob ${$I}pattern${$NI} matches string."\ + -help\ {See if pattern matches string; return 1 if it does, 0 if it does not. If -nocase is specified, then the pattern attempts to match against the string in a case insensitive manner. For the two strings to match, their contents must be identical except that the @@ -8829,7 +8986,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::range - @cmd -name "Built-in: tcl::string::range" -help\ + @cmd -name "Built-in: tcl::string::range"\ + -summary\ + "Get characters from ${$I}first${$NI} to ${$I}last${$NI} index"\ + -help\ "Returns a range of consecutive characters from ${$I}string${$NI}, starting with the character whose index is ${$I}first${$NI} and ending with the character whose index is ${$I}last${$NI} (using the forms described in ${$B}STRING INDICES${$N}). An index of ${$B}0${$N} refers to the first character of the string; an index of @@ -8858,7 +9018,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::replace - @cmd -name "Built-in: tcl::string::replace" -help\ + @cmd -name "Built-in: tcl::string::replace"\ + -summary\ + "Replace characters from ${$I}first${$NI} to ${$I}last${$NI} index"\ + -help\ "Removes a range of consecutive characters from string, starting with the character whose index is first and ending with the character whose index is last (Using the forms described in STRING_INDICES). An index of 0 refers to the first @@ -8878,7 +9041,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::reverse - @cmd -name "Built-in: tcl::string::reverse" -help\ + @cmd -name "Built-in: tcl::string::reverse"\ + -summary\ + "Reverse a string."\ + -help\ "Returns a string that is the same length as ${$I}string${$NI} but with its characters in reverse order." @values -min 1 -max 1 @@ -8887,7 +9053,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::tolower - @cmd -name "Built-in: tcl::string::tolower" -help\ + @cmd -name "Built-in: tcl::string::tolower"\ + -summary\ + "Convert to lowercase."\ + -help\ "Returns a value equal to ${$I}string${$NI} except that all upper (or title) case case letters have been converted to lower case. ${$I}first${$NI} and ${$I}last${$NI} may be specified using the forms described in STRING INDICES." @@ -8903,7 +9072,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::totitle - @cmd -name "Built-in: tcl::string::totitle" -help\ + @cmd -name "Built-in: tcl::string::totitle"\ + -summary\ + "Convert to titlecase"\ + -help\ "Returns a value equal to string except that the first character in string is converted to its Unicode title case variant (or upper case if there is no title case variant) and the rest of the string is converted to lower case. @@ -8921,7 +9093,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::toupper - @cmd -name "Built-in: tcl::string::toupper" -help\ + @cmd -name "Built-in: tcl::string::toupper"\ + -summary\ + "Convert to upper case."\ + -help\ "Returns a value equal to ${$I}string${$NI} except that all lower (or title) case case letters have been converted to upper case. ${$I}first${$NI} and ${$I}last${$NI} may be specified using the forms described in STRING INDICES." @@ -8937,7 +9112,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::trim - @cmd -name "Built-in: tcl::string::trim" -help\ + @cmd -name "Built-in: tcl::string::trim"\ + -summary\ + "Remove leading/trailing whitespace or specified chars."\ + -help\ {Returns a value equal to ${$I}string${$NI} except that any leading or trailing characters present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"} @@ -8947,7 +9125,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::define { @id -id ::tcl::string::trimleft - @cmd -name "Built-in: tcl::string::trimleft" -help\ + @cmd -name "Built-in: tcl::string::trimleft"\ + -summary\ + "Remove leading whitespace or specified chars."\ + -help\ {Returns a value equal to ${$I}string${$NI} except that any leading characters present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"} @@ -8957,7 +9138,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { } "@doc -name Manpage: -url [manpage_tcl string]" punk::args::define { @id -id ::tcl::string::trimright - @cmd -name "Built-in: tcl::string::trimright" -help\ + @cmd -name "Built-in: tcl::string::trimright"\ + -summary\ + "Remove trailing whitespace or specified chars."\ + -help\ {Returns a value equal to ${$I}string${$NI} except that any trailing characters present in the string given by ${$I}chars${$NI} are removed. if ${$I}chars${$NI} is not specified then white space is removed (any character for which ${$N}string is space${$N} returns 1, and "\0"} @@ -8969,7 +9153,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::wordend - @cmd -name "Built-in: tcl::string::wordend" -help\ + @cmd -name "Built-in: tcl::string::wordend"\ + -summary\ + "Get index of char after end of word at charIndex"\ + -help\ "Returns the index of the character just after the last one in the word containing character ${$I}charIndex${$NI} of ${$I}string${$NI}. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) @@ -8985,7 +9172,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define { @id -id ::tcl::string::wordstart - @cmd -name "Built-in: tcl::string::wordstart" -help\ + @cmd -name "Built-in: tcl::string::wordstart"\ + -summary\ + "Get index of first char of word at charIndex."\ + -help\ "Returns the index of the first character in the word containing character ${$I}charIndex${$NI} of ${$I}string${$NI}. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) @@ -9014,7 +9204,10 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { punk::args::define [punk::args::lib::tstr -return string { @id -id ::tcl::string::is - @cmd -name "Built-in: tcl::string::is" -help\ + @cmd -name "Built-in: tcl::string::is"\ + -summary\ + "Test character class of string."\ + -help\ "Returns 1 if string is a valid member of the specified character class, otherwise returns 0. " @leaders -min 1 -max 1 @@ -9836,7 +10029,7 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { CommandPrefix executes in the same context as the code that invoked the traced operation: thus the commandPrefix, if invoked from a procedure, will have access to the same local variables as code in the - procedure. This context may be different thatn the context in which + procedure. This context may be different than the context in which the trace was created. If commandPrefix invokes a procedure (which it normally does) then the procedure will have to use upvar or uplevel commands if it wishes to access the local variables of the code which @@ -10411,6 +10604,161 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- namespace eval argdoc { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + lappend PUNKARGS [list { + @id -id ::unload + @cmd -name "Built-in: unload"\ + -summary\ + {Unload machine code.}\ + -help\ + {This command tries to unload shared libraries previously loaded with ${$B}load${$N} from the + application's address space. + + ${$I}fileName${$NI} is the name of the file containing the library + file to be unloaded; it must be the same as the filename provided to ${$B}load${$N} for loading + the library. + + The ${$I}prefix${$NI} argument is the prefix (as determined by or passed to ${$B}load${$N}), + and is used to compute the name of the unload procedure; if not supplied, it is + computed from fileName in the same manner as ${$B}load${$N}. + + The ${$I}interp${$NI} argument is the path + name of the interpreter from which to unload the package (see the interp manual entry + for details); if interp is omitted, it defaults to the interpreter in which the + unload command was invoked. + + If the initial arguments to ${$B}unload${$N} start with - then they are treated as switches. + + ${$T}UNLOAD OPERATION${$NT} + When a file containing a shared library is loaded through the ${$B}load${$N} command, Tcl + associates two reference counts to the library file. The first counter shows how many + times the library has been loaded into normal (trusted) interpreters while the second + describes how many times the library has been loaded into safe interpreters. As a file + containing a shared library can be loaded only once by Tcl (with the first ${$B}load${$N} call + on the file), these counters track how many interpreters use the library. Each + subsequent call to ${$B}load${$N} after the first simply increments the proper reference count. + + ${$B}unload${$N} works in the opposite direction. As a first step, ${$B}unload${$N} will check whether the + library is unloadable: an unloadable library exports a special unload procedure. The + name of the unload procedure is determined by ${$I}prefix${$NI} and whether or not the target + interpreter is a safe one. For normal interpreters the name of the initialization + procedure will have the form pfx_Unload, where pfx is the same as ${$I}prefix${$NI} except that + the first letter is converted to upper case and all other letters are converted to + lower case. For example, if ${$I}prefix${$NI} is foo or FOo, the initialization procedure's name + will be Foo_Unload. If the target interpreter is a safe interpreter, then the name of + the initialization procedure will be pkg_SafeUnload instead of pkg_Unload. + + If ${$B}unload${$N} determines that a library is not unloadable (or unload functionality has + been disabled during compilation), an error will be returned. If the library is + unloadable, then unload will call the unload procedure. If the unload procedure + returns TCL_OK, unload will proceed and decrease the proper reference count + (depending on the target interpreter type). When both reference counts have reached 0, + the library will be detached from the process. + + ${$T}UNLOAD HOOK PROTOTYPE${$NT} + The unload procedure must match the following prototype: + ${[example { + typedef int ${$B}Tcl_LibraryUnloadProc${$N}( + Tcl_Interp *interp, + int flags); + }]} + The ${$I}interp${$NI} argument identifies the interpreter from which the library is to be unloaded. + The unload procedure must return ${$B}TCL_OK${$N} or ${$B}TCL_ERROR${$N} to indicate whether or not it + completed successfully; in the event of an error it should set the interpreter's result + to point to an error message. In this case, the result of the ${$B}unload${$N} command will be the + result returned by the unload procedure. + + The ${$I}flags${$NI} argument can be either ${$B}TCL_UNLOAD_DETACH_FROM_INTERPRETER${$N} or + ${$B}TCL_UNLOAD_DETACH_FROM_PROCESS${$N}. In case the library will remain attached to the process + after the unload procedure returns (i.e. because the library is used by other + interpreters), ${$B}TCL_UNLOAD_DETACH_FROM_INTERPRETER${$N} will be defined. However, if the library + is used only by the target interpreter and the library will be detached from the + application as soon as the unload procedure returns, the flags argument will be set to + ${$B}TCL_UNLOAD_DETACH_FROM_PROCESS${$N}. + + ${$T}NOTES${$NT} + The ${$B}unload${$N} command cannot unload libraries that are statically linked with the application. + If fileName is an empty string, then the ${$I}prefix${$NI} argument must be specified. + + If ${$I}prefix${$NI} is omitted or specified as an empty string, Tcl tries to guess the prefix. This + may be done differently on different platforms. The default guess, which is used on most + UNIX platforms, is to take the last element of fileName, strip off the first three + characters if they are lib, then strip off the next three characters if they are tcl9, and + use any following wordchars but not digits, converted to titlecase as the prefix. For + example, the command ${$B}unload${$N} libxyz4.2.so uses the prefix Xyz and the command ${$B}unload${$N} + bin/last.so {} uses the prefix Last. + + ${$T}PORTABILITY ISSUES${$NT} + Unix + Not all unix operating systems support library unloading. Under such an operating + system unload returns an error (unless -nocomplain has been specified). + + ${$T}BUGS${$NT} + If the same file is loaded by different fileNames, it will be loaded into the process's + address space multiple times. The behavior of this varies from system to system (some + systems may detect the redundant loads, others may not). In case a library has been + silently detached by the operating system (and as a result Tcl thinks the library is + still loaded), it may be dangerous to use ${$B}unload${$N} on such a library (as the library will be + completely detached from the application while some interpreters will continue to use it). + } + + @form -form {basic prefix prefix_interp} + @leaders -min 0 -max 0 + @opts + -nocomplain -type none -help\ + {Suppresses all error messages. If this switch is given, + unload will never report an error.} + -keeplibrary -type none -help\ + {This switch will prevent unload from issuing the + operating system call that will unload the library + from the process.} + -- -type none -help\ + {Marks the end of switches. The argument following this + one will be treated as a fileName even if it starts + with a -.} + + @values + fileName -type string -help\ + {The name of the file containing the library + file to be unloaded; it must be the same as the filename + provided to ${$B}load${$N} for loading the library.} + + @form -form {prefix prefix_interp} + prefix -type string -help\ + {The prefix (as determined by or passed to ${$B}load${$N}). It is used + to compute the name of the unload procedure; if not supplied, + it is computed from ${$I}fileName${$NI} in the same manner as ${$B}load${$N}.} + + @form -form prefix_interp + interp -type string -help\ + {The path name of the interpreter from which to unload the + package (see the ${$B}interp${$N} manual entry for details); if ${$I}interp${$NI} + is omitted, it defaults to the interpreter in which the ${$B}unload${$N} + command was invoked.} + + } "@doc -name Manpage: -url [manpage_tcl unload]"\ + { + @examples -help { + If an unloadable module in the file ${$B}foobar.dll${$N} had been loaded using the ${$B}load${$N} command like this (on Windows): + ${[example { + load c:/some/dir/foobar.dll + }]} + then it would be unloaded like this: + ${[example { + ${$B}unload${$N} c:/some/dir/foobar.dll + }]} + This allows a C code module to be installed temporarily into a long-running Tcl program and then removed again + (either because it is no longer needed or because it is being updated with a new version) without having to + shut down the overall Tcl process. + } + }\ + { + @seealso -commands {"info sharedlibextension" load safe::*} + } + ] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + lappend PUNKARGS [list { @id -id ::unset @cmd -name "Built-in: unset"\ @@ -10569,7 +10917,32 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { level -type int|stringstartswith(#) -optional 1 -default 1 @values -min 1 -max -1 arg -type string -optional 0 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl uplevel]" ] + } "@doc -name Manpage: -url [manpage_tcl uplevel]"\ + { + @examples -help { + As stated in the description, the ${$B}uplevel${$N} command is useful for creating new control constructs. + This example shows how (without error handling) it can be used to create a ${$B}do${$N} command that is the + counterpart of ${$B}while${$N} except for always performing the test after running the loop body: + ${[example { + proc do {body while condition} { + if {$while ne "while"} { + error "required word missing" + } + set conditionCmd [list expr $condition] + while {1} { + ${$B}uplevel${$N} 1 $body + if {![${$B}uplevel${$N} 1 $conditionCmd]} { + break + } + } + } + }]} + } + }\ + { + @seealso -commands {apply namespace upvar} + } + ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- lappend PUNKARGS [list { @@ -10617,7 +10990,29 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { If an upvar variable is unset (e.g. ${$B}x${$N} in ${$B}add2${$N} above), the ${$B}unset${$N} operation affects the variable it is linked to, not the upvar variable. There is no way to unset an upvar variable except by exiting the procedure in which it is defined. However, it - is possible to retarget an upvar variable by executing another ${$B}upvar${$N} command.} + is possible to retarget an upvar variable by executing another ${$B}upvar${$N} command. + + ${$T}TRACES AND UPVAR${$NT} + Upvar interacts with traces in a straightforward but possibly unexpected manner. If a variable + trace is defined on otherVar, that trace will be triggered by actions involving myVar. However, + the trace procedure will be passed the name of myVar, rather than the name of otherVar. Thus, + the output of the following code will be “localVar” rather than “originalVar”: + ${[example { + proc traceproc { name index op } { + puts $name + } + proc setByUpvar { name value } { + ${$B}upvar${$N} $name localVar + set localVar $value + } + set originalVar 1 + trace add variable originalVar write traceproc + setByUpvar originalVar 2 + }]} + If ${$I}otherVar${$NI} refers to an element of an array, then the element name is passed as the second + argument to the trace procedure. This may be important information in case of traces set on + an entire array. + } @leaders -min 0 -max 1 -takewhenargsmodulo 2 #consider -takewhenargsmodulo 2 ?? incompatible with various mixed @opts/@values configurations #level -type int|stringstartswith(#) -optional 1 -default 1 @@ -10632,7 +11027,22 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { level -type int|stringstartswith(#) -optional 1 -default 1 @values -min 2 -max -1 varmapping -type {string string} -typesynopsis {${$I}otherVar${$NI} ${$I}myVar${$NI}} -optional 0 -multiple 1 - } "@doc -name Manpage: -url [manpage_tcl upvar]" ] + } "@doc -name Manpage: -url [manpage_tcl upvar]"\ + { + @examples -help { + A ${$B}decr${$N} command that works like ${$B}incr${$N} except it subtracts the value from the variable instead of adding it: + ${[example { + proc decr {varName {decrement 1}} { + ${$B}upvar${$N} 1 $varName var + incr var [expr {-$decrement}] + } + }]} + } + }\ + { + @seealso -commands {global namespace uplevel variable} + } + ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -10702,7 +11112,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { #define subcommand documentation first # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { - @dynamic @id -id "::zlib adler32" @cmd -name "Built-in: ::zlib adler32"\ -summary\ @@ -10718,7 +11127,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { - @dynamic @id -id "::zlib crc32" @cmd -name Built-in: ::zlib crc32"\ -summary\ @@ -10734,7 +11142,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { - @dynamic @id -id "::zlib compress" @cmd -name "Built-in: ::zlib compress"\ -summary\ @@ -10749,7 +11156,6 @@ tcl::namespace::eval punk::args::moduledoc::tclcore { } "@doc -name Manpage: -url [punk::args::moduledoc::tclcore::manpage_tcl zlib]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { - @dynamic @id -id "::zlib decompress" @cmd -name "Built-in: ::zlib decompress"\ -summary\ diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index 510fdbe5..626d7d21 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::console 0 999999.0a1.0] #[copyright "2024"] #[titledesc {punk console}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk console}] [comment {-- Description at end of page heading --}] +#[moddesc {punk console}] [comment {-- Description at end of page heading --}] #[require punk::console] #[keywords module console terminal] #[description] @@ -69,7 +69,7 @@ package require punk::args # #zzzload::pkg_require twapi #} -#see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt +#see https://learn.microsoft.com/en-us/windows/console/classic-vs-vt #https://learn.microsoft.com/en-us/windows/console/creating-a-pseudoconsole-session # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -85,7 +85,7 @@ namespace eval punk::console { variable tabwidth 8 ;#default only - will attempt to detect and set to that configured in terminal #Note that windows terminal cooked mode seems to use 8 for interactive use even if set differently - #e.g typing tab characters may still be echoed 8-spaced while writing to stdout my obey the terminal's tab stops. + #e.g typing tab characters may still be echoed 8-spaced while writing to stdout my obey the terminal's tab stops. variable has_twapi 0 variable previous_stty_state_stdin "" variable previous_stty_state_stdout "" @@ -95,7 +95,7 @@ namespace eval punk::console { if {![tsv::exists console is_raw]} { tsv::set console is_raw 0 } - + variable input_chunks_waiting if {![info exists input_chunks_waiting(stdin)]} { set input_chunks_waiting(stdin) [list] @@ -107,21 +107,21 @@ namespace eval punk::console { variable ansi_response_queuedata ;#dict keyed on callid - with function params # -- - variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run. + variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run. #-1 still evaluates to true - as the modern assumption for ansi availability is true - #only false if ansi_available has been set 0 by test_can_ansi + #only false if ansi_available has been set 0 by test_can_ansi #support ansistrip for legacy windows terminals # -- - variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset + variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset #punk::console namespace - contains *directly* acting functions - some based on ansi escapes from the 'ansi' sub namespace, some on local system calls or executable calls wrapped in the 'local' sub namespace - #directly acting means they write to stdout to cause the console to peform the action, or they perform the action immediately via other means. + #directly acting means they write to stdout to cause the console to perform the action, or they perform the action immediately via other means. #punk::console::ansi contains a subset of punk::ansi, but with emission to stdout as opposed to simply returning the ansi sequence. #punk::console::local functions are used by punk::console commands when there is no ansi equivalent - #ansi escape sequences are possibly preferable esp if terminal is remote to process running punk::console + #ansi escape sequences are possibly preferable esp if terminal is remote to process running punk::console # punk::local commands may be more performant in some circumstances where console is directly attached, but it shouldn't be assumed. e.g ansi::titleset outperforms local::titleset on windows with twapi. namespace eval local { @@ -173,7 +173,7 @@ namespace eval punk::console { return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]] } proc disableAnsi {} { - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set oldmode_out [twapi::GetConsoleMode $h_out] set newmode_out [expr {$oldmode_out & ~4}] twapi::SetConsoleMode $h_out $newmode_out @@ -253,7 +253,7 @@ namespace eval punk::console { set result [dict create] if {"output" in $channels} { #as above - configuring stdout does stderr too - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set oldmode [twapi::GetConsoleMode $h_out] set newmode [expr {$oldmode & ~4}] twapi::SetConsoleMode $h_out $newmode @@ -456,7 +456,7 @@ namespace eval punk::console { } exec {*}$sttycmd -raw echo <@$channel tsv::set console is_raw 0 - #do we really want to exec stty yet again to show final 'to' state? + #do we really want to exec stty yet again to show final 'to' state? #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] } else { @@ -505,7 +505,7 @@ namespace eval punk::console { #NOTE - the is_raw is only being set in current interp - but the channel is shared. #this is problematic with the repl thread being separate. - must be a tsv? REVIEW proc enableRaw {{channel stdin}} { - #variable is_raw + #variable is_raw variable previous_stty_state_$channel set sttycmd [auto_execok stty] @@ -535,7 +535,7 @@ namespace eval punk::console { } } - #review - document and decide granularity required. should we enable/disable more than one at once? + #review - document and decide granularity required. should we enable/disable more than one at once? proc enable_mouse {} { puts -nonewline stdout \x1b\[?1000h puts -nonewline stdout \x1b\[?1003h @@ -586,7 +586,7 @@ namespace eval punk::console { punk::console::enableVirtualTerminal both } } elseif {$raw_or_line eq "line"} { - #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) + #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) if {[catch { punk::console::disableRaw } errM]} { @@ -602,7 +602,9 @@ namespace eval punk::console { } namespace eval internal { + proc abort_if_loop {{failmsg ""}} { + #obsolete #puts "il1 [info level 1]" #puts "thisproc: [lindex [info level 0] 0]" set would_loop [uplevel 1 {expr {[string match *loopavoidancetoken* [info body [namespace tail [lindex [info level 0] 0]]]]}}] @@ -642,15 +644,15 @@ namespace eval punk::console { or other readers if done carefully. The mechanism to run while other readers are active involves disabling and re-enabling installed 'chan event' handlers - and possibly using a shared namespace variable + and possibly using a shared namespace variable (::punk::console::input_chunks_waiting) to ensure all data gets to the right handler. (unread data on input prior to this - function being called) + function being called) Not fully documented. (source diving required -see punk::repl) " @opts -ignoreok -type boolean -default 0 -help\ - "Experimental/debug + "Experimental/debug ignore the regex match 'ok' response and keep going." -return -type string -default payload -choices {payload dict} -choicelabels { @@ -702,7 +704,7 @@ namespace eval punk::console { #Main repl reader may be currently active - or may be inactive. #This call could come from within code called by the main reader - or from user code running while main read-loop is temporarily disabled #In other contexts there may not even be another input reader - + #REVIEW - what if there is existing data in input_chunks_waiting - is it for us? #This occurs for example with key held down on autorepeat and is normal #enable it here for debug/testing only @@ -714,7 +716,7 @@ namespace eval punk::console { return "" } # -- --- - #set callid [info cmdcount] ;#info cmdcount is fast, though not as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context + #set callid [info cmdcount] ;#info cmdcount is fast, though not as fast as clock clicks - and whilst not unique in a long-running app(will wrap?) - fine for this context #clock clicks is approx 2x faster - but can sometimes give duplicates if called sequentially e.g list [clock clicks] [clock clicks] #Either is suitable here, where subsequent calls will be relatively far apart in time #speed of call insignificant compared to function @@ -727,13 +729,13 @@ namespace eval punk::console { upvar ::punk::console::ansi_response_queue queue upvar ::punk::console::ansi_response_queuedata queuedata upvar ::punk::console::ansi_response_tslaunch tslaunch - upvar ::punk::console::ansi_response_tsclock tsclock + upvar ::punk::console::ansi_response_tsclock tsclock upvar ::punk::console::ansi_response_timeoutid timeoutid set accumulator($callid) "" set waitvar($callid) "" lappend queue $callid - if {[llength $queue] > 1} { + if {[llength $queue] > 1} { #while {[lindex $queue 0] ne $callid} {} set queuedata($callid) $args set runningid [lindex $queue 0] @@ -743,7 +745,7 @@ namespace eval punk::console { set runningid [lindex $queue 0] if {$runningid ne $callid} { set ::punk::console::ansi_response_wait($runningid) $::punk::console::ansi_response_wait($runningid) - update ;#REVIEW - probably a bad idea + update ;#REVIEW - probably a bad idea after 10 set runningid [lindex $queue 0] ;#jn test } @@ -1081,7 +1083,7 @@ namespace eval punk::console { #e.g puts [punk::console::a red]test[punk::console::a cyan] would produce a cyan coloured test as the commands are evaluated first - #punk::args::set_alias ::punk::console::code_a+ ::punk::ansi::a+ + #punk::args::set_idalias ::punk::console::code_a+ ::punk::ansi::a+ lappend PUNKARGS_aliases {::punk::console::code_a+ ::punk::ansi::a+} proc code_a+ {args} { variable ansi_wanted @@ -1372,7 +1374,7 @@ namespace eval punk::console { #8 UDK #9 NRCS #12 SCS extension - #15 Technical character set + #15 Technical character set #18 Windowing capability #21 Horizontal scrolling #23 Greek extension @@ -2709,10 +2711,10 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::console [namespace eval punk::console { variable version - set version 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index fedfa7af..2d5c6506 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -1279,7 +1279,7 @@ namespace eval punk::fileline { #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. - lassign [dict values [punk::args::get_by_id ::punk::fileline::get_textinfo $args]] opts values + lassign [dict values [punk::args::parse $args withid ::punk::fileline::get_textinfo]] leaders opts values # -- --- --- --- set opt_file [dict get $opts -file] set opt_translation [dict get $opts -translation] @@ -1290,8 +1290,11 @@ namespace eval punk::fileline { if {$opt_file ne ""} { set filename $opt_file set fd [open $filename r] + chan configure $fd -translation binary -encoding $opt_translation;#should use translation binary to get actual line-endings - but we allow caller to override #Always read encoding in binary - check for bom below and/or apply chosen opt_encoding + + set rawchunk [read $fd] close $fd if {[llength $values]} { @@ -1359,12 +1362,12 @@ namespace eval punk::fileline { set startdata 3 } elseif {$maybe_bom eq "fbee28"} { set bomid bocu-1 - puts stderr "WARNING - bocu-1 BOM FBEE28 found. Not supported - back to binary" + puts stderr "WARNING - bocu-1 BOM FBEE28 found. Not supported - Falling back to binary" set bomenc "binary" ;# utf-8??? set startdata 3 } elseif {$maybe_bom eq "84319533"} { if {![dict exists [punk::char::page_names_dict gb18030] gb18030]} { - puts stderr "WARNING - no direct support for GB18030 (chinese) - falling back to cp936/gbk" + puts stderr "WARNING - no direct support for GB18030 (chinese) - Falling back to cp936/gbk" set bomenc cp936 } else { set bomenc [dict get [punk::char::page_names_dict gb18030]] ;#review - this may never exist in Tcl or may be named differently - create a handler? diff --git a/src/modules/punk/fileline-buildversion.txt b/src/modules/punk/fileline-buildversion.txt index f47d01c8..781c895b 100644 --- a/src/modules/punk/fileline-buildversion.txt +++ b/src/modules/punk/fileline-buildversion.txt @@ -1,3 +1,3 @@ -0.1.0 +0.1.1 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index be3ed06a..9ef4128f 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -69,6 +69,16 @@ package require punk::args tcl::namespace::eval punk::lib::ensemble { #wiki.tcl-lang.org/page/ensemble+extend # extend an ensemble-like routine with the routines in some namespace + + #NOTE - the extension ns becomes the '-namespace ' for the original routine name, + #with -unknown handling the original subcommands. + #This makes the original ensemble harder to introspect! + #e.g (the original -map or -namespace not visible) + #In this specific case (which, being published on the wiki might be common in the wild) + #we could call {*}[namespace ensemble configure $routine -unknown] $routine + #and then detect that the first resulting word is an ensemble + #For arbitrary '-unknown scripts' - sensible introspection is likely not possible + proc extend {routine extension} { if {![string match ::* $routine]} { set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] @@ -119,6 +129,17 @@ tcl::namespace::eval punk::lib::ensemble { # some (?) tcl bug check procs needed to exist before main punk::lib namespaces are evaluated tcl::namespace::eval punk::lib::check { + #These are just a selection of bugs relevant to punk behaviour (or of specific interest to the author) + #Not any sort of comprehensive check of known tcl bugs. + #These are reported in warning output of 'help tcl' - or used for workarounds in some cases. + proc has_tclbug_regexp_emptystring {} { + #The regexp {} [...] trick - code in brackets only runs when non byte-compiled ie in traces + #This was usable as a hack to create low-impact calls that only ran in an execution trace context - handy for debugger logic, + #but as an apparent violation of Tcl's normal parsing rules - was evidently seen as a bug and fixed in: + #https://core.tcl-lang.org/tcl/info/cb03e57a (tcl 9.0.3+ ?) + set bug [expr {![catch {regexp {} [error should_error]}]}] + return [dict create bug $bug bugref cb03e57a description {regexp emptystring first argument over-optimised - difference in compiled vs traced behaviour.} level minor] + } proc has_tclbug_script_var {} { set script {set j [list spud] ; list} @@ -134,30 +155,38 @@ tcl::namespace::eval punk::lib::check { #we assume it should have no string rep in either case #Review: check Tcl versions for behaviour/consistency if {!$nostring2} { - return true + set bug true } else { - return false + set bug false } + set description "string rep for list variable in script generated when script changed\n(not an acknowledged/reported bug)" + return [dict create bug $bug bugref "" description $description level minor] } proc has_tclbug_lsearch_strideallinline {} { #bug only occurs with single -index value combined with -stride -all -inline -subindices #https://core.tcl-lang.org/tcl/tktview/5a1aaa201d if {[catch {lsearch -stride 3 -all -inline -index 1 -subindices {a1 a2 a3} *} result]} { #we aren't looking for an error result - error most likely indicates tcl too old to support -stride - return 0 + set bug 0 + } else { + set bug [expr {$result ne "a2"}] } - return [expr {$result ne "a2"}] + set description "lsearch -stride with -subindices -inline -all and single index - incorrect results." + return [dict create bug $bug bugref 5a1aaa201d description $description level major] } proc has_tclbug_list_quoting_emptyjoin {} { #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" - return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + set bug [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + set description "lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" + return [dict create bug $bug bugref e38dc74e2 description $description level medium] } proc has_tclbug_safeinterp_compile {{show 0}} { #ensemble calls within safe interp not compiled + #https://core.tcl-lang.org/tcl/tktview/1095bf7f756f9aed6bde namespace eval [namespace current]::testcompile { proc ensembletest {} {string index a 0} } @@ -199,7 +228,8 @@ tcl::namespace::eval punk::lib::check { if {[string last "invokeStk" $bytecode_outer] >= 1} { incr has_bug } - return $has_bug + set description "ensemble commands not compiled in safe interps - heavy performance impact in safe interps" + return [dict create bug $has_bug bugref 1095bf7f756f9aed6bde description $description level major] } } @@ -301,7 +331,7 @@ tcl::namespace::eval punk::lib::compat { if {"::lpop" ne [info commands ::lpop]} { #puts stderr "Warning - no built-in lpop" interp alias {} lpop {} ::punk::lib::compat::lpop - punk::args::set_alias ::punk::lib::compat::lpop ::lpop ;#point to the definition of ::lpop defined in punk::args::tclcore + punk::args::set_idalias ::punk::lib::compat::lpop ::lpop ;#point to the definition of ::lpop defined in punk::args::tclcore } proc lpop {lvar args} { #*** !doctools @@ -342,19 +372,19 @@ tcl::namespace::eval punk::lib::compat { } if {"::ledit" ni [info commands ::ledit]} { interp alias {} ledit {} ::punk::lib::compat::ledit - punk::args::set_alias ::punk::lib::compat::ledit ::ledit + punk::args::set_idalias ::punk::lib::compat::ledit ::ledit } proc ledit {lvar first last args} { upvar $lvar l #use lindex_resolve to support for example: ledit lst end+1 end+1 h i set fidx [punk::lib::lindex_resolve [llength $l] $first] switch -exact -- $fidx { - -3 { + -Inf { #index below lower bound set pre [list] set fidx -1 } - -2 { + Inf { #first index position is greater than index of last element in the list set pre [lrange $l 0 end] set fidx [llength $l] @@ -366,11 +396,11 @@ tcl::namespace::eval punk::lib::compat { } set lidx [punk::lib::lindex_resolve [llength $l] $last] switch -exact -- $lidx { - -3 { + -Inf { #index below lower bound set post [lrange $l 0 end] } - -2 { + Inf { #index above upper bound set post [list] } @@ -396,8 +426,8 @@ tcl::namespace::eval punk::lib::compat { foreach v $varnames { lappend values "\$$v" } - set linkvars [uplevel 1 [list info vars]] - set nscaller [uplevel 1 [list namespace current]] + set linkvars [uplevel 1 [list ::tcl::info::vars]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] set apply_script "" foreach vname $linkvars { @@ -499,6 +529,15 @@ namespace eval punk::lib { set has_twapi [expr {![catch {package require twapi}]}] } + namespace eval argdoc { + #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] + } # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == @@ -673,31 +712,31 @@ namespace eval punk::lib { upvar $lvar l set len [llength $l] if {[lindex_resolve_basic $len $a] < 0 || [lindex_resolve_basic $len $z] < 0} { - #lindex_resolve_basic returns only -1 if out of range + #lindex_resolve_basic returns only -Inf if out of range at either bound #if we didn't do this check - we could raise an error on second lset below - leaving list corrupted because only one lset occurred #(e.g using: lswap mylist end-2 end on a two element list) #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report - #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) + #use full 'lindex_resolve' which can report which side via -Inf and Inf special results being lower and upper bound breaches respectively set a_index [lindex_resolve $len $a] set a_msg "" switch -- $a_index { - -2 { - set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" - } - -3 { + -Inf { set a_msg "1st supplied index $a is below the lower bound for the list (0)" } + Inf { + set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" + } } set z_index [lindex_resolve $len $z] set z_msg "" switch -- $z_index { - -2 { - set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" - } - -3 { + -Inf { set z_msg "2nd supplied index $z is below the lower bound for the list (0)" } + Inf { + set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" + } } set errmsg "lswap cannot swap indices $a and $z" if {$a_msg ne ""} { @@ -981,7 +1020,7 @@ namespace eval punk::lib { return $zip_l } #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible - if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { + if {![package vsatisfies [package present Tcl] 9.0-] || [dict get [punk::lib::check::has_tclbug_lsearch_strideallinline] bug]} { #-stride either not available - or has bug preventing use of main algorithm below proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] } else { @@ -991,6 +1030,240 @@ namespace eval punk::lib { namespace import ::punk::args::lib::tstr + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::tclscript_to_scriptlist + @cmd -name punk::lib::tclscript_to_scriptlist\ + -summary\ + "Parse tcl script to toplevel list of lists."\ + -help\ + "Get topmost list of tcl language elements in script. + produces a list of lists where each sublist is a commandlist or + a comment string." + @values -min 1 -max 1 + script -type string + }] + } + proc tclscript_to_scriptlist {script} { + set scriptlist [list] + set cmdlist [list] + set scrlen [string length $script] + set token "" + set in_token 0 + set in_cmdlist 0 + set in_comment 0 + set charmap [list \t TB \n LF \r CR \\ BSL] ;#for switch 'jump' preservation - review - may be slower than escapes in switch statement? + for {set i 0} {$i < $scrlen} {incr i} { + set ch [string index $script $i] + set chswitch [string map $charmap $ch] + if {!$in_token} { + switch -- $chswitch { + { } - TB { + #ignore - continue being a non token + } + CR { + if {[string index $script $i+1] eq "\n"} { + if {$in_cmdlist} { + #no active token - newline ends cmdlist + set in_cmdlist 0 + lappend scriptlist $cmdlist + set cmdlist [list] + } + incr i + } + } + LF - ";" { + #no active token - newline or semicolon ends cmdlist + if {$in_cmdlist} { + set in_cmdlist 0 + lappend scriptlist $cmdlist + set cmdlist [list] + } + } + BSL { + if {[string index $script $i+1] eq "\n"} { + #continuation of whitespace while no token - boring + incr i + } elseif {[string range $script $i+1 $i+2] eq "\r\n"} { + #continuation of whitespace while no token - boring + incr i 2 + } else { + #an uncommon possibility, a command wth surrounding spaces called in an strange way + # e.g \ cmdname\ arg + set in_token 1 + set token "\\[string index $script $i+1]" + incr i + if {!$in_cmdlist} { + set in_cmdlist 1 + } + } + } + # { + if {$in_cmdlist} { + #ordinary data + set in_token 1 + set token # + } else { + if {!$in_comment} { + set in_token 1 + set in_comment 1 + set token # + } else { + #wnen in comment - all will be a single token until comment ends + append token # + } + } + } + default { + #for completeness.. we should exclude other possible whitespace chars + if {![string is space $ch]} { + set in_token 1 + set token $ch + if {!$in_cmdlist} { + set in_cmdlist 1 + } + } + } + } + } else { + #if we're in a token, we must be in a cmdlist or a comment (single token) + #review - not preserving whitespace in list of commands is ok, but for comments it should ideally be preserved + #note that unbalanced curly in *toplevel* comment will still 'info complete' to true + switch -- $chswitch { + LF { + if {!$in_comment} { + if {[tcl::info::complete $token]} { + #ends token and cmdlist + lappend cmdlist $token + lappend scriptlist $cmdlist + set cmdlist "" + set in_cmdlist 0 + set token "" + set in_token 0 + } else { + append token \n + } + } else { + #ends a comment + lappend scriptlist $token ;#single token for comment + set token "" + set in_token 0 + set in_comment 0 + set in_cmdlist 0 ;#shouldn't be necessary, but included for clarity + } + } + ";" { + if {!$in_comment} { + if {[tcl::info::complete $token]} { + #ends token and cmdlist + lappend cmdlist $token + lappend scriptlist $cmdlist + set cmdlist "" + set in_cmdlist 0 + set token "" + set in_token 0 + } else { + append token \n + } + } else { + #ordinary char for comment + append token ";" + } + } + CR { + if {[string index $script $i+1] eq "\n"} { + if {[tcl::info::complete $token]} { + #ends token and commandlist + lappend cmdlist $token + lappend scriptlist $cmdlist + set cmdlist "" + set in_cmdlist 0 + set token "" + set in_token 0 + } else { + append token \r\n + incr i + } + } else { + append token \r + } + } + BSL { + if {[string index $script $i+1] eq "\n"} { + #continuation - lf effectively becomes a space + if {!$in_comment} { + #token may end - but cmdlist goes on + if {[tcl::info::complete $token]} { + lappend cmdlist $token + set token "" + set in_token 0 + } else { + append token " " + } + } else { + append token " " + } + incr i ;#skip LF + } elseif {[string range $script $i+1 $i+2] eq "\r\n"} { + #continuation - cr-lf effectively becomes a space + if {!$in_comment} { + #token may end - but cmdlist goes on + if {[tcl::info::complete $token]} { + lappend cmdlist $token + set token "" + set in_token 0 + } else { + append token " " + } + } else { + append token " " + } + incr i 2 ;#skip CRLF + } else { + append token "\\[string index $script $i+1]" + incr i + } + } + default { + if {![string is space $ch]} { + append token $ch + } else { + if {!$in_comment} { + if {[tcl::info::complete $token]} { + lappend cmdlist $token + set token "" + set in_token 0 + } else { + append token $ch + } + } else { + append token $ch + } + } + } + } + } + } + #eof + if {!$in_comment} { + if {$in_token} { + if {[tcl::info::complete $token]} { + lappend cmdlist $token + lappend scriptlist $cmdlist + } else { + error "Eof reached whilst script incomplete. Unbalanced braces?\ntoken: '$token'" + } + } else { + if {$in_cmdlist} { + lappend scriptlist $cmdlist + } + } + } else { + lappend scriptlist $token + } + return $scriptlist + } proc invoke command { @@ -1064,6 +1337,7 @@ namespace eval punk::lib { Segments are classified into list,dict and string operations. Leading % indicates a string operation - e.g %# gives string length A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 + (todo - change to indexset syntax @1..3 @1..end-1 etc) A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. e.g1 pdict env */%# @@ -1087,9 +1361,9 @@ namespace eval punk::lib { set opts [dict get $argd opts] set dvar [dict get $argd values dictvar] set patterns [dict get $argd values patterns] - set isarray [uplevel 1 [list array exists $dvar]] + set isarray [uplevel 1 [list ::tcl::array::exists $dvar]] if {$isarray} { - set dvalue [uplevel 1 [list array get $dvar]] + set dvalue [uplevel 1 [list ::tcl::array::get $dvar]] if {![dict exists $opts -keytemplates]} { set arrdisplay [string map [list %dvar% $dvar] {${[if {[lindex $key 1] eq "query"} {val "%dvar% [lindex $key 0]"} {val "%dvar%($key)"}]}}] dict set opts -keytemplates [list $arrdisplay] @@ -1231,6 +1505,9 @@ namespace eval punk::lib { if {$opt_roottype in {dict list string}} { #puts "getting keys for roottype:$opt_roottype" if {[llength $dval]} { + + #TODO - change to indexset notation 0..1,3..end-1 etc + set re_numdashnum {^([-+]{0,1}\d+)-([-+]{0,1}\d+)$} set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} foreach pattern_nest $patterns { @@ -1445,30 +1722,33 @@ namespace eval punk::lib { if {![regexp $re_idxdashidx $p _match a b]} { error "unrecognised pattern $p" } - set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-2 for too low, -1 for too high + #TODO - fix terminology. 'lower_resolve' is confusing here as range can be in descending order + #change to start/end terminology? + + set lower_resolve [punk::lib::lindex_resolve [llength $dval] $a] ;#-Inf for too low, Inf for too high #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds - if {${lower_resolve} == -2} { + if {${lower_resolve} == Inf} { ##x #lower bound is above upper list range #match with decreasing indices is still possible set lower [expr {[llength $dval]-1}] ;#set to max - } elseif {$lower_resolve == -3} { + } elseif {$lower_resolve == -Inf} { ##x set lower 0 } else { set lower $lower_resolve } set upper [punk::lib::lindex_resolve [llength $dval] $b] - if {$upper == -3} { + if {$upper == -Inf} { ##x #upper bound is below list range - - if {$lower_resolve >=-2} { + if {$lower_resolve > -Inf} { ##x set upper 0 } else { continue } - } elseif {$upper == -2} { + } elseif {$upper == Inf} { #use max set upper [expr {[llength $dval]-1}] #assert - upper >=0 because we have ruled out empty lists @@ -2181,17 +2461,22 @@ namespace eval punk::lib { "Validate that a string is an 'indexset' An indexset consists of a comma delimited list of indexes or index-ranges. - The indexes are 0-based. + No particular base is assumed for the purposes of validating an indexset here. + While in Tcl, lists are zero-based - an indexset can be applied to lists of any base. + e.g -10..-1 is an indexset that just won't resolve any results for a list with a base >= 0. + To validate if an indexset is strictly within range, both the length of the data and the base would + need to be considered. + The normal 'range' specifier is .. The range specifier can appear at the beginning, middle or end, or even alone to indicate the entire range of valid values. e.g the following are all valid ranges 1.. - (index 1 to max) + (index 1 to 'max') ..10 - (index 0 to 10) + (index 'base' to 10) 2..11 - (index 2o to 11) + (index 2 to 11) .. (all indices) Common whitespace elements space,tab,newlines are ignored. @@ -2199,7 +2484,7 @@ namespace eval punk::lib { e.g end-2 or 2+2. see indexset_resolve" - @values -min 2 -max 2 + @values -min 1 -max 1 indexset -type string } proc is_indexset {indexset} { @@ -2252,29 +2537,69 @@ namespace eval punk::lib { e.g in a basic case: for a list of 10 items, 'indexset_resolve 10 end' will return the index 9 An indexset consists of a comma delimited list of indexes or index-ranges. - The indexes are 0-based. - Ranges must be specified with .. as the separator. + Ranges must be specified with .. as the separator, with an empty value at either side of the + separator representing beginning and end of the index range respectively. + + The indexes are 0-based by default, but the base can be specified. + indexset_resolve 7 .. + -> 0 1 2 3 4 5 6 + indexset_resolve 7 .. -3 + -> -3 -2 -1 0 1 2 3 + Whitespace is ignored. Each index (or endpoint of an index-range) can be of the forms accepted by Tcl list or string commands, e.g end-2 or 2+2. end means the last item. end-1 means the second last item. - 0.. is the same as 0..end. + 0.. is the same as 0..end + indexset examples: + + These assume the default 0-based indices (base == 0) + 1,3.. output the index 1 (2nd item) followed by all from index 3 to the end. - 'indexset_resolve 4 1,3..' -> 1 3 - 'indexset_resolve 10 1,3..' -> 1 3 4 5 6 7 8 9 - 0-2,end + indexset_resolve 4 1,3.. + -> 1 3 + indexset_resolve 10 1,3.. + -> 1 3 4 5 6 7 8 9 + 0..2,end output the first 3 indices, and the last index. end-1..0 output the indexes in reverse order from 2nd last item to first item." - @values -min 2 -max 2 + @values -min 2 -max 3 numitems -type integer indexset -type indexset -help "comma delimited specification for indices to return" - } - proc indexset_resolve {numitems indexset} { + base -type integer -default 0 -help\ + "This is the starting index. It can be positive, negative or zero. + This affects the start and end calculations, limiting what indices will be + returned. + e.g with base 1 'end' will give a different value from base 0 + + for 10 items 'end' is 10 when 1-based + for 10 items 'end' is 9 when 0-based + + For base 1, index 0 is considered to be below the range. + ie + indexset_resolve 10 0..3 1 + -> 1 2 3 + indexset_resolve 10 0..3 0 + -> 0 1 2 3 + + It does not *convert* integers within the range. + + indexset_resolve 10 5 1 + -> 5 + indexset_resolve 10 5 0 + -> 5 + + ie if you ask for a 1 based indexset the integers that are within the + range will come out the same, so the result needs to be treated as a + 1-based set of indices when performing further operations. + " + } + proc indexset_resolve {numitems indexset {base 0}} { if {![string is integer -strict $numitems] || ![is_indexset $indexset]} { #use parser on unhappy path only set errmsg [punk::args::usage -scheme error ::punk::lib::indexset_resolve] @@ -2283,7 +2608,8 @@ namespace eval punk::lib { set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] ;#collapse basic whitespace set index_list [list] ;#list of actual indexes within the range set iparts [split $indexset ,] - set index_list [list] + set based_max [expr {$numitems -1 + $base}] + foreach ipart $iparts { set ipart [string trim $ipart] set rposn [string first .. $ipart] @@ -2292,76 +2618,83 @@ namespace eval punk::lib { lassign [punk::lib::string_splitbefore_indices $ipart $rposn $rposn+2] rawa _ rawb set rawa [string trim $rawa] set rawb [string trim $rawb] - if {$rawa eq ""} {set rawa 0} - set a [punk::lib::lindex_resolve $numitems $rawa] - if {$a == -3} { + if {$rawa eq ""} {set rawa $base} + set a [punk::lib::lindex_resolve $numitems $rawa $base] + if {$a == -Inf} { + #(was -3) #undershot - leave negative - } elseif {$a == -2 && $rawa ne "-2"} { + } elseif {$a == Inf} { #overshot - set a [expr {$numitems}] ;#put it outside the range on the upper side + set a [expr {$based_max + 1}] ;#put it outside the range on the upper side } + #review - a may be -Inf if {$rawb eq ""} { - if {$a > $numitems-1} { + if {$a > $based_max} { set rawb $a ;#make sure .. doesn't return last item - should return nothing } else { set rawb end } } - set b [punk::lib::lindex_resolve $numitems $rawb] - if {$b == -3} { + set b [punk::lib::lindex_resolve $numitems $rawb $base] + if {$b == -Inf} { #undershot - leave negative - } elseif {$b == -2 && $rawb ne "-2"} { - set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side + } elseif {$b == Inf} { + #set b [expr {$numitems}] ;#overshot - put it outside the range on the upper side + set b [expr {$based_max + 1}] ;#overshot - put it outside the range on the upper side } + #JJJ + #e.g make sure .. doesn't return last item - should return nothing as both are above the range. - if {$a >= 0 && $a <= $numitems-1 && $b >=0 && $b <= $numitems-1} { + if {$a >= $base && $a <= $based_max && $b >=$base && $b <= $based_max} { lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { - if {$a >= 0 && $a <= $numitems-1} { + if {$a >= $base && $a <= $based_max} { #only a is in the range - if {$b < 0} { - set b 0 + if {$b < $base} { + set b $base } else { - set b [expr {$numitems-1}] + set b $based_max } lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. - } elseif {$b >=0 && $b <= $numitems-1} { + } elseif {$b >=$base && $b <= $based_max} { #only b is in the range - if {$a < 0} { - set a 0 + if {$a < $base} { + set a $base } else { - set a [expr {$numitems-1}] + set a $based_max } lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. } else { #both outside the range - if {$a < 0 && $b > 0} { + if {$a < $base && $b > $base} { #spans the range in forward order - set a 0 - set b [expr {$numitems-1}] + set a $base + set b $based_max lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. - } elseif {$a > 0 && $b < 0} { + } elseif {$a > $base && $b < $base} { #spans the range in reverse order - set a [expr {$numitems-1}] - set b 0 + set a $based_max + set b $base lappend index_list {*}[punk::lib::range $a $b] ;#required for tcl8.6, on tcl9 this will call lseq internally. } #both outside of range on same side } } } else { - set idx [punk::lib::lindex_resolve_basic $numitems $ipart] - if {$idx >= 0} { + set idx [punk::lib::lindex_resolve_basic $numitems $ipart $base] + #returns only -Inf for out of range at either end + if {$idx >= $base} { + #index within the range lappend index_list $idx } } } return $index_list } - # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bounds on upper vs lower side - #REVIEW: This shouldn't really need the list itself - just the length would suffice + # showdict uses lindex_resolve results -Inf & Inf to determine whether index is out of bounds on lower vs upper side + #This doesn't need the list itself - just the length suffices. punk::args::define { @id -id ::punk::lib::lindex_resolve @cmd -name punk::lib::lindex_resolve\ @@ -2379,9 +2712,9 @@ namespace eval punk::lib { We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. lindex_resolve will parse the index expression and return: - a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) - b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) - lindex_resolve never returns -1 - as the similar function lindex_resolve_basic uses this to denote + a) -Inf if the supplied index expression is below the lower bound for the supplied list. (< 0) + b) Inf if the supplied index expression is above the upper bound for the supplied list. (> end) + The similar function lindex_resolve_basic uses -Inf to denote out of range at either end of the list/string. Otherwise it will return an integer corresponding to the position in the data. This is in stark contrast to Tcl list/string function indices which will return empty strings for out of @@ -2397,7 +2730,7 @@ namespace eval punk::lib { datalength -type integer index -type indexexpression } - proc lindex_resolve {len index} { + proc lindex_resolve {len index {base 0}} { #*** !doctools #[call [fun lindex_resolve] [arg len] [arg index]] #[para]Resolve an index which may be of the forms accepted by Tcl list commands such as end-2 or 2+2 to the actual integer index for the supplied list/string length @@ -2406,8 +2739,8 @@ namespace eval punk::lib { #[para]Sometimes the actual integer index is desired. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]lindex_resolve will parse the index expression and return: - #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) - #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end) + #[para] a) -Inf if the supplied index expression is below the lower bound for the supplied list. (< 0) + #[para] b) Inf if the supplied index expression is above the upper bound for the supplied list. (> end) #[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list/string #[para]Otherwise it will return an integer corresponding to the position in the list. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out of bounds indices, or in the case of lrange, return results anyway. @@ -2427,16 +2760,17 @@ namespace eval punk::lib { } if {![string is integer -strict $len] || $len < 0} { - error "lindex_resolve len must be a positive integer" + error "lindex_resolve len must be a positive integer." } - + set based_max [expr {$len -1 + $base}] if {[string is integer -strict $index]} { + #review - base? #can match +i -i - if {$index < 0} { - return -3 - } elseif {$index >= $len} { - return -2 + if {$index < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf } else { #integer may still have + sign - normalize with expr return [expr {$index}] @@ -2453,19 +2787,22 @@ namespace eval punk::lib { if {$offset == 0} { #(offset +0, -0 or 0 or 000 0_0 etc) #op either + or - is irrelevant - set index [expr {$len-1}] - if {$index < 0} { - return -2 ;#special case - equivalent to 'end', with empty list - treat like a positive number out of bounds + #set index [expr {$len-1}] ;#+ base ? + set index $based_max + if {$index < $base} { + #return -2 ;#special case - equivalent to 'end', with empty list - treat like a positive number out of bounds + return Inf } else { return $index } } - set index [if {$op eq "+"} {expr {($len-1) + $offset}} else {expr {($len-1) - $offset}}] - if {$index < 0} { - return -3 - } elseif {$index > $len-1} { - return -2 + #set index [if {$op eq "+"} {expr {($len-1) + $offset}} else {expr {($len-1) - $offset}}] + set index [if {$op eq "+"} {expr {$based_max + $offset}} else {expr {$based_max - $offset}}] + if {$index < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf } else { return $index } @@ -2473,9 +2810,10 @@ namespace eval punk::lib { #index is 'end' if {$len == 0} { #special case - 'end' with empty list - treat end like a positive number out of bounds - return -2 + return Inf } - return [expr {$len - 1}] + #return [expr {$len - 1 + $base}] + return $based_max } } else { #plain +- already handled above. @@ -2494,37 +2832,45 @@ namespace eval punk::lib { } else { error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" } - if {$index < 0} { - return -3 - } elseif {$index >= $len} { - return -2 + if {$index < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf } return $index } } } - proc lindex_resolve_basic {len index} { + proc lindex_resolve_basic {len index {base 0}} { #*** !doctools #[call [fun lindex_resolve_basic] [arg len] [arg index]] #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) - #[para] returns -1 for out of range at either end, or a valid integer index + #[para] returns -Inf for out of range at either end, or a valid integer index #[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound #[para] This is only likely to be faster than average over lindex_resolve for small lists and for Tcl which has the builtin lseq command #[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1 #[para] For pure integer indices the performance should be equivalent - if {![string is integer -strict $len]} { - error "lindex_resolve_basic len must be an integer" + if {![string is integer -strict $len] || $len < 0} { + error "lindex_resolve_basic len must be an integer greater than or equal to zero" } + if {![string is integer -strict $base]} { + #base can be negative + error "lindex_resolve_basic base must be an integer" + } + set based_max [expr {$len -1 + $base}] set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { #can match +i -i #avoid even the lseq overhead when the index is simple - if {$index < 0 || ($index >= $len)} { - #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. - return -1 + if {$index < $base || ($index > $based_max)} { + #even though in this case we could return -Inf or Inf like lindex_resolve; + #for consistency we don't return Inf for upper-boudn violation, + #as which bound is violated is not always directly determinable for compound index expressions (such as end-x) using the lseq+lindex mechanism. + return -Inf } else { + #!NOTE! index within range is unchanged - no matter the base #integer may still have + sign - normalize with expr return [expr {$index}] } @@ -2532,7 +2878,7 @@ namespace eval punk::lib { if {$len > 0} { #For large len - this is a wasteful allocation if no true lseq available in Tcl version. #lseq produces an 'arithseries' object which we can index into without allocating an entire list (REVIEW) - set testlist [punk::lib::range 0 [expr {$len-1}]] ;# uses lseq if available, has fallback. + set testlist [punk::lib::range $base $based_max] ;# uses lseq if available, has fallback of creating a potentially large list of numbers. } else { set testlist [list] #we want to call 'lindex' even in this case - to get the appropriate error message @@ -2540,7 +2886,7 @@ namespace eval punk::lib { set idx [lindex $testlist $index] if {$idx eq ""} { #we have no way to determine if out of bounds is at lower vs upper end - return -1 + return -Inf } else { return $idx } @@ -2560,12 +2906,12 @@ namespace eval punk::lib { if {![string is integer -strict $index]} { set index [punk::lib::lindex_resolve [string length $str] $index] switch -- $index { - -2 { - return [list $str ""] - } - -3 { + -Inf { return [list "" $str] } + Inf { + return [list $str ""] + } } } return [list [string range $str 0 $index-1] [string range $str $index end]] @@ -2580,20 +2926,20 @@ namespace eval punk::lib { if {![string is integer -strict $index]} { set index [punk::lib::lindex_resolve [string length $str] $index] switch -- $index { - -2 { - if {[lindex $sizes end] != 0} { - ledit parts end end [lindex $parts end] {} - ledit sizes end end [lindex $sizes end] 0 - } - continue - } - -3 { + -Inf { if {[lindex $sizes 0] != 0} { ledit parts 0 0 {} [lindex $parts 0] ledit sizes 0 0 0 [lindex $sizes 0] } continue } + Inf { + if {[lindex $sizes end] != 0} { + ledit parts end end [lindex $parts end] {} + ledit sizes end end [lindex $sizes end] 0 + } + continue + } } } if {$index <= 0} { @@ -4038,14 +4384,15 @@ namespace eval punk::lib { set result "" set in_jt 0 foreach ln [split $data \n] { - set tln [string trim $ln] + set tln [::tcl::string::trim $ln] if {!$in_jt} { - if {[string match *jumpTable* $ln]} { + if {[::tcl::string::match *jumpTable* $ln]} { + punk::ns::call_frame append result $ln \n set in_jt 1 } } else { - if {[string match Command* $tln] || [string match "(*) *" $tln]} { + if {[::tcl::string::match Command* $tln] || [::tcl::string::match "(*) *" $tln]} { set in_jt 0 } else { append result $ln \n @@ -4055,6 +4402,13 @@ namespace eval punk::lib { return $result } + #a test + # punk::ns::cmdtracereturn punk::lib::disassemble ::punk::ns::test_switch4 + # Note the different disassemble result when trace is running. + proc disassemble {procname} { + tcl::unsupported::disassemble proc $procname + } + proc temperature_f_to_c {deg_fahrenheit} { return [expr {($deg_fahrenheit -32) * (5/9.0)}] } @@ -4201,6 +4555,17 @@ namespace eval punk::lib { } } + #review - there are various type of uuid - we should use something consistent across platforms + #twapi is used on windows because it's about 5 times faster - but is this more important than consistency? + #twapi is much slower to load in the first place (e.g 75ms vs 6ms if package names already loaded) - so for oneshots tcllib uuid is better anyway + #(counterpoint: in the case of punk - we currently need twapi anyway on windows) + #does tcllib's uuid use the same mechanisms on different platforms anyway? + if {$has_twapi} { + interp alias "" ::punk::lib::uuid "" twapi::new_uuid + } else { + catch {package require uuid} + interp alias "" ::punk::lib::uuid "" uuid::uuid generate + } #*** !doctools diff --git a/src/modules/punk/lib-buildversion.txt b/src/modules/punk/lib-buildversion.txt index 71fa630d..7e019aff 100644 --- a/src/modules/punk/lib-buildversion.txt +++ b/src/modules/punk/lib-buildversion.txt @@ -1,3 +1,3 @@ -0.1.3 +0.1.4 #First line must be a semantic version number #all other lines are ignored. diff --git a/src/modules/punk/libunknown-0.1.tm b/src/modules/punk/libunknown-0.1.tm index e0532e41..fea6b146 100644 --- a/src/modules/punk/libunknown-0.1.tm +++ b/src/modules/punk/libunknown-0.1.tm @@ -1585,12 +1585,12 @@ namespace eval punk::libunknown { #use lindex_resolve to support for example: ledit lst end+1 end+1 h i set fidx [lindex_resolve [llength $l] $first] switch -exact -- $fidx { - -3 { + -Inf { #index below lower bound set pre [list] set fidx -1 } - -2 { + Inf { #first index position is greater than index of last element in the list set pre [lrange $l 0 end] set fidx [llength $l] @@ -1601,11 +1601,11 @@ namespace eval punk::libunknown { } set lidx [lindex_resolve [llength $l] $last] switch -exact -- $lidx { - -3 { + -Inf { #index below lower bound set post [lrange $l 0 end] } - -2 { + Inf { #index above upper bound set post [list] } @@ -1632,9 +1632,9 @@ namespace eval punk::libunknown { if {[string is integer -strict $index]} { #can match +i -i if {$index < 0} { - return -3 + return -Inf } elseif {$index >= $len} { - return -2 + return Inf } else { #integer may still have + sign - normalize with expr return [expr {$index}] @@ -1646,14 +1646,14 @@ namespace eval punk::libunknown { set offset [string range $index 4 end] if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} if {$op eq "+" && $offset != 0} { - return -2 + return Inf } } else { #index is 'end' set index [expr {$len-1}] if {$index < 0} { #special case - 'end' with empty list - treat end like a positive number out of bounds - return -2 + return Inf } else { return $index } @@ -1661,7 +1661,7 @@ namespace eval punk::libunknown { if {$offset == 0} { set index [expr {$len-1}] if {$index < 0} { - return -2 ;#special case as above + return Inf ;#special case as above } else { return $index } @@ -1670,7 +1670,7 @@ namespace eval punk::libunknown { set index [expr {($len-1) - $offset}] } if {$index < 0} { - return -3 + return -Inf } else { return $index } @@ -1691,9 +1691,9 @@ namespace eval punk::libunknown { error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" } if {$index < 0} { - return -3 + return -Inf } elseif {$index >= $len} { - return -2 + return Inf } return $index } diff --git a/src/modules/punk/mix/util-999999.0a1.0.tm b/src/modules/punk/mix/util-999999.0a1.0.tm index 1eeb66f3..3e6088ad 100644 --- a/src/modules/punk/mix/util-999999.0a1.0.tm +++ b/src/modules/punk/mix/util-999999.0a1.0.tm @@ -150,7 +150,7 @@ namespace eval punk::mix::util { error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" } if {![string match ::* $ns]} { - set nscaller [uplevel 1 {namespace current}] + set nscaller [uplevel 1 {::tcl::namespace::current}] set ns [punk::nsjoin $nscaller $ns] } set a_export_patterns [namespace eval $source_ns {namespace export}] diff --git a/src/modules/punk/netbox-999999.0a1.0.tm b/src/modules/punk/netbox-999999.0a1.0.tm index 2508bc36..f8a4becd 100644 --- a/src/modules/punk/netbox-999999.0a1.0.tm +++ b/src/modules/punk/netbox-999999.0a1.0.tm @@ -711,6 +711,7 @@ tcl::namespace::eval punk::netbox { return [file join $punk_netbox_data_dir netbox_api_contexts.toml] } + lappend PUNKARGS [list { @id -id ::punk::netbox::api_context_save @cmd -name punk::netbox::api_context_save -help\ @@ -1173,483 +1174,458 @@ tcl::namespace::eval punk::netbox::dcim { tcl::namespace::eval punk::netbox::ipam { namespace export {[a-z]*} - lappend PUNKARGS [list\ - { - @dynamic - @id -id ::punk::netbox::ipam::vrfs_list - @cmd -name punk::netbox::ipam::vrfs_list -help\ - "ipam_vrfs_list - GET request for endpoint /ipam/vrfs/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - -id -type integer - -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -name - -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} - -rd -type string -help\ - "Route distinguisher in any format" - -enforce_unique - -description -type string -help "Exact Match (case sensitive)" - -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}} - }\ - [set ::punk::netbox::argdoc::_create_update_options]\ - { - -q - -tag - }\ - [set ::punk::netbox::argdoc::_tenant_options]\ - [set ::punk::netbox::argdoc::_region_options]\ - [set ::punk::netbox::argdoc::_site_options]\ - [set ::punk::netbox::argdoc::_group_options]\ - [set ::punk::netbox::argdoc::_role_options]\ - { - -status - -available_on_device - -available_on_virtualmachine - }\ - [set ::punk::netbox::argdoc::_page_options]\ - [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ - [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ - { - @values -min 0 -max 0 - }] + namespace eval argdoc { + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::ipam::vrfs_list + @cmd -name punk::netbox::ipam::vrfs_list -help\ + "ipam_vrfs_list + GET request for endpoint /ipam/vrfs/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + -rd -type string -help\ + "Route distinguisher in any format" + -enforce_unique + -description -type string -help "Exact Match (case sensitive)" + -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q + -tag + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + -status + -available_on_device + -available_on_virtualmachine + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::vrfs_list api/ipam/vrfs/ -verb get -body none - lappend PUNKARGS [list\ - { - @dynamic - @id -id ::punk::netbox::ipam::vrfs_read - @cmd -name punk::netbox::ipam::vrfs_read -help\ - "ipam_vrfs_list - GET request for endpoint /ipam/vrfs/{id}" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_RETURN_DICT]\ - { - @values -min 1 -max 1 - id -type integer -help\ - "A unique integer value identifying this VRF" - }] + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::ipam::vrfs_read + @cmd -name punk::netbox::ipam::vrfs_read -help\ + "ipam_vrfs_list + GET request for endpoint /ipam/vrfs/{id}" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this VRF" + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::vrfs_read api/ipam/vrfs/{id}/ -verb get -body none - - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::prefixes_list - @cmd -name punk::netbox::ipam::prefixes_list -help\ - "ipam_prefixes_list - GET request for endpoint /ipam/prefixes/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - -id -type integer - -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -is_pool - -mark_utilized - -description -type string -help "Exact Match (case sensitive)" - -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}} - }\ - [set ::punk::netbox::argdoc::_create_update_options]\ - { - -q -type string -help\ - "Query prefixes by substring" - -tag - }\ - [set ::punk::netbox::argdoc::_tenant_options]\ - [set ::punk::netbox::argdoc::_region_options]\ - [set ::punk::netbox::argdoc::_site_options]\ - [set ::punk::netbox::argdoc::_group_options]\ - [set ::punk::netbox::argdoc::_role_options]\ - { - -family - -prefix - -within - -within_include - -contains - -depth - -DEPTH_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -children - -CHILDREN_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -mask_length - -mask_length__gte - -mask_length__lte - -vlan_id -type integer - -vlan_id__n -type integer - -vlan_vid -type integer - -VLAN_VID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -vrf_id - -vrf - -status - -available_on_device - -available_on_virtualmachine - }\ - [set ::punk::netbox::argdoc::_page_options]\ - [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ - [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ - { - @values -min 0 -max 0 - }] + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_list + @cmd -name punk::netbox::ipam::prefixes_list -help\ + "ipam_prefixes_list + GET request for endpoint /ipam/prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -is_pool + -mark_utilized + -description -type string -help "Exact Match (case sensitive)" + -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q -type string -help\ + "Query prefixes by substring" + -tag + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + -family + -prefix + -within + -within_include + -contains + -depth + -DEPTH_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -children + -CHILDREN_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -mask_length + -mask_length__gte + -mask_length__lte + -vlan_id -type integer + -vlan_id__n -type integer + -vlan_vid -type integer + -VLAN_VID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -vrf_id + -vrf + -status + -available_on_device + -available_on_virtualmachine + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_list api/ipam/prefixes/ -verb get -body none - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::prefixes_create - @cmd -name punk::netbox::ipam::prefixes_create -help\ - "ipam_prefixes_create - POST request for endpoint /ipam/prefixes/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_RETURN_DICT]\ - { - @values -min 1 -max 1 - body -type string -help\ - "JSON string" - }] + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_create + @cmd -name punk::netbox::ipam::prefixes_create -help\ + "ipam_prefixes_create + POST request for endpoint /ipam/prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + body -type string -help\ + "JSON string" + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_create api/ipam/prefixes/{id}/ -verb post -body required - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::prefixes_read - @cmd -name punk::netbox::ipam::prefixes_read -help\ - "ipam_prefixes_read - GET request for endpoint /ipam/prefixes/{id}/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_RETURN_DICT]\ - { - @values -min 1 -max 1 - id -type integer -help\ - "A unique integer value identifying this prefix" - }] + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_read + @cmd -name punk::netbox::ipam::prefixes_read -help\ + "ipam_prefixes_read + GET request for endpoint /ipam/prefixes/{id}/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this prefix" + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_read api/ipam/prefixes/{id}/ -verb get -body none - - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::prefixes_available-ips_list - @cmd -name punk::netbox::ipam::prefixes_available-ips_list -help\ - "ipam_prefixes_available-ips_list - GET request for endpoint /ipam/prefixes/{id}/available-ips/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_page_options]\ - [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ - [set ::punk::netbox::argdoc::_RETURN_LISTOFDICTS]\ - { - @values -min 1 -max 1 - id -type integer -help\ - "A unique integer value identifying this prefix" - }\ - ] + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-ips_list + @cmd -name punk::netbox::ipam::prefixes_available-ips_list -help\ + "ipam_prefixes_available-ips_list + GET request for endpoint /ipam/prefixes/{id}/available-ips/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LISTOFDICTS]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this prefix" + }\ + ] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_list api/ipam/prefixes/{id}/available-ips/ -verb get -body none - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::prefixes_available-ips_create - @cmd -name punk::netbox::ipam::prefixes_available-ips_create -help\ - "ipam_prefixes_available-ips_create - POST request for endpoint /ipam/prefixes/{id}/available-ips/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ - [set ::punk::netbox::argdoc::_RETURN_LIST]\ - { - @values -min 1 -max 2 - id -type integer -help\ - "A unique integer value identifying this prefix" - body -type string -default "" -help\ - { - If empty create a single IP with default values. - (next available IP in prefix) - - e.g Create 2 IPs: - [ - {"description": "ip1"}, + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-ips_create + @cmd -name punk::netbox::ipam::prefixes_available-ips_create -help\ + "ipam_prefixes_available-ips_create + POST request for endpoint /ipam/prefixes/{id}/available-ips/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LIST]\ + { + @values -min 1 -max 2 + id -type integer -help\ + "A unique integer value identifying this prefix" + body -type string -default "" -help\ { - "description": "ip2", - "tenant": 5, - "dns_name": "test.intx.com.au" - } - ] - NOTE1: tenant is the tenant_id (why?) - NOTE: This always uses next available IPs. - To create a specific IP, use api/ipam/ip-addresses endpoint. + If empty create a single IP with default values. + (next available IP in prefix) - The returned json is just an object if one address created, - but a list if multiple. :/ + e.g Create 2 IPs: + [ + {"description": "ip1"}, + { + "description": "ip2", + "tenant": 5, + "dns_name": "test.intx.com.au" + } + ] + NOTE1: tenant is the tenant_id (why?) + NOTE: This always uses next available IPs. + To create a specific IP, use api/ipam/ip-addresses endpoint. - } - }\ - ] + The returned json is just an object if one address created, + but a list if multiple. :/ + + } + }\ + ] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-ips_create api/ipam/prefixes/{id}/available-ips/ -verb post -body required - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::prefixes_available-prefixes_list - @cmd -name punk::netbox::ipam::prefixes_available-prefixes_list -help\ - "ipam_prefixes_available-prefixes_list - GET request for endpoint /ipam/prefixes/{id}/available-prefixes/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_page_options]\ - [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ - [set ::punk::netbox::argdoc::_RETURN_LISTOFDICTS]\ - { - @values -min 1 -max 1 - id -type integer -help\ - "A unique integer value identifying this prefix" - }\ - ] + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-prefixes_list + @cmd -name punk::netbox::ipam::prefixes_available-prefixes_list -help\ + "ipam_prefixes_available-prefixes_list + GET request for endpoint /ipam/prefixes/{id}/available-prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LISTOFDICTS]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this prefix" + }\ + ] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_list api/ipam/prefixes/{id}/available-prefixes/ -verb get -body none - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::prefixes_available-prefixes_create - @cmd -name punk::netbox::ipam::prefixes_available-prefixes_create -help\ - "ipam_prefixes_available-prefixes_create - POST request for endpoint /ipam/prefixes/{id}/available-prefixes/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ - [set ::punk::netbox::argdoc::_RETURN_LIST]\ - { - @values -min 1 -max 2 - id -type integer -help\ - "A unique integer value identifying this prefix" - body -type string -default "" -help\ - { + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::prefixes_available-prefixes_create + @cmd -name punk::netbox::ipam::prefixes_available-prefixes_create -help\ + "ipam_prefixes_available-prefixes_create + POST request for endpoint /ipam/prefixes/{id}/available-prefixes/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_LIST]\ + { + @values -min 1 -max 2 + id -type integer -help\ + "A unique integer value identifying this prefix" + body -type string -default "" -help\ { - "prefix_length": 0 + { + "prefix_length": 0 + } } - } - }\ - ] + }\ + ] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::prefixes_available-prefixes_create api/ipam/prefixes/{id}/available-prefixes/ -verb post -body required - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::ip-addresses_list - @cmd -name punk::netbox::ipam::ip-addresses_list -help\ - "ipam_ip-addresses_list - GET request for endpoint /ipam/ip-addresses/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - -id -type integer - -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -dns_name - -DNS_NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} - -description -type string -help "Exact Match (case sensitive)" - -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}} - }\ - [set ::punk::netbox::argdoc::_create_update_options]\ - { - -q - -tag - }\ - [set ::punk::netbox::argdoc::_tenant_options]\ - [set ::punk::netbox::argdoc::_region_options]\ - [set ::punk::netbox::argdoc::_site_options]\ - [set ::punk::netbox::argdoc::_group_options]\ - [set ::punk::netbox::argdoc::_role_options]\ - { - -family - -parent - -address - -mask_length - -vrf_id - -vrf - -present_in_vrf_id - -present_in_vrf - -device - -device_id - -virtual_machine - -virtual_machine_id - -interface - -interface_id - -vminterface - -vminterface_id - -fhrpgroup_id - -assigned_to_interface - -status - -role - -available_on_device - -available_on_virtualmachine - }\ - [set ::punk::netbox::argdoc::_page_options]\ - [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ - [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ - { - @values -min 0 -max 0 - }] + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::ip-addresses_list + @cmd -name punk::netbox::ipam::ip-addresses_list -help\ + "ipam_ip-addresses_list + GET request for endpoint /ipam/ip-addresses/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -dns_name + -DNS_NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -description -type string -help "Exact Match (case sensitive)" + -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_description_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q + -tag + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + -family + -parent + -address + -mask_length + -vrf_id + -vrf + -present_in_vrf_id + -present_in_vrf + -device + -device_id + -virtual_machine + -virtual_machine_id + -interface + -interface_id + -vminterface + -vminterface_id + -fhrpgroup_id + -assigned_to_interface + -status + -role + -available_on_device + -available_on_virtualmachine + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_list api/ipam/ip-addresses/ -verb get -body none - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::ip-addresses_read - @cmd -name punk::netbox::ipam::ip-addresses_read -help\ - "ipam_ip-addresses_read - GET request for endpoint /ipam/ip-addresses/{id}/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_RETURN_DICT]\ - { - @values -min 1 -max 1 - id -type integer - }] + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::ip-addresses_read + @cmd -name punk::netbox::ipam::ip-addresses_read -help\ + "ipam_ip-addresses_read + GET request for endpoint /ipam/ip-addresses/{id}/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_read api/ipam/ip-addresses/{id}/ -verb get -body none - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::ip-addresses_create - @cmd -name punk::netbox::ipam::ip-addresses_create -help\ - "ipam_ip-addresses_create - POST request for endpoint /ipam/ip-addresses/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_RETURN_DICT]\ - { - @values -min 1 -max 1 - body -type string -help\ - {JSON string - Example: - { - "address": "string", - "vrf": 0, - "tenant": 0, - "status": "active", - "role": "loopback", - "assigned_object_type": "string", - "assigned_object_id": 0, - "nat_inside": 0, - "dns_name": "string", - "description": "string", - "tags": [ + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::ip-addresses_create + @cmd -name punk::netbox::ipam::ip-addresses_create -help\ + "ipam_ip-addresses_create + POST request for endpoint /ipam/ip-addresses/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + body -type string -help\ + {JSON string + Example: { - "name": "string", - "slug": "string", - "color": "string" - } - ], - "custom_fields": {} - } - Required: address (IPv4 or IPV6 address with mask) - } - }] - ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_create api/ipam/ip-addresses/ -verb post -body required - - punk::args::define {*}[list\ - { - @dynamic - @id -id ::punk::netbox::ipam::ip-addresses_bulk_partial_update - @cmd -name punk::netbox::ipam::ip-addresses_bulk_partial_update -help\ - "ipam_ip-addresses_bulk_partical_update - PATCH request for endpoint /ipam/ip-addresses/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_RETURN_DICT]\ - { - @values -min 1 -max 1 - body -type string -help\ - {JSON string - model: - { "address": "string", "vrf": 0, "tenant": 0, @@ -1668,236 +1644,308 @@ tcl::namespace::eval punk::netbox::ipam { } ], "custom_fields": {} + } + Required: address (IPv4 or IPV6 address with mask) } - required: address + }] } - }] - ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_bulk_partial_update api/ipam/ip-addresses/ -verb patch -body required + ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_create api/ipam/ip-addresses/ -verb post -body required + namespace eval argdoc { + punk::args::define {*}[list\ + { + @dynamic + @id -id ::punk::netbox::ipam::ip-addresses_bulk_partial_update + @cmd -name punk::netbox::ipam::ip-addresses_bulk_partial_update -help\ + "ipam_ip-addresses_bulk_partical_update + PATCH request for endpoint /ipam/ip-addresses/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + body -type string -help\ + {JSON string + model: + { + "address": "string", + "vrf": 0, + "tenant": 0, + "status": "active", + "role": "loopback", + "assigned_object_type": "string", + "assigned_object_id": 0, + "nat_inside": 0, + "dns_name": "string", + "description": "string", + "tags": [ + { + "name": "string", + "slug": "string", + "color": "string" + } + ], + "custom_fields": {} + } + required: address + } + }] + } + ::punk::netbox::system::make_rest_func ::punk::netbox::ipam::ip-addresses_bulk_partial_update api/ipam/ip-addresses/ -verb patch -body required } + + tcl::namespace::eval punk::netbox::tenancy { namespace export {[a-z]*} - lappend PUNKARGS [list\ - { - @dynamic - @id -id ::punk::netbox::tenancy::tenants_list - @cmd -name punk::netbox::tenancy::tenants_list -help\ - "tenancy_tenants_list - GET request for endpoint /tenancy/tenants/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - -id -type integer - -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -name - -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} - -slug -type string - -SLUG_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} - -description -type string - -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} - }\ - [set ::punk::netbox::argdoc::_create_update_options]\ - { - -q -type string - -tag -type string - -tag__n -type string - }\ - [set ::punk::netbox::argdoc::_contact_options]\ - { - }\ - { - }\ - [set ::punk::netbox::argdoc::_group_options]\ - { - }\ - [set ::punk::netbox::argdoc::_page_options]\ - [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ - [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ - { - @values -min 0 -max 0 - }] + variable PUNKARGS + + namespace eval argdoc { + variable PUNKARGS + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::tenancy::tenants_list + @cmd -name punk::netbox::tenancy::tenants_list -help\ + "tenancy_tenants_list + GET request for endpoint /tenancy/tenants/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + -slug -type string + -SLUG_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -description -type string + -DESCRIPTION_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q -type string + -tag -type string + -tag__n -type string + }\ + [set ::punk::netbox::argdoc::_contact_options]\ + { + }\ + { + }\ + [set ::punk::netbox::argdoc::_group_options]\ + { + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + ::punk::netbox::system::make_rest_func ::punk::netbox::tenancy::tenants_list api/tenancy/tenants/ -verb get -body none } tcl::namespace::eval punk::netbox::virtualization { namespace export {[a-z]*} - lappend PUNKARGS [list\ - { - @dynamic - @id -id ::punk::netbox::virtualization::virtual-machines_list - @cmd -name punk::netbox::virtualization::virtual-machines_list -help\ - "virtualization_virtual-machines_list - GET request for endpoint /virtualization/virtual-machines/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - -id -type integer - -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -name - -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} - -cluster -type string - -cluster_n -type string - -vcpus -type integer - -VCPUS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -memory -type integer -help\ - "Whole number" - -MEMORY_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - -disk -type integer - -DISK_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} - }\ - [set ::punk::netbox::argdoc::_create_update_options]\ - { - -q - -tag - }\ - [set ::punk::netbox::argdoc::_tenant_options]\ - [set ::punk::netbox::argdoc::_contact_options]\ - { - -local_context_data - -status - -status_n - -cluster_group_id - -cluster_group_id__n - -cluster_group - -cluster_group__n - -cluster_type_id - -cluster_type_id__n - -cluster_type - -cluster_type__n - -cluster_id - -cluster_id__n - }\ - [set ::punk::netbox::argdoc::_region_options]\ - [set ::punk::netbox::argdoc::_site_options]\ - { - -platform - -platform__n - -mac_address - -MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} - -has_primary_ip - }\ - [set ::punk::netbox::argdoc::_group_options]\ - [set ::punk::netbox::argdoc::_role_options]\ - { - }\ - [set ::punk::netbox::argdoc::_page_options]\ - [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ - [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ - { - @values -min 0 -max 0 - }] + + namespace eval argdoc { + variable PUNKARGS + variable DYN_CONTEXTNAMES + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_list + @cmd -name punk::netbox::virtualization::virtual-machines_list -help\ + "virtualization_virtual-machines_list + GET request for endpoint /virtualization/virtual-machines/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -id -type integer + -ID_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -name + -NAME_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_name_filter_help}} + -cluster -type string + -cluster_n -type string + -vcpus -type integer + -VCPUS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -memory -type integer -help\ + "Whole number" + -MEMORY_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + -disk -type integer + -DISK_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_number_filter_help}} + }\ + [set ::punk::netbox::argdoc::_create_update_options]\ + { + -q + -tag + }\ + [set ::punk::netbox::argdoc::_tenant_options]\ + [set ::punk::netbox::argdoc::_contact_options]\ + { + -local_context_data + -status + -status_n + -cluster_group_id + -cluster_group_id__n + -cluster_group + -cluster_group__n + -cluster_type_id + -cluster_type_id__n + -cluster_type + -cluster_type__n + -cluster_id + -cluster_id__n + }\ + [set ::punk::netbox::argdoc::_region_options]\ + [set ::punk::netbox::argdoc::_site_options]\ + { + -platform + -platform__n + -mac_address + -MAC_ADDRESS_FILTER -type list -minsize 2 -maxsize 2 -multiple 1 -unindentedfields {-help} -help {${$::punk::netbox::argdoc::_string_filter_help}} + -has_primary_ip + }\ + [set ::punk::netbox::argdoc::_group_options]\ + [set ::punk::netbox::argdoc::_role_options]\ + { + }\ + [set ::punk::netbox::argdoc::_page_options]\ + [set ::punk::netbox::argdoc::_CUSTOM_PARAMS]\ + [set ::punk::netbox::argdoc::_RETURN_PAGEDICT]\ + { + @values -min 0 -max 0 + }] + } + ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_list api/virtualization/virtual-machines/ -verb get -body none - lappend PUNKARGS [list\ - { - @dynamic - @id -id ::punk::netbox::virtualization::virtual-machines_create - @cmd -name punk::netbox::virtualization::virtual-machines_create -help\ - "virtualization_virtual-machines_create - GET request for endpoint /virtualization/virtual-machines/" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_RETURN_DICT]\ - { - @values -min 2 -max 2 - id -type integer -help\ - "A unique integer value identifying this virtual machine" - body -type string -help\ - "JSON string" - }] + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_create + @cmd -name punk::netbox::virtualization::virtual-machines_create -help\ + "virtualization_virtual-machines_create + GET request for endpoint /virtualization/virtual-machines/" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 2 -max 2 + id -type integer -help\ + "A unique integer value identifying this virtual machine" + body -type string -help\ + "JSON string" + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_create api/virtualization/virtual-machines/ -verb post -body required - lappend PUNKARGS [list\ - { - @dynamic - @id -id ::punk::netbox::virtualization::virtual-machines_delete - @cmd -name punk::netbox::virtualization::virtual-machines_delete -help\ - "virtualization_virtual-machines_delete - DELETE request for endpoint /virtualization/virtual-machines/ - HTTP code: 204 - " - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - -FORCE -default 0 -type boolean -help\ - "Set to true to BULK delete all items at this endpoint" - }\ - { - @values -min 0 -max 0 - }] + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_delete + @cmd -name punk::netbox::virtualization::virtual-machines_delete -help\ + "virtualization_virtual-machines_delete + DELETE request for endpoint /virtualization/virtual-machines/ + HTTP code: 204 + " + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + -FORCE -default 0 -type boolean -help\ + "Set to true to BULK delete all items at this endpoint" + }\ + { + @values -min 0 -max 0 + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_delete api/virtualization/virtual-machines/ -verb delete -body none - - lappend PUNKARGS [list\ - { - @dynamic - @id -id ::punk::netbox::virtualization::virtual-machines_read - @cmd -name punk::netbox::virtualization::virtual-machines_read -help\ - "virtualization_virtual-machines_read - GET request for endpoint /virtualization/virtual-machines/{id}" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_RETURN_DICT]\ - { - @values -min 1 -max 1 - id -type integer -help\ - "A unique integer value identifying this virtual machine" - }] + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_read + @cmd -name punk::netbox::virtualization::virtual-machines_read -help\ + "virtualization_virtual-machines_read + GET request for endpoint /virtualization/virtual-machines/{id}" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 1 -max 1 + id -type integer -help\ + "A unique integer value identifying this virtual machine" + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_read api/virtualization/virtual-machines/{id}/ -verb get -body none - lappend PUNKARGS [list\ - { - @dynamic - @id -id ::punk::netbox::virtualization::virtual-machines_update - @cmd -name punk::netbox::virtualization::virtual-machines_update -help\ - "virtualization_virtual-machines_update - PUT request for endpoint /virtualization/virtual-machines/{id}" - @leaders -min 1 -max 1 - apicontextid -help\ - "The name of the stored api context to use. - A contextid can be created in-memory using - api_context_create, or loaded from a .toml - file using api_context_load."\ - -choices {${[punk::netbox::api_context_names]}} - @opts - }\ - [set ::punk::netbox::argdoc::_RETURN_DICT]\ - { - @values -min 2 -max 2 - id -type integer -help\ - "A unique integer value identifying this virtual machine" - body -type string -help\ - "JSON string" - }] + namespace eval argdoc { + lappend PUNKARGS [list\ + { + @dynamic + @id -id ::punk::netbox::virtualization::virtual-machines_update + @cmd -name punk::netbox::virtualization::virtual-machines_update -help\ + "virtualization_virtual-machines_update + PUT request for endpoint /virtualization/virtual-machines/{id}" + @leaders -min 1 -max 1 + apicontextid -help\ + "The name of the stored api context to use. + A contextid can be created in-memory using + api_context_create, or loaded from a .toml + file using api_context_load."\ + -choices {${$DYN_CONTEXTNAMES}} + @opts + }\ + [set ::punk::netbox::argdoc::_RETURN_DICT]\ + { + @values -min 2 -max 2 + id -type integer -help\ + "A unique integer value identifying this virtual machine" + body -type string -help\ + "JSON string" + }] + } ::punk::netbox::system::make_rest_func ::punk::netbox::virtualization::virtual-machines_update api/virtualization/virtual-machines/{id}/ -verb put -body required } diff --git a/src/modules/punk/netbox/man-999999.0a1.0.tm b/src/modules/punk/netbox/man-999999.0a1.0.tm index 47492ce0..347b311b 100644 --- a/src/modules/punk/netbox/man-999999.0a1.0.tm +++ b/src/modules/punk/netbox/man-999999.0a1.0.tm @@ -178,13 +178,25 @@ tcl::namespace::eval punk::netbox::man::prefixes { namespace export {[a-z]*} namespace ensemble create -parameters {apicontextid} - variable PUNKARGS - lappend PUNKARGS [::list\ - [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes::list"}} ::punk::netbox::ipam::prefixes_list]\ + namespace eval argdoc { + variable PUNKARGS + #mark as @dynamic and ensure double-substitution present for dynamic parts + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [::list\ + {@dynamic}\ + [punk::args::resolved_def\ + -antiglobs {@leaders @values -RETURN}\ + -override { + @id {-id ::punk::netbox::man::prefixes::list } + apicontextid {-choices {${$DYN_CONTEXTNAMES}} } + }\ + ::punk::netbox::ipam::prefixes_list\ + ]\ {-RETURN -default table -choices {table tableobject list}}\ {-MAXRESULTS -type integer -default -1}\ {@values -min 0 -max 0}\ ] + } #caution: must use ::list to avoid loop proc list {args} { @@ -290,18 +302,24 @@ tcl::namespace::eval punk::netbox::man::prefixes { namespace ensemble create -parameters {apicontextid} variable PUNKARGS - lappend PUNKARGS [::list\ - [punk::args::resolved_def\ - -antiglobs {@leaders -offset}\ - -override {\ - @id {-id "::punk::netbox::man::prefixes::available-ips::create"}\ - -RETURN {-default table -choices {list linelist showlistofdicts}}\ - @values {-min 2 -max 2}\ - body {-optional 0}\ + namespace eval argdoc { + variable PUNKARGS + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [::list\ + {@dynamic}\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override { + @id {-id "::punk::netbox::man::prefixes::available-ips::create" } + apicontextid {-choices {${$DYN_CONTEXTNAMES}} } + -RETURN {-default table -choices {list linelist showlistofdicts} } + @values {-min 2 -max 2 } + body {-optional 0 } }\ - ::punk::netbox::ipam::prefixes_available-ips_create\ - ]\ - ] + ::punk::netbox::ipam::prefixes_available-ips_create\ + ]\ + ] + } proc create {args} { set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::create"] set resultlist [::list] @@ -356,18 +374,22 @@ tcl::namespace::eval punk::netbox::man::prefixes { # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ # {-RETURN -default table -choices {table tableobject list}} # ] - lappend PUNKARGS [::list\ - [punk::args::resolved_def\ - -antiglobs {@leaders -offset}\ - -override {\ - @id {-id "::punk::netbox::man::prefixes::available-ips::list"}\ - -limit {-default 254 -help "Maximum number of entries to return"}\ - -RETURN {-default table -choices {table tableobject list linelist}}\ - @values {-min 1 -max 1}\ + namespace eval argdoc { + lappend PUNKARGS [::list\ + {@dynamic}\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override { + @id {-id "::punk::netbox::man::prefixes::available-ips::list"} + apicontextid {-choices {${$DYN_CONTEXTNAMES}} } + -limit {-default 254 -help "Maximum number of entries to return"} + -RETURN {-default table -choices {table tableobject list linelist}} + @values {-min 1 -max 1} }\ - ::punk::netbox::ipam::prefixes_available-ips_list\ - ]\ - ] + ::punk::netbox::ipam::prefixes_available-ips_list\ + ]\ + ] + } proc list {args} { set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-ips::list"] @@ -453,20 +475,25 @@ tcl::namespace::eval punk::netbox::man::prefixes { tcl::namespace::eval available-prefixes { namespace export {[a-z]*} namespace ensemble create -parameters {apicontextid} - variable PUNKARGS - lappend PUNKARGS [::list\ - [punk::args::resolved_def\ - -antiglobs {@leaders -offset}\ - -override {\ - @id {-id "::punk::netbox::man::prefixes::available-prefixes::create"}\ - -RETURN {-default table -choices {list linelist showlistofdicts}}\ - @values {-min 2 -max 2}\ - body {-optional 0}\ + namespace eval argdoc { + variable PUNKARGS + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [::list\ + {@dynamic}\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override { + @id {-id "::punk::netbox::man::prefixes::available-prefixes::create"} + apicontextid {-choices {${$DYN_CONTEXTNAMES}} } + -RETURN {-default table -choices {list linelist showlistofdicts}} + @values {-min 2 -max 2} + body {-optional 0} }\ - ::punk::netbox::ipam::prefixes_available-prefixes_create\ - ]\ - ] + ::punk::netbox::ipam::prefixes_available-prefixes_create\ + ]\ + ] + } proc create {args} { set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::create"] set resultlist [::list] @@ -521,18 +548,22 @@ tcl::namespace::eval punk::netbox::man::prefixes { # [punk::args::resolved_def -antiglobs {apicontextid @leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::prefixes available-ips_list"}} ::punk::netbox::ipam::prefixes_available-ips_list]\ # {-RETURN -default table -choices {table tableobject list}} # ] - lappend PUNKARGS [::list\ - [punk::args::resolved_def\ - -antiglobs {@leaders -offset}\ - -override {\ - @id {-id "::punk::netbox::man::prefixes::available-prefixes::list"}\ - -limit {-default 254 -help "Maximum number of entries to return"}\ - -RETURN {-default table -choices {table tableobject list linelist}}\ - @values {-min 1 -max 1}\ + namespace eval argdoc { + lappend PUNKARGS [::list\ + {@dynamic}\ + [punk::args::resolved_def\ + -antiglobs {@leaders -offset}\ + -override { + @id {-id "::punk::netbox::man::prefixes::available-prefixes::list"} + apicontextid {-choices {${$DYN_CONTEXTNAMES}} } + -limit {-default 254 -help "Maximum number of entries to return"} + -RETURN {-default table -choices {table tableobject list linelist}} + @values {-min 1 -max 1} }\ - ::punk::netbox::ipam::prefixes_available-prefixes_list\ - ]\ - ] + ::punk::netbox::ipam::prefixes_available-prefixes_list\ + ]\ + ] + } proc list {args} { set argd [punk::args::parse $args withid "::punk::netbox::man::prefixes::available-prefixes::list"] @@ -631,17 +662,23 @@ tcl::namespace::eval punk::netbox::man::tenancy { #we're overriding a resolved_def which was dynamic # - we need to ensure the new definition is also dynamic # - todo - override rawdef instead? (convenience functions for override of rawdef is missing in punk::args) - lappend PUNKARGS [::list\ - @dynamic\ - [punk::args::resolved_def\ - -antiglobs {@leaders @values -RETURN}\ - -override {@id {-id "::punk::netbox::man::tenancy::tenants::list"} apicontextid {-choices {${[punk::netbox::api_context_names]}}}}\ - ::punk::netbox::tenancy::tenants_list\ - ]\ - {-RETURN -default table -choices {table tableobject list linelist}}\ - {-MAXRESULTS -type integer -default -1}\ - {@values -min 0 -max 0}\ - ] + namespace eval argdoc { + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [::list\ + @dynamic\ + [punk::args::resolved_def\ + -antiglobs {@leaders @values -RETURN}\ + -override { + @id {-id "::punk::netbox::man::tenancy::tenants::list" } + apicontextid {-choices {${$DYN_CONTEXTNAMES}} } + }\ + ::punk::netbox::tenancy::tenants_list\ + ]\ + {-RETURN -default table -choices {table tableobject list linelist}}\ + {-MAXRESULTS -type integer -default -1}\ + {@values -min 0 -max 0}\ + ] + } proc list {args} { set argd [punk::args::parse $args withid "::punk::netbox::man::tenancy::tenants::list"] @@ -757,13 +794,25 @@ tcl::namespace::eval punk::netbox::man::virtualization { namespace export {[a-z]*} namespace ensemble create -parameters {apicontextid} variable PUNKARGS + namespace eval argdoc { + variable PUNKARGS + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} - lappend PUNKARGS [::list\ - [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::virtualization::virtual-machines::list"}} ::punk::netbox::virtualization::virtual-machines_list]\ + lappend PUNKARGS [::list\ + {@dynamic}\ + [punk::args::resolved_def\ + -antiglobs {@leaders @values -RETURN}\ + -override { + @id {-id "::punk::netbox::man::virtualization::virtual-machines::list" } + apicontextid {-choices {${$DYN_CONTEXTNAMES}} } + }\ + ::punk::netbox::virtualization::virtual-machines_list\ + ]\ {-RETURN -default table -choices {table tableobject list linelist}}\ {-MAXRESULTS -type integer -default -1}\ {@values -min 0 -max 0}\ - ] + ] + } proc list {args} { set argd [punk::args::parse $args withid "::punk::netbox::man::virtualization::virtual-machines::list"] @@ -881,14 +930,24 @@ tcl::namespace::eval punk::netbox::man::virtualization { tcl::namespace::eval punk::netbox::man::ip-addresses { namespace export {[a-z]*} namespace ensemble create -parameters {apicontextid} - variable PUNKARGS - lappend PUNKARGS [::list\ - [punk::args::resolved_def -antiglobs {@leaders @values -RETURN} -override {@id {-id "::punk::netbox::man::ip-addresses::list"}} ::punk::netbox::ipam::ip-addresses_list]\ + namespace eval argdoc { + set DYN_CONTEXTNAMES {${[punk::netbox::api_context_names]}} + lappend PUNKARGS [::list\ + {@dynamic}\ + [punk::args::resolved_def\ + -antiglobs {@leaders @values -RETURN}\ + -override { + @id {-id ::punk::netbox::man::ip-addresses::list } + apicontextid {-choices {${$DYN_CONTEXTNAMES}} } + }\ + ::punk::netbox::ipam::ip-addresses_list\ + ]\ {-RETURN -default table -choices {table tableobject list linelist}}\ {-MAXRESULTS -type integer -default -1}\ {@values -min 0 -max 0}\ ] + } #caution: must use ::list to avoid loop proc list {args} { diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 62fd8435..b1b589c3 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -72,7 +72,7 @@ tcl::namespace::eval 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 {::namespace current}] + set ns_caller [uplevel 1 {::tcl::namespace::current}] #puts stderr "ns_cur:$ns_current ns_call:$ns_caller" @@ -197,7 +197,7 @@ tcl::namespace::eval punk::ns { set parts [nsparts_cached $nspath] if {[lindex $parts 0] ne ""} { #relative - set ns_caller [uplevel 1 {::namespace current}] + set ns_caller [uplevel 1 [list ::tcl::namespace::current]] set fq_nspath [nsjoin $ns_caller $nspath] } else { set fq_nspath $nspath @@ -209,6 +209,8 @@ tcl::namespace::eval punk::ns { } } + #todo - consider coroutine-based implementation? + #recursive nseval - for introspection of weird namespace trees #approx 10x slower than normal tcl::namespace::eval - but still only a few microseconds.. fine for repl introspection #WARNING: creates namespaces if they don't exist @@ -268,6 +270,10 @@ tcl::namespace::eval punk::ns { } tailcall $cmd $script } + + #for 'weird' namespaces, this uses a generated nested script + #It has to run this (probably non byte-compiled?) script twice in some cases + #consider coroutine-based alternative? proc nseval_ifexists {ns script} { set parts [nsparts $ns] if {[lindex $parts 0] ne ""} { @@ -280,13 +286,27 @@ tcl::namespace::eval punk::ns { if {[lsearch [nsparts $nsfq] :*] >=0} { #weird_ns set ns_script [nseval_ifexists_getscript $nsfq] - return [uplevel 1 [list {*}$ns_script $script]] + #we need to return an error if the script itself errors - but not return an error due to ns not existing + if {[catch {uplevel 1 [list {*}$ns_script {::string cat ok}]} isok]} { + #the error must be due to ns path not existing + return + } else { + #only re-run if script is something else + if {$script ne {::string cat ok}} { + #some other script - if it raises an error we want to see it. + return [uplevel 1 [list {*}$ns_script $script]] + } else { + return $isok + } + } } else { if {[namespace exists $nsfq]} { return [namespace eval $nsfq $script] } } } + + #resulting script can error for non-existant ns proc nseval_ifexists_getscript {location} { set parts [nsparts $location] if {[lindex $parts 0] eq ""} { @@ -341,7 +361,7 @@ tcl::namespace::eval punk::ns { ns } proc nschildren {args} { - set argd [punk::args::parse $args withid ::punk::ns::nschildren] + set argd [punk::args::parse $args -cache 1 withid ::punk::ns::nschildren] set opt_sort [dict get $argd opts -sort] set ns [dict get $argd values ns] set parts [nsparts $ns] @@ -812,7 +832,7 @@ tcl::namespace::eval punk::ns { proc nstree {{location ""}} { if {![string match ::* $location]} { - set nscaller [uplevel 1 {::namespace current}] + set nscaller [uplevel 1 {::tcl::namespace::current}] set location [nsjoin $nscaller $location] } list_as_lines [nstree_list $location] @@ -1034,7 +1054,7 @@ tcl::namespace::eval punk::ns { } proc Cmark {args} { if {[llength $args] == 0} { - punk::args::parse {} withid ::punk::ns::Cmark + punk::args::parse {} -cache 1 withid ::punk::ns::Cmark return; #should be unreachable - parse should raise usage error } set type [lindex $args 0] @@ -1057,7 +1077,7 @@ tcl::namespace::eval punk::ns { } #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) proc aliases {{tailglob *}} { - set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + set ns [uplevel 1 {::tcl::namespace::current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command set ns_segments [nsparts_cached $ns] ;#include empty string before leading :: if {![string length [lindex $ns_segments end]]} { @@ -1095,72 +1115,109 @@ tcl::namespace::eval punk::ns { #set matched_abs [lsearch -all -inline $all_aliases $glob] return $matched } - proc aliases1 {{glob *}} { - set ns [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - set ns_mapped [string map {:: \uFFFF} $ns] - #puts stderr "aliases ns: $ns_mapped" - set segments [split $ns_mapped \uFFFF] ;#include empty string before leading :: - if {![string length [lindex $segments end]]} { - #special case for :: only include leading segment rather thatn {} {} - set segments [lrange $segments 0 end-1] - } - set segcount [llength $segments] ;#only match number of segments matching current ns + punk::args::define { + @id -id ::punk::ns::alias + @cmd -name punk::ns::alias\ + -summary\ + "Get/set alias in current namespace."\ + -help\ + "" + @opts + -force -type none -help\ + "" + @values -min 0 -max -1 + aliasorglob -default "" -optional 1 + arg -type any -multiple 1 -optional 1 + } + #todo - use punk::args + #enforce overwrite of alias or shadowing of resolvable command to require -force argument + #todo - mechanism to keep track of all aliases made in session and allow saving to config? + proc alias {args} { + set argd [punk::args::parse $args withid ::punk::ns::alias] + lassign [dict values $argd] leaders opts values received + set aliasorglob [dict get $values aliasorglob] + if {[dict exists $received arg]} { + set arglist [dict get $values arg] + } else { + set arglist [list] + } - set all_aliases [interp aliases {}] - set matched [list] - foreach a $all_aliases { - #normalize with leading :: - if {![string match ::* $a]} { - set abs ::$a + set nsthis [uplevel 1 {::tcl::namespace::current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command + if {[llength $arglist]} { + set nsparts [nsparts $aliasorglob] + if {[lindex $nsparts 0] ne ""} { + #relative ns path specified for aliasorglob + set fqns [nsjoin $nsthis $aliasorglob] } else { - set abs $a - } - - set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] - set acount [llength $asegs] - #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {($acount - 1) == $segcount} { - if {[lrange $asegs 0 end-1] eq $segments} { - if {[string match $glob [lindex $asegs end]]} { - #report this alias in the current namespace - even though there may be no matching command - lappend matched $a ;#add raw alias token which may or may not have leading :: - } + set fqns $aliasorglob + } + set plain_fqns [string range $fqns 2 end] ;#tcl treats alias ::blah::etc the same as blah::etc + #we will test for collisions with plain_fqns - but always create as fully qualified + set all_aliases [interp aliases ""] + set existing_target "" + if {$fqns in $all_aliases} { + set existing_target [interp alias "" $fqns] + set aliasname $fqns + } elseif {$plain_fqns in $all_aliases} { + set existing_target [interp alias "" $plain_fqns] + set aliasname $plain_fqns + } + if {([llength $arglist] ==1) && [string trim [lindex $arglist 0]] eq ""} { + #use empty string/whitespace as intention to delete alias + if {$existing_target ne ""} { + puts stderr "Removing existing alias $aliasname -> $existing_target (in current session only)" } + return [interp alias "" $fqns ""] } - } - #set matched_abs [lsearch -all -inline $all_aliases $glob] - return $matched - } - - proc alias {{aliasorglob ""} args} { - set nsthis [uplevel 1 {::namespace current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command - if {[llength $args]} { - if {$aliasorglob in [interp aliases ""]} { - set existing [interp alias "" $aliasorglob] - puts stderr "Overwriting existing alias $aliasorglob -> $existing with $aliasorglob -> $args (in current session only)" + set firstword [lindex $arglist 0] + set which [uplevel 1 [list ::tcl::namespace::which $firstword]] + if {$which ne ""} { + #use resolved + lset arglist 0 $which } - if {([llength $args] ==1) && [string trim [lindex $args 0]] eq ""} { - #use empty string/whitespace as intention to delete alias - return [interp alias "" $aliasorglob ""] + + if {$existing_target ne ""} { + puts stderr "Overwriting existing alias $aliasname -> $existing_target with $fqns -> $arglist (in current session only)" + } else { + #check if we are shadowing a resolvable command + set resolved [namespace which $aliasorglob] + if {$resolved ne ""} { + puts stderr "Alias $fqns will shadow existing command $resolved when in current namespace" + } } - return [interp alias "" $aliasorglob "" {*}$args] + return [interp alias "" $fqns "" {*}$arglist] } else { if {![string length $aliasorglob]} { - set aliaslist [punk::ns::aliases] - puts -nonewline stderr $aliaslist + #no arguments or specific alias query - display all in current namespace + puts stderr [uplevel 1 [list punk::ns::aliases]] return } + + set nsparts [nsparts $aliasorglob] + if {[lindex $nsparts 0] ne ""} { + #relative ns path specified for aliasorglob + set fqns [nsjoin $nsthis $aliasorglob] + } else { + set fqns $aliasorglob + } + set plain_fqns [string range $fqns 2 end] ;#tcl treats alias ::blah::etc the same as blah::etc + #we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias - set target [interp alias "" $aliasorglob] + set target [interp alias "" $fqns] + if {[llength $target]} { + return $target + } + set target [interp alias "" $plain_fqns] if {[llength $target]} { return $target } + #review if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { - set aliaslist [punk::ns::aliases $aliasorglob] - puts -nonewline stderr $aliaslist + set aliaslist [uplevel 1 [list punk::ns::aliases $aliasorglob]] + puts stderr $aliaslist return } return [list] @@ -1508,7 +1565,7 @@ tcl::namespace::eval punk::ns { if {$path_is_absolute} { return $nspath } - set ns_caller [uplevel 1 {::namespace current}] ;#must qualify 'namespace' command. Needs to be called from arbitrary namespaces where 'namespace' command may exist (e.g tdom::schema) + set ns_caller [uplevel 1 {::tcl::namespace::current}] ;#must qualify 'namespace' command. Needs to be called from arbitrary namespaces where 'namespace' command may exist (e.g tdom::schema) if {$nspath eq "\uFFFF"} { return $ns_caller } @@ -1671,6 +1728,1228 @@ tcl::namespace::eval punk::ns { return [get_ns_dicts $ns_absolute {*}$args] } + #return a dict of info about keys and switches in a switch block + #In particular we need the line-numbers from the raw scriptblock where each script begins and where each key begins. + #(used to calculate line offsets in execution trace callbacks for debug display) + #(for switch -form 1 - combined patterns and bodies in single argument) + #test with: switchblock_scriptindex_line [string trim [info body test_switch]] + #note that "-" between keys is considered a scriptblock in this context + #NOTE: in *nearly* every case - the script starts on the same line as the key + + + variable switchblock_cache ;#review - when do we clear it? + set switchblock_cache [dict create] + proc switchblock_info {switchblock} { + variable switchblock_cache + set patternblock [lindex $switchblock end] + if {[dict exists $switchblock_cache $patternblock]} { + return [dict get $switchblock_cache $patternblock] + } + #eg for: + #switch -- $val {...} + #(where newlines may be present in ...) + #return only the lines in ... + set lines [split $patternblock \n] + set scriptline 0 + set current_scriptindex 0 + set keys [list] + set key "" + set scriptblock "" + set scripts [list] + set in_script 0 + set linenum 0 + set index_to_linenums [dict create] + foreach ln $lines { + incr linenum + set chars [split $ln ""] + set cidx 0 + foreach ch $chars { + incr cidx ;#1-based + if {!$in_script} { + if {$key eq ""} { + if {![string is space $ch]} { + append key $ch + #add the linenum info before key is ready + dict set index_to_linenums [llength $keys] [dict create k $linenum s ""] + if {[info complete $key] && $cidx == [llength $chars]} { + #complete key at end of line + append key \n + lappend keys $key + set key "" + set in_script 1 + } + } + } else { + if {![info complete $key]} { + append key $ch + } else { + if {[string is space $ch]} { + lappend keys $key + set key "" + set in_script 1 + } else { + append key $ch + if {$cidx == [llength $chars]} { + lappend keys $key + set key "" + set in_script 1 + } + } + } + } + } else { + if {$scriptblock eq ""} { + if {![string is space $ch]} { + #start of script - record linenumber + set idx [expr {[llength $keys]-1}] + set lineinfo [dict get $index_to_linenums $idx] ;#entry already created by key + dict set lineinfo s $linenum + dict set index_to_linenums $idx $lineinfo ;#updated so now has linenums for both k and s + append scriptblock $ch + } + } else { + if {![info complete $scriptblock]} { + append scriptblock $ch + } else { + if {[string is space $ch]} { + + lappend scripts $scriptblock + set scriptblock "" + set in_script 0 + } else { + append scriptblock $ch + } + } + } + } + } + } + if {[llength $keys] != [llength $scripts]} { + error "switchblock_info failed to parse patternblock [llength keys] keys vs [llength $scripts] scripts\npatternblock:\n$patternblock" + } + + set result [list keys $keys scripts $scripts lineinfo $index_to_linenums] + dict set switchblock_cache $patternblock $result + return $result + } + proc test_switch {s} { + switch -- $s { x {return x} + a - b { + return AB + } + c - d - + e { + #line number effect of this comment? + set result CDE + return $result + } + f - g\ + - h { + return FGH + } i - j - k {return IJK} l - m - n { + set result LMN + #test + return $result + } + o - + p - q + {return OPQ} + "quirk +y" {return quirkykeyscript} + default { + return default + } + } + } + proc test_switch2 {s} { + switch -- [string index $s 0] { + a { + switch -- [string index $s 1] { + 1 { + return a1 + } + 2 { + #etc + #blah + set msg "test" + return "a2_$msg" + } + 3 { + set slen [string length $s] + switch -- $slen { + 1 { + return a3-1 + } + 2 { + return a3-2 + } + default { + return a3-more + } + } + } + default { + return a[string index $s 1]-default + } + } + } + b { + if {[string length $s] == 1} { + return b-1 + } elseif {[string length $s] == 2} { + return b-2 + } else { + return b-more + } + } + default { + return default + } + } + } + proc test_switch3 {s} { + switch -- [string index $s 0] { + a { + switch -- [string index $s 1] { + 1 { + call_frame + return a1 + } + 2 { + call_frame + return a2 + } + 3 { + set c3 [string index $s 2] + # + # + switch -- $c3 { + 1 { + call_frame + return a31 + } + 2 { + call_frame + return a32 + } + 3 { + call_frame + return a33 + } + 4 { + #test + call_frame + #etc + call_frame + return a34 + } + default { + call_frame + return a3-default + } + } + } + 4 { + #etc + #blah + call_frame + #return a2 + return a4 + } + default { + call_frame + return a[string index $s 1]-default + } + } + } + b { + if {[string length $s] == 1} { + call_frame + return b-1 + } elseif {[string length $s] == 2} { + call_frame + return b-2 + } else { + call_frame + return b-more + } + } + c { + #test + call_frame + return c + } + d { + call_frame + return d + } + default { + return default + } + } + } + + + proc test_switch4 {s} { + switch [string index $s 0] { + a { + set ch2 [string index $s 1] + switch $ch2 { + x { + call_frame + return ax + } + y { + call_frame + return ay + } + z { + call_frame + return az + } + a { + call_frame + return aa + } + b { + call_frame + return ab + } + default { + call_frame + return a_ + } + } + } + } + } + proc test_switch4b {s} { + switch -- [string index $s 0] { + a { + set ch2 [string index $s 1] + switch -- $ch2 { + x { + call_frame + return ax + } + y { + call_frame + return ay + } + z { + call_frame + return az + } + a { + call_frame + return aa + } + b { + call_frame + return ab + } + default { + call_frame + return a_ + } + } + } + } + } + proc test_switch4c {s} { + set ch1 [string index $s 0] + set ch2 [string index $s 1] + switch -- $ch1 { + a { + switch -- $ch2 { + x { + call_frame + return ax + } + y { + call_frame + return ay + } + z { + call_frame + return az + } + a { + call_frame + return aa + } + b { + call_frame + return ab + } + default { + call_frame + return a_ + } + } + } + } + } + + proc test_switch4d {s} { + switch -exact [string index $s 0] { + a { + switch -exact [string index $s 1] { + a { + return aa + } + b { + return ab + } + c { + return ac + } + default { + return a-default + } + } + } + b { + switch -exact [string index $s 1] { + a { + return ba + } + b { + switch -exact [string index $s 2] { + a { + return bba + } + b { + return bbb + } + c { + return bbc + } + default { + return bb-default + } + } + } + c { + return bc + } + default { + return b-default + } + } + } + c { + switch -exact [string index $s 1] { + a { + switch -exact [string index $s 2] { + a { + return caa + } + b { + return cab + } + c { + return cac + } + default { + return ca-default + } + } + + } + b { + return cb + } + c { + switch -exact [string index $s 2] { + a { + return cca + } + b { + return ccb + } + c { + return ccc + } + default { + return cc-default + } + } + } + default { + return c-default + } + } + } + } + } + proc test_switch5 {s} { + set ch1 [string index $s 0] + switch -- $ch1 { + x { + return ax + } + y { + return ay + } + z { + return az + } + a { + return aa + } + b { + return ab + } + default { + return a_ + } + } + } + + variable tinfo + proc _cmdtrace_enter {vname target args} { + variable _cmdtrace_disabled + if {$_cmdtrace_disabled} return + + variable tinfo + #----------------------------------------------------------------------------------------------------------------- + #traces are still in place at this point for $target - but according to trace documentation are disabled + # (they still show in 'trace info execution $target' output) + #NOTE however that traces for other targets will still run on anything we do here. + #We don't seem to be able to stop the callbacks - but we can flag with _cmdtrace_disabled until were done here. + #--------------------------------------------------- + #Note that in an environment with channel transforms - even a basic puts to stderr/stdout may invoke a slew of commands + #--------------------------------------------------- + set _cmdtrace_disabled true + #----------------------------------------------------------------------------------------------------------------- + + tcl::dict::set tinfo($target) firstline -1 + tcl::dict::set tinfo($target) procoffset 0 + tcl::dict::set tinfo($target) level [expr {[::tcl::info::level]+1}] + tcl::dict::set tinfo($target) subcmds 0 + puts "enter: $target -- $args" + puts "frame-2: [::tcl::info::frame -2]" + + set _cmdtrace_disabled false + } + proc _cmdtrace_leave {vname target args} { + + variable _cmdtrace_disabled + if {$_cmdtrace_disabled} return + #----------------------------------------------------------------------------------------------------------------- + #traces are still in place at this point for $target - but according to trace documentation are disabled + # (they still show in 'trace info execution $target' output) + #NOTE however that traces for other targets will still run on anything we do here. + #We don't seem to be able to stop the callbacks - but we can flag with _cmdtrace_disabled until were done here. + #puts "-----------" + #puts [trace info execution $target] + #puts "-----------" + set _cmdtrace_disabled true + #----------------------------------------------------------------------------------------------------------------- + + + #variable tinfo + upvar $vname linedict + + lassign $args commandstring code result op + if {$code == 0} { + ::dictn::incr linedict [list $target successcalls] 1 + } else { + ::dictn::incr linedict [list $target errorcalls] 1 + } + + puts stdout "leaving $target" + puts stdout "call $commandstring\x1b\[m" + puts stdout "result:" + puts stdout $result + puts stdout \x1b\[m ;#result may leave terminal with ansi SGR attributes in effect - emit a reset + + set cmdtype [dict get $linedict $target cmdtype] + if {$cmdtype eq "proc"} { + set procbody [punk::ns::corp -n $target] ;#may commonly be repeated in a cmdtrace operation - cache? + + dict for {k v} [dict get $linedict $target lines] { + set t [dict get $v type] + set c [dict get $v calls] + switch -- $t { + proc - eval { + set procbody [grepstr -r a -highlight {red bold underline} "^\\s*${k}\\s+" $procbody] + } + source { + set procbody [grepstr -r a -highlight {yellow bold underline} "^\\s*${k}\\s+" $procbody] + puts stderr "source $k" + } + default { + #set procbody [grepstr -r a -highlight {cyan bold underline} "^\\s*${k}\\s+" $procbody] + puts stderr "$t $k" + } + } + } + puts stdout $procbody + punk::lib::askuser "paused - hit enter key to continue" + puts stdout "continuing..." + } + + set _cmdtrace_disabled false + } + proc dkf_enterstep {vname target args} { + #dkf sample on wiki + variable tinfo + if {$tinfo(disabled)} return + #only trace top level steps in the proc + if {[info level] == [dict get $tinfo($target) level]} { + if {[dict get $tinfo($target) firstline] < 0} { + # make line numbers relative to the start of the proc rather than the file + set finfo [info frame -4] + set firstline [dict get $finfo line] + dict set tinfo($target) firstline $firstline + } + dkf_DumpFrame $target -3 + } + } + proc dkf_DumpFrame {procname frame} { + variable tinfo + set d [info frame [expr {$frame -1}]] + if {![dict exists $d proc]} { + return + } + # This test prevents tracing of stuff uplevelled from called procs + if {"[dict get $d proc]" ne "$procname"} { + return + } + set cmd [dict get $d cmd] + # limit output to one line + set nl [string first "\n" $cmd] + if {$nl >= 0} { + set cmd [string range $cmd 0 $nl-1]... + } + # calculate proc line number rather than file line number + set procline [expr {[dict get $d line] - [dict get $tinfo($procname) firstline] + 1}] + puts stdout "TRACE $procname line $procline $cmd" + # by performing a vwait at this point you can easily implement single stepping etc + #vwait ::step + } + + proc _cmdtrace_get_eval_offset {cmdlist} { + set eval_offset "default" ;#we need to detect default vs having been set to 1 (which happens to be the default) + #cmdlist has already been 'expanded' by Tcl + #so we don't get things like {switch -$matchtype [lindex $args 0] {....}} + + set cmd_firstword [lindex $cmdlist 0] + switch -- $cmd_firstword { + "switch" { + puts "found a switch" + set cmd_args [lrange $cmdlist 1 end] + + #review - why do we punk::args::parse it for form 1? 2nd last in cmdlist is string to match, last element in cmdlist is patternbody block (curly wrapped) + if {![catch {punk::args::parse $cmd_args -cache 1 -form 1 withid ::switch} parseresult]} { + #determine which switch arm any following 'eval' callbacks will belong to. + #puts ">>> $parseresult" + set patterndict [dict get $parseresult values {{pattern body ?pattern body?...}}] ;#review - fragile name in punk::args::define script for ::switch? + #set patterndict [lindex $cmdlist end 0] ? + #set switchstring [dict get $parseresult values string] ;#string being matched + #match using same flags as original switch statement + #we just need the index of which arm matches - then we can use switchblock_info to determine the right line within the raw switch body + set testswitch [lrange $cmdlist 0 end-1] ;# switch -- + set testbody [list] + set idx -1 + dict for {k v} $patterndict { + incr idx + lappend testbody $k "expr $idx" + } + lappend testswitch $testbody + #puts stderr "--------------" + puts stderr $testswitch + #puts stderr "--------------" + if {[catch { + set switch_arm_index [eval $testswitch] + } errM]} { + puts stderr "testswitch error: $errM" + } else { + puts stderr "switch arm $switch_arm_index" + #Tcl switch doesn't have to have a default case, so our testswitch can legitimately produce an empty + #result when no arms matched + if {$switch_arm_index ne ""} { + set ts_start [clock millis] + set switchinfo [punk::ns::switchblock_info $cmdlist] + set ts_now [clock millis] + puts stderr "switchblock_info gathered in [expr {$ts_now - $ts_start}] ms" + #puts stderr $switchinfo + + set keys [dict get $switchinfo keys] + set scripts [dict get $switchinfo scripts] + set numkeys [llength $keys] + set lineinfo [dict get $switchinfo lineinfo] + set script_start_line "" + for {set kidx $switch_arm_index} {$kidx < $numkeys} {incr kidx} { + set scr [lindex $scripts $kidx] + if {$scr ne "-"} { + set linedata [dict get $lineinfo $kidx] + set script_start_line [dict get $linedata s] + break + } + } + puts stderr "script_start_line: $script_start_line" + set eval_offset $script_start_line + } + } + + } else { + puts stderr "_cmdtrace_get_eval_offset failed to parse switch statement (wrong form?)\n$parseresult" + } + } + default { + } + } + return $eval_offset + } + + #set a (1-based) eval_offset for commands which generate subsequent enterstep trace callbacks of type 'eval' e.g switch statements + proc _cmdtrace_get_eval_offset1 {cmd} { + set eval_offset 1 ;#default + + #list operations not safe on cmd. eg {mycmd {*}$something} + set endw1 [string wordend $cmd 0] + set cmd_firstword [string range $cmd 0 $endw1-1] + switch -- $cmd_firstword { + "switch" { + puts "found a switch" + set cmd_string [string range $cmd $endw1 end] + puts "--------->" + puts $cmd_string + puts "--------->" + #scripts are of a form that hasn't been parsed into arguments. + #ie Tcl hasn't expanded it, so we don't have a tcl list of arguments to punk::args::parse against the ::switch definition forms. + #eg " -- [lindex $args 0] {....}" + #eg " {*}[get opts] -- ${match} {....}" + #eg " -[get matchtype] -- {....} + #eg " -- $prefix$etc [get my switch body]" + # + #Even the switch body (for switch -form 1, combined pattern/script block) can't simply be retrieved as the last element in the script - especially not using list operations. + # + set scriptlist [punk::lib::tclscript_to_scriptlist $cmd_string] + set cmd_args [lindex $scriptlist 0] ;#should only be one list in the list of lists + #set a [concat {*}$cmd_args] ;#REVIEW - is this roundtrip fundamentally any different to the string? how? + #puts stderr "------------------>" + #puts stderr $a + #puts stderr "------------------>" + set alist [list] + foreach a $cmd_args { + lappend alist [lindex $a 0] + } + + + + if {![catch {punk::args::parse $alist -cache 1 -form 1 withid ::switch} parseresult]} { + #determine which switch arm any following 'eval' callbacks will belong to. + puts ">>> $parseresult" + set patterndict [dict get $parseresult values {{pattern body ?pattern body?...}}] ;#review - fragile name in punk::args::define script for ::switch? + set switchstring [dict get $parseresult values string] ;#string being matched + set string [uplevel 2 [list ::subst $switchstring]] + #match using same flags as original switch statement + #we just need the index of which arm matches - then we can use switchblock_info to determine the right line within the raw switch body + set testswitch [list] + #usually ok for a switch - but we shouldn't really treat $cmd directly as a list here either. review + lappend testswitch {*}[lrange $cmd 0 end-2] ;# switch -- + lappend testswitch $string + set testbody [list] + set idx -1 + dict for {k v} $patterndict { + incr idx + lappend testbody $k "expr $idx" + } + lappend testswitch $testbody + #puts stderr "--------------" + puts stderr $testswitch + #puts stderr "--------------" + if {[catch { + set switch_arm_index [eval $testswitch] + } errM]} { + puts stderr "testswitch error: $errM" + } else { + puts stderr "switch arm $switch_arm_index" + #Tcl switch doesn't have to have a default case, so our testswitch can legitimately produce an empty + #result when no arms matched + if {$switch_arm_index ne ""} { + set switchinfo [punk::ns::switchblock_info $cmd] + puts stderr $switchinfo + + set keys [dict get $switchinfo keys] + set scripts [dict get $switchinfo scripts] + set numkeys [llength $keys] + set lineinfo [dict get $switchinfo lineinfo] + set script_start_line "" + for {set kidx $switch_arm_index} {$kidx < $numkeys} {incr kidx} { + set scr [lindex $scripts $kidx] + if {$scr ne "-"} { + set linedata [dict get $lineinfo $kidx] + set script_start_line [dict get $linedata s] + break + } + } + puts stderr "script_start_line: $script_start_line" + set eval_offset $script_start_line + } + } + + } else { + puts stderr "_coverage_enterstep failed to parse switch statement (wrong form?)\n$parseresult" + } + } + default { + } + } + return $eval_offset + } + proc _cmdtrace_enterstep {vname target args} { + #note: we get apparent duplicate callbacks when resolving ensembles. + #e.g {string range $x 1 2} will result in enterstep callback being called twice + #whereas {tcl::string::range $x 1 2} will only callback once + #Unknown if this is a bug or a feature - it does give possible indication of minor overhead when using ensemble form (at least during trace operation) + #(presumably there is no difference when byte compiled) + + #puts " --------------> $args <-----------" + variable _cmdtrace_disabled + if {$_cmdtrace_disabled} return + + variable tinfo + if {[::tcl::info::level] != [::tcl::dict::get $tinfo($target) level]} { + #There are often a *huge* number of subcalls. Can easily be millions, so even emitting a dot with nonewline can be overwhelming. + #uncomment for debug on procs which don't have extensive subcalls. + #puts -nonewline stdout . + #puts -nonewline stderr " $args" + ::tcl::dict::incr tinfo($target) subcmds + return + } + + + set callinfo [::tcl::info::frame -2] + #call to _cmdtrace_enterstep at level -1 + + #----------------------------------------------------------------------------------------------------------------- + #traces are still in place at this point for $target - but according to trace documentation are disabled + # (they still show in 'trace info execution $target' output) + #NOTE however that traces for other targets will still run on anything we do here. + #We don't seem to be able to stop the callbacks - but we can flag with _cmdtrace_disabled until were done here. + #--------------------------------------------------- + #Note that in an environment with channel transforms - even a basic puts to stderr/stdout may invoke a slew of commands + #--------------------------------------------------- + set _cmdtrace_disabled true + #----------------------------------------------------------------------------------------------------------------- + #make sure to re-enable at each return point + + + set type [::tcl::dict::get $callinfo type] + if {[dict exists $callinfo proc]} { + upvar $vname linedict + if {[dict get $callinfo proc] eq $target} { + set prevline [dict get $linedict $target eval_base] + if {[catch { + set traceline [dict get $callinfo line] + }]} { + #eg cmd {tcl::mathfunc::sqrt 100} + puts "No line info for call: $callinfo" + set tinfo(disabled) false + return + } + switch -- $type { + proc { + set line $traceline + dict set linedict $target eval_base $traceline + dict set linedict $target eval_offset 1 + puts " step type: proc traceline:$traceline ** $args" + #puts "** $callinfo" + if {[dict exists $callinfo cmd]} { + #set cmd [string trim [dict get $callinfo cmd]] ;#raw 'unexpanded' script from the stack frame + set cmdlist [lindex $args 0] ;#Tcl has parsed the script - expanded form should be a proper list + #dict set linedict $target eval_offset [_cmdtrace_get_eval_offset $cmdlist] + set getoffset [_cmdtrace_get_eval_offset $cmdlist] + if {$getoffset eq "default"} { + set getoffset 1 + } + dict set linedict $target eval_offset $getoffset + } + } + eval { + #Note that trace considers line 1 for any block to be where the first command is found. + #ie *leading* empty lines/comment lines are not counted + #This contrasts with the output of punk::ns::corp - which counts them. + + #eval_base has been set by previous source or proc + #It can also be set by previous eval - *if* a non default offset was returned by _cmdtrace_get_eval_offset + set eval_offset [dict get $linedict $target eval_offset] + set line [expr {$prevline + ($eval_offset-1) + ($traceline-1)}] + #puts "stack-- $callinfo" + puts " step type: eval traceline: $traceline -- " + if {[dict exists $callinfo cmd]} { + #set cmd [string trim [dict get $callinfo cmd]] + set cmdlist [lindex $args 0] + #dict set linedict $target eval_offset [_cmdtrace_get_eval_offset $cmdlist] + set getoffset [_cmdtrace_get_eval_offset $cmdlist] + if {$getoffset ne "default"} { + dict set linedict $target eval_base [expr {$line}] + dict set linedict $target eval_offset [expr {$getoffset}] + puts "-> line:$line new eval_base: [dict get $linedict $target eval_base] new eval_offset [dict get $linedict $target eval_offset]" + } + } + } + source { + #REVIEW - line continuations in source files make this approach problematic! + if {[dict get $tinfo($target) firstline] < 0} { + # make line numbers relative to the start of the proc rather than the file + + #NOTE - the type key is source, the file key is the sourced file, and + # the line key is the line of the first command, + # *not* the first line in the proc! (this means leading comments, empty lines + # will make this line inaccurate as a relative staring point for proc lines. + + #also - source file can have line continuations - which are never reflected in + #info body + #we have to build some sort of logical line map the first time we see the file + + + dict set tinfo($target) firstline $traceline + set pbody [info body $target] + set offset 0 + foreach ln [split $pbody \n] { + incr offset 1 + set ln [string trim $ln] + if {$ln ne "" && [string index $ln 0] ne "#"} { + #assume it's a command - review (what about line continuations in comments in source file?) + break + } + } + dict set tinfo($target) procoffset $offset + } + set line [expr {$traceline - [dict get $tinfo($target) firstline] + [dict get $tinfo($target) procoffset]}] + #set line $traceline + #puts "--line:$line firstline:[dict get $tinfo($target) firstline] poffset:[dict get $tinfo($target) procoffset] $callinfo" + puts " step type: src traceline $traceline line:$line firstline:[dict get $tinfo($target) firstline] poffset:[dict get $tinfo($target) procoffset]" + dict set linedict $target eval_base $line + } + precompiled { + set line $traceline + puts stderr " step type: PRECOMPILED -- $callinfo" + } + default { + #As at tcl9 - there shouldn't be any unknown types and this branch shouldn't be reached. + set line $traceline + puts stderr " step: $type (unexpected) line:$traceline -- $callinfo" + } + } + + if {![dict exists $linedict $target lines $line]} { + dict set linedict $target lines $line [list type $type calls 1] + } else { + set update [dict get $linedict $target lines $line] + dict incr update calls + dict set linedict $target lines $line $update + } + #puts "-- $callinfo" + } else { + puts ">>step type: $type (nontargeted proc)>> $callinfo" + } + } else { + #todo - handle type 'source' and type 'eval' with keys 'method' 'class' (oo) + #puts ------------------------- + #puts ">[dict get $callinfo cmd]" + #puts "enter type: $type -- $callinfo" + } + set _cmdtrace_disabled false + } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::ns::cmdtrace + @cmd -name punk::ns::cmdtrace\ + -summary\ + "Trace command execution."\ + -help\ + "Experimental. + Note that line-continuations in source file + proc definition will make traced line numbers + inaccurate. + Redefine the proc using something like: + + rename procname procname_old + proc procname {args} [info body procname_old] + + and then run the cmdtrace for better results. + + Nested switch statements - traced linenumbers + are dubious when *not* referencing source file. + (inconsistently based on start-of-switch vs + start-of-switcharm script) + Possibly an unreported/unacknowleged + bug in Tcl. + " + @opts + -target -type string -multiple 1 -help\ + "" + -- -type none -help\ + "end of options indicator" + @values -min 1 -max -1 + arg -type any -multiple 1 -optional 0 -help\ + "Elements of cmdline to run. + If no -target values are supplied, + This will also be the target of the + trace." + + }] + } + proc cmdtrace {args} { + package require dictn ;#convenience to allow dictn::incr d {key subkey} + variable tinfo + array unset tinfo + variable _cmdtrace_disabled + set _cmdtrace_disabled false + + set argd [punk::args::parse $args -cache 1 withid ::punk::ns::cmdtrace] + lassign [dict values $argd] leaders opts values received + + set cmdargs [dict get $values arg] + + set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdargs]] + set origin [dict get $cinfo origin] + set arglist [dict get $cinfo args_remaining] + + if {[dict exists $received -target]} { + set targets [dict get $opts -target] + } else { + set targets [list $origin] + } + + upvar ::punk::ns::linedict linedict + set ::punk::ns::linedict [::tcl::dict::create] + + set resolved_targets [list] + foreach tgt $targets { + set tgt_info [uplevel 1 [list ::punk::ns::cmdinfo {*}$tgt]] + set tgt_cmd [dict get $tgt_info origin] + set tgt_type [dict get $tgt_info cmdtype] + set tgt_remaining [dict get $tgt_info args_remaining] + if {[llength $tgt_remaining]} { + if {[dict exists $received -target]} { + error "cmdtrace unable to resolve all parts of given target: '$tgt' to a single command to trace" + } + #don't raise the error when no -target supplied - as our launch command can contain extra arguments + } + lappend resolved_targets $tgt_cmd + ::tcl::dict::set ::punk::ns::linedict $tgt_cmd [::tcl::dict::create eval_base 1 eval_offset 1 lines {} cmdtype $tgt_type successcalls 0 errorcalls 0] + } + + foreach tgt_cmd $resolved_targets { + puts "tracing target: $tgt_cmd whilst running: $origin $arglist" + + trace add execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] + trace add execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] + trace add execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + } + + + try { + uplevel 1 [list $origin {*}$arglist] + } trap {} {errMsg errOptions} { + puts stderr "command error $errMsg" + + } finally { + foreach tgt_cmd $resolved_targets { + trace remove execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] + trace remove execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] + trace remove execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + } + } + + set final_display "" + append final_display [punk::lib::showdict [array get tinfo] */*] + append final_display \n + + #todo - foreach tgt_cmd in resolved_targets? + foreach tgt_cmd $resolved_targets { + set lines [dict get $linedict $tgt_cmd lines] + if {[llength $lines]} { + set procbody [punk::ns::corp -n $tgt_cmd] + dict for {k v} $lines { + set t [dict get $v type] + set c [dict get $v calls] + switch -- $t { + proc - eval { + set procbody [grepstr -r a -highlight {red bold underline} "^\\s*${k}\\s+" $procbody] + } + source { + set procbody [grepstr -r a -highlight {yellow bold underline} "^\\s*${k}\\s+" $procbody] + puts stderr "source $k" + } + default { + #set procbody [grepstr -r a -highlight {cyan bold underline} "^\\s*${k}\\s+" $procbody] + puts stderr "$t $k" + } + } + } + append final_display $procbody \n + } else { + append final_display "No lines to display for $tgt_cmd" \n + } + append final_display "success_calls: [dict get $linedict $tgt_cmd successcalls]" \n + append final_display "error_calls : [dict get $linedict $tgt_cmd errorcalls]" \n + + } + return $final_display + } + proc cmdtracebasic {args} { + variable tinfo + set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$args]] + set origin [dict get $cinfo origin] + set arglist [dict get $cinfo args_remaining] + trace add execution $origin enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $origin] + trace add execution $origin enterstep [list ::punk::ns::dkf_enterstep ::punk::ns::linedict $origin] + try { + uplevel 1 [list $origin {*}$arglist] + } trap {} {errMsg errOptions} { + puts stderr "command error $errMsg" + + } finally { + trace remove execution $origin enterstep [list ::punk::ns::dkf_enterstep ::punk::ns::linedict $origin] + trace remove execution $origin enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $origin] + } + parray tinfo + } + + proc call_frame {} { + puts stdout "\x1b\[93m[info frame -1]\x1b\[m" + } + proc Enterstep_return {target args} { + set d [info frame -2] + #puts $d + if {[dict exists $d cmd]} { + set c [dict get $d cmd] + if {[string match "return *" $c]} { + puts stdout $d + puts stdout $args + } + } + } + proc cmdtracereturn {procname args} { + trace add execution $procname enterstep [list ::punk::ns::Enterstep_return $procname] + try { + uplevel 1 [list $procname {*}$args] + } trap {} {errMsg errOptions} { + puts stderr "command: '$procname' error: $errMsg" + + } finally { + trace remove execution $procname enterstep [list ::punk::ns::Enterstep_return $procname ] + } + } + + variable proc_tracers + proc trace_disable1 {} { + #determine all procs in the call stack above this one + set depth [expr {(-1* [info frame])+1}] + set procs [list] + for {set i -2} {$i > $depth} {incr i -1} { + set f [info frame $i] + if {[dict exists $f proc]} { + set p [dict get $f proc] + if {$p ni $procs} { + lappend procs $p + } + } + } + #puts "procs:------$procs" + set mycaller [dict get [info frame -1] proc] + + variable proc_tracers + dict set proc_tracers $mycaller [list] + foreach procname $procs { + set tracers [trace info execution $procname] + if {[llength $tracers]} { + dict lappend proc_tracers $mycaller [list $procname $tracers] ;#store for re-enabling later + foreach t $tracers { + trace remove execution $procname {*}$t + } + } + } + } + proc trace_disable {} { + #use the regexp {} [...] trick - only runs when non byte-compiled ie in traces + regexp {} [ + #determine all procs in the call stack above this one + set depth [expr {(-1* [info frame])+1}] + set procs [list] + for {set i -2} {$i > $depth} {incr i -1} { + set f [info frame $i] + if {[dict exists $f proc]} { + set p [dict get $f proc] + if {$p ni $procs} { + lappend procs $p + } + } + } + #puts "procs:------$procs" + set mycaller [dict get [info frame -1] proc] + + variable proc_tracers + dict set proc_tracers $mycaller [list] + set removed_tracers [list] + foreach procname $procs { + set tracers [trace info execution $procname] + if {[llength $tracers]} { + #dict lappend proc_tracers $mycaller [list $procname $tracers] ;#store for re-enabling later + set removed [list] + foreach t $tracers { + lassign $t op script + if {$op eq "enterstep"} { + trace remove execution $procname {*}$t + lappend removed $t + } + } + if {[llength $removed]} { + #dict set proc_tracers $mycaller [list $procname $removed] + lappend removed_tracers [list $procname $removed] + } + } + } + dict set proc_tracers $mycaller $removed_tracers + ] + } + proc trace_enable {} { + #this must run when tracing off - as we use it after trace_disable + set mycaller [dict get [info frame -1] proc] + variable proc_tracers + if {[dict exists $proc_tracers $mycaller]} { + puts "tracers: $proc_tracers" + set tracers [dict get $proc_tracers $mycaller] + foreach tracegroup $tracers { + lassign $tracegroup pname tlist + foreach tinfo $tlist { + puts "---> trace add execution $pname $tinfo" + trace add execution $pname {*}$tinfo + } + } + } + } + + proc traced_func1 {} { + trace_disable1 + return "DON'T TRACE ME 1" + } + + proc traced_func2 {} { + trace_disable + return "DON'T TRACE ME 2" + } + proc traced_func3 {} { + trace_disable + puts aaa + trace_enable + puts bbb + return done + } + proc traced_outer {} { + traced_func3 + } + punk::args::define { @id -id ::punk::ns::cmdtype @cmd -name punk::ns::cmdtype -help\ @@ -1686,7 +2965,7 @@ tcl::namespace::eval punk::ns { #it is not desirable to do a partial cmdtype support here proc cmdtype {cmd} { #set cmd [namespace which $cmd] ;#will return empty result for empty string command or command such as :x or any command that doesn't exist - set fqcmd [uplevel 1 [list ::namespace which $cmd]] ;#will resolve for example 'namespace path' reachable commands + set fqcmd [uplevel 1 [list ::tcl::namespace::which $cmd]] ;#will resolve for example 'namespace path' reachable commands if {$fqcmd eq ""} { #e.g ::ns:::x will return empty result from namespace which even if :x is a command in ::ns set where [nsprefix $cmd] @@ -2474,10 +3753,11 @@ tcl::namespace::eval punk::ns { set opts [dict get $argd opts] set origin [dict get $argd values origin] - set ensembleinfo [namespace ensemble configure $origin] + set ensembleinfo [uplevel 1 [list ::tcl::namespace::ensemble configure $origin]] set prefixes [dict get $ensembleinfo -prefixes] - set map [dict get $ensembleinfo -map] - set ns [dict get $ensembleinfo -namespace] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] + set unkhandler [dict get $ensembleinfo -unknown] #review - we can have a combination of commands from -map as well as those exported from -namespace # if and only if -subcommands is specified @@ -2524,7 +3804,7 @@ tcl::namespace::eval punk::ns { } proc nscommands {args} { - set commandns [uplevel 1 [list ::namespace current]] + set commandns [uplevel 1 [list ::tcl::namespace::current]] set commandlist [::list] #color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway #colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed @@ -2576,10 +3856,10 @@ tcl::namespace::eval punk::ns { #info commands can't glob with weird_ns prefix puts ">>> base: $base what: $what" ::set all_ns_commands [nseval_ifexists $base [list apply {{loc what} { - set _all [uplevel 1 [list ::info commands]] + set _all [uplevel 1 [list ::tcl::info::commands]] set _matches [list] foreach _a $_all { - set _c [uplevel 1 [list ::namespace which $_a]] + set _c [uplevel 1 [list ::tcl::namespace::which $_a]] if {[::string match ${loc}::${what} $_c]} { ::lappend _matches $_a } @@ -2627,7 +3907,7 @@ tcl::namespace::eval punk::ns { set search * } } else { - set nscaller [uplevel 1 [list ::namespace current]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] if {[regexp {\*} $tail]} { if {[nsprefix $ns] ne ""} { set targetns [nsjoin $nscaller [nsprefix $ns]] @@ -2656,10 +3936,10 @@ tcl::namespace::eval punk::ns { # the commands that are actually in the namespace are listed first. # This means we can stop processing on the first command for which 'namespace which' shows another namespace. set remaining [nseval_ifexists $targetns [list apply {{loc} { - ::set _visiblecommands [::uplevel 1 [::list ::info commands]] + ::set _visiblecommands [::uplevel 1 [::list ::tcl::info::commands]] ::set _matches [::list] ::foreach _v $_visiblecommands { - ::set _commandns [::uplevel 1 [::list ::namespace which $_v]] + ::set _commandns [::uplevel 1 [::list ::tcl::namespace::which $_v]] ::if {[::string match ${loc}::* $_commandns]} { ::lappend _matches $_v } else { @@ -2723,37 +4003,56 @@ tcl::namespace::eval punk::ns { } #REVIEW! todo - change 'origin' in resultdict to 'next'? #(origin too similar to 'namespace origin' - but we are using it for that as well as alias target) + #TODO - handle interp alias eg interp0 alias ::thread::id ::thread::id without infinite loop proc cmdwhich {querycommand} { - set nscaller [uplevel 1 [list ::namespace current]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] #puts "cmdwhich nscaller: $nscaller" if {[string match ::* $querycommand]} { #absolute - set targetns [nsprefix $querycommand] - set name [nstail $querycommand] - set targetparts [nsparts_cached $targetns] + set cmdparts [nsparts_cached $querycommand] + set name [lindex $cmdparts end] + set targetparts [lrange $cmdparts 0 end-1] + set targetns [join $targetparts ::] + #set targetns [nsprefix $querycommand] + #set name [nstail $querycommand] + #set targetparts [nsparts_cached $targetns] if {[lsearch $targetparts :*] >=0} { # #for an *unwisely* named ns - info commands ${targetns}::* will not work set ns_commands [nscommandlist $targetns] ;#results are tails only set ns_commands_fq [lmap v $ns_commands {string cat $targetns ::$v}] + if {[lsearch -exact $ns_commands_fq $querycommand] >= 0} { + #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths + if {[punk::ns::nsexists $targetns]} { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + } else { + puts stderr "ns $targetns does'nt seem to exist" + set origin $querycommand + set resolved $querycommand + } + } else { + #fully qualified command specified but doesn't exist + set origin $querycommand + set resolved $querycommand + } } else { set ns_commands_fq [info commands ${targetns}::*] ;#results remain fully qualified - } - if {[lsearch -exact $ns_commands_fq $querycommand] >= 0} { - #use nseval_ifexists to avoid creating intermediate namespaces for bogus paths - if {[catch { - set origin [nseval_ifexists $targetns [list ::namespace origin $name]] - set resolved [nseval_ifexists $targetns [list ::namespace which $name]] - } errM]} { - puts stderr "$errM" + if {[lsearch -exact $ns_commands_fq $querycommand] >= 0} { + if {[namespace exists $targetns]} { + set origin [namespace eval $targetns [list ::namespace origin $name]] + set resolved [namespace eval $targetns [list ::namespace which $name]] + } else { + #puts stderr "ns $targetns doesn't seem to exist" + set origin $querycommand + set resolved $querycommand + } + } else { + #fully qualified command specified but doesn't exist set origin $querycommand set resolved $querycommand } - } else { - #fully qualified command specified but doesn't exist - set origin $querycommand - set resolved $querycommand } } else { #relative commandpath @@ -2769,30 +4068,49 @@ tcl::namespace::eval punk::ns { set targetparts [nsparts_cached $targetns] if {[lsearch $targetparts :*] >=0} { #weird ns - set valid_ns [nsexists $targetns] - } else { - set valid_ns [namespace exists $targetns] - } - if {$valid_ns} { - if {[catch { - set origin [nseval_ifexists $targetns [list ::namespace origin $name]] - set resolved [nseval_ifexists $targetns [list ::namespace which $name]] - }]} { - set thiscmd [nsjoin $targetns $name] - #relative querycommand specified - but Tcl didn't find a match in namespace path - #assume global (todo - look for namespace match in auto_index first ?) - set origin ::$name - set resolved ::$name + if {[nsexists $targetns]} { + if {[catch { + set origin [nseval_ifexists $targetns [list ::namespace origin $name]] + set resolved [nseval_ifexists $targetns [list ::namespace which $name]] + }]} { + set thiscmd [nsjoin $targetns $name] + #relative querycommand specified - but Tcl didn't find a match in namespace path + #assume global (todo - look for namespace match in auto_index first ?) + set origin ::$name + set resolved ::$name + } + } else { + #namespace as relative to current doesn't seem to exist + #Tcl would also attempt to resolve as global + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::cmdwhich $querycommand]] + } + + set origin $querycommand + set resolved $querycommand } } else { - #namespace as relative to current doesn't seem to exist - #Tcl would also attempt to resolve as global - if {$nscaller ne "::"} { - return [namespace eval :: [list punk::ns::cmdwhich $querycommand]] - } + if {[namespace exists $targetns]} { + if {[catch { + set origin [namespace eval $targetns [list ::namespace origin $name]] + set resolved [namespace eval $targetns [list ::namespace which $name]] + }]} { + set thiscmd [nsjoin $targetns $name] + #relative querycommand specified - but Tcl didn't find a match in namespace path + #assume global (todo - look for namespace match in auto_index first ?) + set origin ::$name + set resolved ::$name + } + } else { + #namespace as relative to current doesn't seem to exist + #Tcl would also attempt to resolve as global + if {$nscaller ne "::"} { + return [namespace eval :: [list punk::ns::cmdwhich $querycommand]] + } - set origin $querycommand - set resolved $querycommand + set origin $querycommand + set resolved $querycommand + } } } } @@ -2821,9 +4139,14 @@ tcl::namespace::eval punk::ns { } else { #alias may have some curried-in arguments if {[llength $tgt] == 1} { - set whichinfo [uplevel 1 [list cmdwhich $tgt]] - set origin [dict get $whichinfo origin] - set origintype [dict get $whichinfo origintype] + #in child interps - we may legitimately get an *apparent* alias to self + #eg because parent interp called something like: interp0 alias ::thread::id ::thread::id + #make sure we don't perform an infinite loop + if {$tgt ne $resolved} { + set whichinfo [uplevel 1 [list ::punk::ns::cmdwhich $tgt]] + set origin [dict get $whichinfo origin] + set origintype [dict get $whichinfo origintype] + } } else { set origin $tgt ;#multiword origin set origintype script @@ -2909,8 +4232,14 @@ tcl::namespace::eval punk::ns { set queryargs_remaining [lrange $queryargs 1 end] } create { - set constructorinfo [info class constructor $origin] - set arglist [lindex $constructorinfo 0] + if {![catch { + set constructorinfo [info class constructor $origin] + }]} { + set arglist [lindex $constructorinfo 0] + } else { + set arglist [list] + } + set argdef [punk::lib::tstr -return string { @id -id "(autodef)${$origin} create" @cmd -name "${$origin} create"\ @@ -3131,17 +4460,29 @@ tcl::namespace::eval punk::ns { ensemble { #review #todo - check -unknown + + + set ensembleinfo [namespace ensemble configure $origin] + set parameters [dict get $ensembleinfo -parameters] + set prefixes [dict get $ensembleinfo -prefixes] + set map [dict get $ensembleinfo -map] + set ns [dict get $ensembleinfo -namespace] + set unkhandler [dict get $ensembleinfo -unknown] #if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. #presumably -choiceprefix should be zero in that case?? + #however - the unknown handler might not add any new subcommands, it may just be for custom error presentation + #see also punk::lib::ensemble::extend - which is based on the wiki 'ensemble extend' command. + #This extension via -unknown mechanism might be common in the wild. + - set ensembleinfo [namespace ensemble configure $origin] - set parameters [dict get $ensembleinfo -parameters] - set prefixes [dict get $ensembleinfo -prefixes] - set map [dict get $ensembleinfo -map] - set ns [dict get $ensembleinfo -namespace] #review - we can have a combination of commands from -map as well as those exported from -namespace # if and only if -subcommands is specified + #---------------------- + #Documentation for namespace states that "when non-empty, this option lists exactly what subcommands are in the ensemble" + #(When there is an -unknown handler that provides additional subcommands, this isn't effectively true) + #---------------------- + #note that an explicit -subcommands list set subcommand_dict [dict create] set commands [list] @@ -3201,7 +4542,7 @@ tcl::namespace::eval punk::ns { #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] #tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] #subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") - tailcall generate_autodef {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] + tailcall generate_autodef {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] } } } @@ -3239,8 +4580,17 @@ tcl::namespace::eval punk::ns { } } + set restrict "" + set help "" + if {$unkhandler ne ""} { + set restrict [list -choicerestricted 0] + set help [list -help "[punk::ansi::a+ bold]Warning: -unknown handler exists. Not all subcommands may be displayed.[punk::ansi::a]"] + } + + #set vline [list subcommand {*}$restrict {*}$help -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] + #arg to force synopsis -return summary ? + set vline [punk::args::ensemble_subcommands_definition -columns 2 $origin] - set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] set autoid "(autodef)$origin" puts "ENSEMBLE auto def $autoid (generate_autodef)" #A namespace can contain spaces, so an ensemble command can contain spaces. We must quote the -id value in the autodef @@ -3366,7 +4716,7 @@ tcl::namespace::eval punk::ns { variable cmdinfo_reducerid set reduce ::punk::ns::reducer[incr cmdinfo_reducerid] - set nscaller [uplevel 1 [list ::namespace current]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] set init [coroutine $reduce cmd_traverse $nscaller $fid {*}$cmdlist] #puts stderr "init: $init" @@ -3455,6 +4805,11 @@ tcl::namespace::eval punk::ns { #if {$argc == 1} { # return [list 1 $origin {} [lrange $args 1 end] $docid] #} else { + + if {$docid ne "" && ![llength [lrange $args 1 end]]} { + return [list 0a $origin {} {} $docid] + } + set origin [yield [list 0 $origin {} [lrange $args 1 end] $docid]] set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $cmd]] set origin [dict get $whichinfo origin] @@ -3471,72 +4826,75 @@ tcl::namespace::eval punk::ns { } if {$docid eq ""} { #review - orgintype classmethod, objectmethod? - if {$origintype eq "script"} { - #a 'script' is essentially an alias-target to a command with curried args - #There will not be documentation or a 'command' matching the entire script, but there may be for the target command (first word of script) - set scriptcmdraw [lindex $origin 0] - set scriptinfo [namespace eval $ns [list punk::ns::cmdwhich $scriptcmdraw]] - set scriptcmd [dict get $scriptinfo which] - set scriptargs [lrange $origin 1 end] - #ledit args -1 -1 {*}$scriptargs ;#prepend - set args [linsert $args 1 {*}$scriptargs] - #JJJ review - #set resolvedargs $scriptargs - punk::args::update_definitions [list [namespace qualifiers $scriptcmd]] - if {![punk::args::id_exists $scriptcmd] && ![dict exists $autodefined $scriptcmd]} { - namespace eval $ns [list punk::ns::generate_autodef $scriptcmd] - dict set autodefined $origin 1 - #if the scriptcmd is itself an alias - no autodef will be generated for it - } - if {[punk::args::id_exists $scriptcmd]} { - set docid $scriptcmd - } elseif {[punk::args::id_exists "(autodef)$scriptcmd"]} { - set docid (autodef)$scriptcmd - } else { + switch -- $origintype { + script { + #a 'script' is essentially an alias-target to a command with curried args + #There will not be documentation or a 'command' matching the entire script, but there may be for the target command (first word of script) + set scriptcmdraw [lindex $origin 0] + set scriptinfo [namespace eval $ns [list punk::ns::cmdwhich $scriptcmdraw]] + set scriptcmd [dict get $scriptinfo which] + set scriptargs [lrange $origin 1 end] + #ledit args -1 -1 {*}$scriptargs ;#prepend + set args [linsert $args 1 {*}$scriptargs] + #JJJ review + #set resolvedargs $scriptargs + punk::args::update_definitions [list [namespace qualifiers $scriptcmd]] + if {![punk::args::id_exists $scriptcmd] && ![dict exists $autodefined $scriptcmd]} { + namespace eval $ns [list punk::ns::generate_autodef $scriptcmd] + dict set autodefined $origin 1 + #if the scriptcmd is itself an alias - no autodef will be generated for it + } + if {[punk::args::id_exists $scriptcmd]} { + set docid $scriptcmd + } elseif {[punk::args::id_exists "(autodef)$scriptcmd"]} { + set docid (autodef)$scriptcmd + } else { - set docid "" + set docid "" + } + set origin $scriptcmd } - set origin $scriptcmd - } elseif {$origintype eq "alias"} { - #JJJ2 - #puts "==> examining alias $origin" - if {[string match >* [nstail $origin]] && [package provide pattern] ne ""} { - if {![catch {pattern::which_alias $origin} alias_target]} { - #review - todo? - set patternorigin [lindex $alias_target 0] - #set queryargs [list {*}[lrange $alias_target 1 end] {*}$queryargs] - set args [linsert $args 1 {*}[lrange $alias_target 1 end]] - #set resolvedargs [lrange $alias_target 1 end] - punk::args::update_definitions [list [namespace qualifiers $patternorigin]] - if {![punk::args::id_exists $patternorigin] && ![dict exists $autodefined $patternorigin]} { - namespace eval $ns [list punk::ns::generate_autodef $patternorigin] - dict set autodefined $origin 1 - #if the patternorigin is itself an alias - no autodef will be generated for it - } - if {[punk::args::id_exists $patternorigin]} { - set docid $patternorigin - } elseif {[punk::args::id_exists "(autodef)$patternorigin"]} { - set docid (autodef)$patternorigin - } else { + alias { + #JJJ2 + #puts "==> examining alias $origin" + if {[string match >* [nstail $origin]] && [package provide pattern] ne ""} { + if {![catch {pattern::which_alias $origin} alias_target]} { + #review - todo? + set patternorigin [lindex $alias_target 0] + #set queryargs [list {*}[lrange $alias_target 1 end] {*}$queryargs] + set args [linsert $args 1 {*}[lrange $alias_target 1 end]] + #set resolvedargs [lrange $alias_target 1 end] + punk::args::update_definitions [list [namespace qualifiers $patternorigin]] + if {![punk::args::id_exists $patternorigin] && ![dict exists $autodefined $patternorigin]} { + namespace eval $ns [list punk::ns::generate_autodef $patternorigin] + dict set autodefined $origin 1 + #if the patternorigin is itself an alias - no autodef will be generated for it + } + if {[punk::args::id_exists $patternorigin]} { + set docid $patternorigin + } elseif {[punk::args::id_exists "(autodef)$patternorigin"]} { + set docid (autodef)$patternorigin + } else { - set docid "" + set docid "" + } + set origin $patternorigin } - set origin $patternorigin } } - - } else { - punk::args::update_definitions [list [namespace qualifiers $origin]] - if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { - namespace eval $ns [list punk::ns::generate_autodef $origin] - dict set autodefined $origin 1 - } - if {[punk::args::id_exists $origin]} { - set docid $origin - } elseif {[punk::args::id_exists "(autodef)$origin"]} { - set docid (autodef)$origin - } else { - set docid "" + default { + punk::args::update_definitions [list [namespace qualifiers $origin]] + if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { + namespace eval $ns [list punk::ns::generate_autodef $origin] + dict set autodefined $origin 1 + } + if {[punk::args::id_exists $origin]} { + set docid $origin + } elseif {[punk::args::id_exists "(autodef)$origin"]} { + set docid (autodef)$origin + } else { + set docid "" + } } } } @@ -3594,6 +4952,14 @@ tcl::namespace::eval punk::ns { } if {$docid_exists} { + + #review - get_spec needs to resolve if @dynamic + #we don't really need the spec if we have no queryargs + if {![llength $queryargs]} { + return [list X $origin $resolvedargs $queryargs_untested $docid] + } + + set spec [punk::args::get_spec $docid] #--------------------------------------------------------------------------- set form_names [dict get $spec form_names] @@ -3856,7 +5222,7 @@ tcl::namespace::eval punk::ns { cmditem -multiple 1 -optional 0 } proc forms {args} { - set argd [::punk::args::parse $args withid ::punk::ns::forms] + set argd [::punk::args::parse $args -cache 1 withid ::punk::ns::forms] set cmdwords [dict get $argd values cmditem] set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context #set id [dict get $resolveinfo origin] @@ -3877,7 +5243,7 @@ tcl::namespace::eval punk::ns { cmditem -multiple 1 -optional 0 } proc eg {args} { - set argd [::punk::args::parse $args withid ::punk::ns::eg] + set argd [::punk::args::parse $args -cache 1 withid ::punk::ns::eg] set cmdwords [dict get $argd values cmditem] set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context #set resolved_id [dict get $resolveinfo origin] @@ -3906,7 +5272,7 @@ tcl::namespace::eval punk::ns { cmditem -multiple 1 -optional 0 } proc synopsis {args} { - set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set argd [::punk::args::parse $args -cache 1 withid ::punk::ns::synopsis] set form [dict get $argd opts -form] set opt_return [dict get $argd opts -return] set cmdwords [dict get $argd values cmditem] @@ -3932,6 +5298,9 @@ tcl::namespace::eval punk::ns { set excess [expr {[llength $unresolved_args] - [llength $synopsis_args]}] } + #note we can still get a synopsis for a cmdtype value of 'notfound' if there is a docid for it + + #TODO! better result for subcommand prefix match vs complete mismatch vs undocumented match!!! if {$doc_id eq ""} { set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] @@ -3989,7 +5358,7 @@ tcl::namespace::eval punk::ns { } } proc synopsis_raw {args} { - set argd [::punk::args::parse $args withid ::punk::ns::synopsis] + set argd [::punk::args::parse $args -cache 1 withid ::punk::ns::synopsis] set form [dict get $argd opts -form] set cmdwords [dict get $argd values cmditem] set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context @@ -3998,7 +5367,6 @@ tcl::namespace::eval punk::ns { } punk::args::define { - @dynamic @id -id ::punk::ns::cmdhelp @cmd -name punk::ns::cmdhelp\ -summary\ @@ -4044,8 +5412,8 @@ tcl::namespace::eval punk::ns { Multiple subcommands can be supplied if ensembles are further nested" } proc cmdhelp {args} { - set nscaller [uplevel 1 [list ::namespace current]] - lassign [dict values [punk::args::parse $args withid ::punk::ns::cmdhelp]] leaders opts values received + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + lassign [dict values [punk::args::parse $args -cache 1 withid ::punk::ns::cmdhelp]] leaders opts values received if {![dict exists $received -scheme]} { #dict set opts -scheme info set scheme_received 0 @@ -4070,14 +5438,14 @@ tcl::namespace::eval punk::ns { } set nextopts [dict remove $opts -grepstr] #JJJ - set whichinfo [uplevel 1 [list cmdwhich $querycommand]] + set whichinfo [uplevel 1 [list ::punk::ns::cmdwhich $querycommand]] set rootorigin [dict get $whichinfo origin] set which [dict get $whichinfo which] set rootorigintype [dict get $whichinfo origintype] set whichtype [dict get $whichinfo whichtype] - set rootinfo [uplevel 1 [list cmdinfo $which]] + set rootinfo [uplevel 1 [list ::punk::ns::cmdinfo $which]] set rootdoc [dict get $rootinfo docid] #NOTE - we can get 'args_remaining' due to cmdinfo resolving to a curried alias target set args_remaining [dict get $rootinfo args_remaining] @@ -4104,9 +5472,9 @@ tcl::namespace::eval punk::ns { } if {$opt_grepstr ne ""} { if {[llength $opt_grepstr] == 1} { - set result [punk::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] + set result [punk::ansi::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] } else { - set result [punk::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] + set result [punk::ansi::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] } } return $result @@ -4151,7 +5519,7 @@ tcl::namespace::eval punk::ns { #----------------------------------------------------------------------------------------------------------------------------- #puts "-----> rootorigin $rootorigin queryargs $queryargs" - set cinfo [uplevel 1 [list cmdinfo $rootorigin {*}$queryargs]] + set cinfo [uplevel 1 [list ::punk::ns::cmdinfo $rootorigin {*}$queryargs]] set origin [dict get $cinfo origin] @@ -4166,13 +5534,12 @@ tcl::namespace::eval punk::ns { set scriptcmd [lindex $origin 0] set nextqueryargs [list {*}$scriptargs {*}$args_remaining] #puts stderr "cmdhelp $nextopts $scriptcmd $args_remaining" - return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts $scriptcmd {*}$nextqueryargs]] + return [uplevel 1 [list ::punk::ns::cmdhelp {*}$nextopts $scriptcmd {*}$nextqueryargs]] } } if {$origindoc ne ""} { - - - if {[catch {punk::args::parse $args_remaining -form $opt_form -errorstyle $estyle withid $origindoc} parseresult]} { + #important not to use "-cache 1" for this parse - need to reflect dynamically updated ensembles etc + if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $estyle withid $origindoc} parseresult]} { if {$opt_return eq "tableobject"} { set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] } else { @@ -4187,9 +5554,9 @@ tcl::namespace::eval punk::ns { } if {$opt_grepstr ne ""} { if {[llength $opt_grepstr] == 1} { - set result [punk::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] + set result [punk::ansi::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] } else { - set result [punk::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] + set result [punk::ansi::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] } } return $result @@ -5126,9 +6493,9 @@ tcl::namespace::eval punk::ns { # } # if {[llength $grepstr] != 0} { # if {[llength $grepstr] == 1} { - # return [punk::grepstr -no-linenumbers -highlight red [lindex $grepstr 0] $msg] + # return [punk::ansi::grepstr -no-linenumbers -highlight red [lindex $grepstr 0] $msg] # } else { - # return [punk::grepstr -no-linenumbers -highlight [lrange $grepstr 1 end] [lindex $grepstr 0] $msg] + # return [punk::ansi::grepstr -no-linenumbers -highlight [lrange $grepstr 1 end] [lindex $grepstr 0] $msg] # } # } # return $msg @@ -5167,6 +6534,11 @@ tcl::namespace::eval punk::ns { " @opts #todo - make definition @dynamic - load highlighters as functions? + -n|--line-number -type none -help\ + "Each body line is preceded by its line number, starting at line 1." + -ranges -type indexset -default "0..end" -help\ + "comma delimited set of line ranges. + " -syntax -type string -typesynopsis "none|basic" -default basic -choices {none basic}\ -choicelabels { none\ @@ -5191,9 +6563,12 @@ tcl::namespace::eval punk::ns { }] } proc corp {args} { - set argd [punk::args::parse $args withid ::punk::ns::corp] - set path [dict get $argd values commandname] - set syntax [dict get $argd opts -syntax] + set argd [punk::args::parse $args -cache 1 withid ::punk::ns::corp] + lassign [dict values $argd] leaders opts values received + set path [dict get $values commandname] + set syntax [dict get $opts -syntax] + set ranges [dict get $opts -ranges] + set do_ln [expr {[dict exists $received --line-number]}] #thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp #Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) if {[info exists punk::console::tabwidth]} { @@ -5205,41 +6580,51 @@ tcl::namespace::eval punk::ns { #set indent [string repeat " " $tw] ;#A more sensible default for code - review if {[info exists ::auto_index($path)]} { - set body "\n${indent}#corp# auto_index $::auto_index($path)" + set infoheader "\n${indent}#corp# auto_index $::auto_index($path)" } else { - set body "" + set infoheader "" } #we want to handle edge cases of commands such as "" or :x #various builtins such as 'namespace which' won't work - if {[string match ::* $path]} { - set targetns [nsprefix $path] - set name [nstail $path] - } else { - set thispath [uplevel 1 [list ::nsthis $path]] - set targetns [nsprefix $thispath] - set name [nstail $thispath] + #if {[string match ::* $path]} { + # set targetns [nsprefix $path] + # set name [nstail $path] + #} else { + # set thispath [uplevel 1 [list ::nsthis $path]] + # set targetns [nsprefix $thispath] + # set name [nstail $thispath] + #} + set cinfo [uplevel 1 [list punk::ns::cmdwhich $path]] + set origin [dict get $cinfo origin] + set resolved [dict get $cinfo which] + + set targetcmd $resolved + set targetns [nsprefix $targetcmd] + set name [nstail $targetcmd] + #review - whether relative or absolute, ns might not exist + #if we 'namespace eval' we could create pollution in the form of a new namespace + if {![punk::ns::nsexists $targetns]} { + #JJJ + error "no such namespace $targetns" } - #puts stderr "corp upns:$upns" - #set name [string trim $name :] - #set origin [namespace origin ${upns}::$name] - set origin [nseval $targetns [list ::namespace origin $name]] - set resolved [nseval $targetns [list ::namespace which $name]] + #set origin [nseval $targetns [list ::namespace origin $name]] + #set resolved [nseval $targetns [list ::namespace which $name]] #A renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! #set iproc [info procs $origin] ;#This will find empty-string command as ::ns:: but miss finding proc ":x" as ::ns:::x set iproc [nsjoin $targetns [nseval $targetns [list ::info procs $name]]] - if {$origin ni $iproc} { + if {$targetcmd ni $iproc} { #It seems an interp alias of "::x"" behaves the same as "x" #But we can't create both at the same time - and they have to be queried by the exact name. #So we query for alias with and without leading :: - set alias_qualified [interp alias {} [string trim $origin :]] - set alias_unqualified [interp alias {} $origin] + set alias_qualified [interp alias {} [string trim $targetcmd :]] + set alias_unqualified [interp alias {} $targetcmd] if {[string length $alias_qualified] && [string length $alias_unqualified]} { #our assumptions are wrong.. change in tcl version? - puts stderr "corp: Found alias for unqualified name:'[string trim $origin :]' and qualified name: '$origin' - unexpected (assumed impossible as at Tcl 8.6)" + puts stderr "corp: Found alias for unqualified name:'[string trim $targetcmd :]' and qualified name: '$targetcmd' - unexpected (assumed impossible as at Tcl 8.6)" if {$alias_qualified ne $alias_unqalified} { } else { @@ -5257,13 +6642,14 @@ tcl::namespace::eval punk::ns { return [list alias {*}$alias] } } - if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { - append body \n "${indent}#corp# namespace origin $origin" + if {[nsprefix $targetcmd] ne [nsprefix [nsjoin ${targetns} $name]]} { + append infoheader \n "${indent}#corp# namespace origin $origin" } - if {$body ne "" && [string index $body end] ne "\n"} { - append body \n + if {$infoheader ne "" && [string index $infoheader end] ne "\n"} { + append infoheader \n } + set body "" if {![catch {package require textutil::tabify} errpkg]} { #set bodytext [info body $origin] set bodytext [nseval $targetns [list ::info body $name]] @@ -5275,6 +6661,8 @@ tcl::namespace::eval punk::ns { #relevant test test::punk::ns SUITE ns corp.test corp_leadingcolon_functionname append body [nseval $targetns [list ::info body $name]] } + + set argl {} set argnames [nseval $targetns [list ::info args $name]] foreach a $argnames { @@ -5296,22 +6684,50 @@ tcl::namespace::eval punk::ns { } #list proc [nsjoin ${targetns} $name] $argl $body #todo - load highlighters as functions from somewhere + set is_highlighted 1 ;# default assumption + set lnc [punk::ansi::a+ term-73] + set lnr "\x1b\[m" switch -- $syntax { basic { #rudimentary colourising only - set argl [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl] - set body [punk::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. - set body [punk::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon - #set body [punk::grepstr -return all -highlight tk-darkcyan {\{|\}} $body] - set body [punk::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body] - set body [punk::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body] - set body [punk::grepstr -return all -highlight tk-orange {\[|\]} $body] - #ansi colourised items in list format may not always have desired string representation (list escaping can occur) - #return as a string - which may not be a proper Tcl list! - return "proc $resolved {$argl} {\n$body\n}" - } - } - list proc $resolved $argl $body + set argl [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl] + + set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. + set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon + + ##set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $body] + + set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body] + set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body] + set body [punk::ansi::grepstr -return all -highlight tk-orange {\[|\]} $body] + } + default { + set is_highlighted 0 + set lnc "" + set lnr "" + } + } + if {$do_ln} { + set linebody "" + set n 0 + set lines [split $body \n] + set linecount [llength $lines] + set w [string length $linecount] + foreach ln $lines { + incr n + append linebody "$lnc[format %${w}s $n]$lnr $ln" \n + } + set body [string range $linebody 0 end-1] + #set body $linebody + } + + if {$is_highlighted} { + #ansi colourised items in list format may not always have desired string representation (list escaping can occur) + #return as a string - which may not be a proper Tcl list! + return "proc $resolved {$argl} {\n$infoheader$body\n}" + } else { + list proc $resolved $argl $infoheader$body + } } @@ -5687,14 +7103,14 @@ tcl::namespace::eval punk::ns { if {$ver eq ""} { error "Namespace $ns not found. No package version found." } else { - set out "(no package namespace found) remaining in [uplevel 1 {namespace current}]" + set out "(no package namespace found) remaining in [uplevel 1 {::tcl::namespace::current}]" append out \n $ver return $out } } return $out } - interp alias "" use "" punk::ns::pkguse + #interp alias "" use "" punk::ns::pkguse punk::args::define { @id -id ::punk::ns::nsimport_noclobber @@ -5719,7 +7135,7 @@ tcl::namespace::eval punk::ns { lassign [dict values [punk::args::parse $args withid ::punk::ns::nsimport_noclobber]] leaders opts values received set sourcepatterns [dict get $values sourcepattern] - set nscaller [uplevel 1 {namespace current}] + set nscaller [uplevel 1 {::tcl::namespace::current}] if {![dict exists $received -targetnamespace]} { set target_ns $nscaller } else { @@ -5840,8 +7256,9 @@ tcl::namespace::eval punk::ns { interp alias {} nslist_dict {} punk::ns::nslist_dict interp alias {} cmdwhich {} punk::ns::cmdwhich - interp alias {} cmdinfo {} punk::ns::cmdinfo - interp alias {} cmdtype {} punk::ns::cmdtype + interp alias {} cmdinfo {} punk::ns::cmdinfo + interp alias {} cmdtype {} punk::ns::cmdtype + interp alias {} cmdtrace {} punk::ns::cmdtrace #extra slash implies more verbosity (ie display commands instead of just nschildren) interp alias {} n/ {} punk::ns::ns/ / @@ -5862,7 +7279,6 @@ tcl::namespace::eval punk::ns { interp alias {} corp {} punk::ns::corp interp alias {} i {} punk::ns::cmdhelp - interp alias {} j {} punk::ns::arginfo ;#todo - make obsolete #An example of using punk::args in a pipeline punk::args::define { diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index ed8e932a..34235e3c 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -452,7 +452,7 @@ proc repl::start {inchan args} { #punk::repl::codethread::running is required whether safe or not. interp eval code { namespace eval ::punk::repl::codethread {} - set ::punk::repl::codethread::running 1 + set ::punk::repl::codethread::is_running 1 namespace eval ::punk::ns::ns_current {} set ::punk::ns::ns_current %ns1% } @@ -1616,7 +1616,11 @@ proc repl::repl_handler {inputchan prompt_config} { #repl_handler_checkchannel $inputchan chan event $inputchan readable {} set reading 0 - thread::send -async $::repl::codethread {set ::punk::repl::codethread::running 0} + #target is the 'main' interp in codethread. + #(note bug where thread::send goes to code interp, but thread::send -async goes to main interp) + # https://core.tcl-lang.org/thread/tktview/0de73f04c7ce188b13a4 + + thread::send -async $::repl::codethread {set ::punk::repl::codethread::is_running 0} ;#to main interp of codethread if {$::tcl_interactive} { rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" #rputs stderr "\n|repl> ctrl-c EOF on $inputchan." @@ -2609,7 +2613,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #after any external command - raw mode as the console sees it can be disabled - #set it to match current state of the tsv + #set it to match current state of the tsv if {[tsv::get console is_raw]} { if {$::tcl_platform(platform) eq "windows"} { #review @@ -2940,7 +2944,8 @@ namespace eval repl { thread::send %replthread% [list punk::repl::editbuf {*}$args] } proc escapeeval {script} { - eval $script + #eval $script + uplevel #0 $script } proc do_after {args} { if {[llength $args] == 1} { @@ -3050,7 +3055,7 @@ namespace eval repl { namespace ensemble create namespace ensemble configure [namespace current] -unknown ::repl::interphelpers::repl_ensemble_unknown variable replinfo - set replinfo [dict create thread %replthread% interp %replthread_interp%] + set replinfo [dict create thread %replthread% interp %replthread_interp% codethread [thread::id]] proc thread {} { return %replthread% } @@ -3075,7 +3080,7 @@ namespace eval repl { } #autodoc for ensemble, or a punk::args::define doc here - #will not alow discovery of the documentation from within an interp that has + #will not alow discovery of the documentation from within an interp that has #only alias access to this - as the docs (indeed even the namespace) won't #exist in the calling interp. namespace eval ::repl::interphelpers::subshell_ensemble { @@ -3267,6 +3272,7 @@ namespace eval repl { textutil\ punk::encmime\ punk::char\ + punk::trie\ punk::ansi\ punk::lib\ overtype\ @@ -3353,7 +3359,7 @@ namespace eval repl { code alias ::shellfilter::stack ::shellfilter::stack #code alias ::punk::lib::set_valcopy ::punk::lib::set_valcopy #code alias ::aliases ::punk::ns::aliases - code alias ::punk::ns::aliases ::punk::ns::aliases + #code alias ::punk::ns::aliases ::punk::ns::aliases namespace eval ::codeinterp {} code alias ::md5::md5 ::repl::interphelpers::md5 @@ -3445,6 +3451,13 @@ namespace eval repl { interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)] interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)] + set codehidden [code hidden] + #interp alias is available in safe - so it seems unreasonable to disallow 'info cmdtype' + if {"tcl:info:cmdtype" in $codehidden} { + code eval {rename ::tcl::info::cmdtype ""} + code expose tcl:info:cmdtype + code eval {rename tcl:info:cmdtype ::tcl::info::cmdtype} + } code alias ::fconfigure ::repl::interphelpers::fconfigure ;#needed for shellfilter @@ -3578,7 +3591,7 @@ namespace eval repl { } } if {$libunknown ne ""} { - uplevel 1 [list source $libunknown] + uplevel 1 [list ::source $libunknown] if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} { puts "error initialising punk::libunknown\n$errM" } @@ -3689,6 +3702,10 @@ namespace eval repl { code alias exit ::repl::interphelpers::quit + code alias ::thread::id ::thread::id + #REVIEW + #code alias ::thread::send ::thread::send + #experiment #code alias ::shellfilter::stack ::shellfilter::stack diff --git a/src/modules/punk/repl/codethread-999999.0a1.0.tm b/src/modules/punk/repl/codethread-999999.0a1.0.tm index a0fbb998..51135a6e 100644 --- a/src/modules/punk/repl/codethread-999999.0a1.0.tm +++ b/src/modules/punk/repl/codethread-999999.0a1.0.tm @@ -62,44 +62,6 @@ package require punk::config #*** !doctools #[section API] -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# oo::class namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#tcl::namespace::eval punk::repl::codethread::class { - - #*** !doctools - #[subsection {Namespace punk::repl::codethread::class}] - #[para] class definitions - - #if {[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 ---}] - - #} -#} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -109,7 +71,7 @@ tcl::namespace::eval punk::repl::codethread { tcl::namespace::export * variable replthread variable replthread_cond - variable running 0 + variable is_running 0 variable output_stdout "" variable output_stderr "" @@ -126,19 +88,6 @@ tcl::namespace::eval punk::repl::codethread { #[list_begin definitions] - - #proc sample1 {p1 n args} { - # #*** !doctools - # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 - # #[para] Arguments: - # # [list_begin arguments] - # # [arg_def tring p1] A description of string argument p1. - # # [arg_def integer n] A description of integer argument n. - # # [list_end] - # return "ok" - #} - variable run_command_cache #Use interp exists instead.. @@ -149,9 +98,10 @@ tcl::namespace::eval punk::repl::codethread { #} proc is_running {} { - variable running - return $running + variable is_running + return $is_running } + proc runscript {script} { #puts stderr "->runscript" @@ -170,12 +120,14 @@ tcl::namespace::eval punk::repl::codethread { puts stderr "runscript is meant to be called from the parent repl thread via a thread::send to the codethread" return } - interp eval code [list set ::punk::repl::codethread::output_stdout ""] - interp eval code [list set ::punk::repl::codethread::output_stderr ""] - set outstack [list] set errstack [list] set config_running [::punk::config::configure running] + + interp eval code { + set ::punk::repl::codethread::output_stdout "" + set ::punk::repl::codethread::output_stderr "" + } if {[string length [dict get $config_running color_stdout_repl]] && [interp eval code punk::console::colour]} { lappend outstack [interp eval code [list ::shellfilter::stack add stdout ansiwrap -settings [list -colour [dict get $running_config color_stdout_repl]]]] } @@ -269,45 +221,7 @@ tcl::namespace::eval punk::repl::codethread { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::repl::codethread::lib { - tcl::namespace::export * - tcl::namespace::path [tcl::namespace::parent] - #*** !doctools - #[subsection {Namespace punk::repl::codethread::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::repl::codethread::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section Internal] -tcl::namespace::eval punk::repl::codethread::system { - #*** !doctools - #[subsection {Namespace punk::repl::codethread::system}] - #[para] Internal functions that are not part of the API - - - -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::repl::codethread [tcl::namespace::eval punk::repl::codethread { variable pkg punk::repl::codethread diff --git a/src/modules/punk/safe-999999.0a1.0.tm b/src/modules/punk/safe-999999.0a1.0.tm index a0ed7ad1..cc739edf 100644 --- a/src/modules/punk/safe-999999.0a1.0.tm +++ b/src/modules/punk/safe-999999.0a1.0.tm @@ -334,7 +334,8 @@ tcl::namespace::eval punk::safe { #REVIEW set autoPath {} } - set argd [punk::args::get_by_id ::punk::safe::interpCreate $args] + #set argd [punk::args::get_by_id ::punk::safe::interpCreate $args] + set argd [punk::args::parse $args withid ::punk::safe::interpCreate] set child [dict get $argd leaders child] set autoPath [dict get $argd opts -autoPath] punk::safe::lib::RejectExcessColons $child @@ -355,7 +356,8 @@ tcl::namespace::eval punk::safe { if {$AutoPathSync} { set autoPath {} } - set argd [punk::args::get_by_id ::punk::safe::interpIC $args] + #set argd [punk::args::get_by_id ::punk::safe::interpIC $args] + set argd [punk::args::parse $args withid ::punk::safe::interpIC] set child [dict get $argd leaders child] set autoPath [dict get $argd opts -autoPath] if {![::interp exists $child]} { @@ -405,7 +407,8 @@ tcl::namespace::eval punk::safe { # we know that "child" is our given argument because it also # checks for the "-help" option. #TODO! - set argd [punk::args::get_by_id ::punk::safe::interpIC $args] + #set argd [punk::args::get_by_id ::punk::safe::interpIC $args] + set argd [punk::args::parse $args withid ::punk::safe::interpIC] set child [dict get $argd leaders child] CheckInterp $child @@ -469,7 +472,8 @@ tcl::namespace::eval punk::safe { } default { #return -code error "unknown flag $name. Known options: $opt_names" - punk::args::get_by_id ::punk::safe::interpIC [list $child $arg] + #punk::args::get_by_id ::punk::safe::interpIC [list $child $arg] + punk::args::parse [list $child $arg] withid ::punk::safe::interpIC } } } @@ -477,7 +481,9 @@ tcl::namespace::eval punk::safe { # Otherwise we want to parse the arguments like init and create did #set Args [::tcl::OptKeyParse ::safe::interpIC $args] - set argd [punk::args::get_by_id ::punk::safe::interpIC $args] + #set argd [punk::args::get_by_id ::punk::safe::interpIC $args] + set argd [punk::args::parse $args withid ::punk::safe::interpIC + set child [dict get $argd leaders child] CheckInterp $child namespace upvar ::punk::safe::system [VarName $child] state diff --git a/src/modules/punk/trie-999999.0a1.0.tm b/src/modules/punk/trie-999999.0a1.0.tm index a70f377a..aaf6de4d 100644 --- a/src/modules/punk/trie-999999.0a1.0.tm +++ b/src/modules/punk/trie-999999.0a1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::trie 0 999999.0a1.0] #[copyright "2010"] #[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] +#[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] #[require punk::trie] #[keywords module datastructure trie] #[description] tcl trie implementation courtesy of CmcC (tcl wiki) @@ -71,23 +71,23 @@ package require Tcl 8.6- # #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 ---}] # #} @@ -103,20 +103,31 @@ tcl::namespace::eval punk::trie { proc Dolog {lvl txt} { #return "$lvl -- $txt" #logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted - set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie '[uplevel [list subst $txt]]'" + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie $lvl '[uplevel [list subst $txt]]'" puts stderr $msg } - package require logger - logger::initNamespace ::punk::trie - foreach lvl [logger::levels] { - interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl - log::logproc $lvl ::punk::trie::Log_$lvl + if {![catch { + package require logger + }]} { + logger::initNamespace ::punk::trie + foreach lvl [logger::levels] { + interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl + log::logproc $lvl ::punk::trie::Log_$lvl + } + #namespace path ::punk::trie::log + } else { + #e.g tcllib not available, safe interp? + #fake out the logger calls + namespace eval log { + foreach lvl {debug info notice warn error critical alert emergency} { + proc $lvl {args} {} + } + } } - #namespace path ::punk::trie::log #*** !doctools #[subsection {Namespace punk::trie}] - #[para] Core API functions for punk::trie + #[para] Core API functions for punk::trie if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { #*** !doctools #[list_begin enumerated] @@ -131,7 +142,7 @@ tcl::namespace::eval punk::trie { method matches {t what} { #*** !doctools #[call class::trieclass [method matches] [arg t] [arg what]] - #[para] search for longest prefix, return matching prefix, element and suffix + #[para] search for longest prefix, return matching prefix, element and suffix set matches {} set wlen [string length $what] @@ -156,7 +167,7 @@ tcl::namespace::eval punk::trie { set match [lindex [lsort -dictionary [dict keys $matches]] end] set mel [dict get $matches $match] set suffix [string range $what [string length $match] end] - + return [list $match $mel $suffix] } else { return {} ;# no matches @@ -250,7 +261,7 @@ tcl::namespace::eval punk::trie { } else { set t $trie } - + if {[dict exists $t $what]} { #Debug.trie {$what is an exact match on path ($args $what)} return [list {*}$args $what] ;# exact match - no change @@ -373,7 +384,7 @@ tcl::namespace::eval punk::trie { set path [my find_path $what] if {[join $path ""] eq $what} { #presumably we use catch and dict size to avoid llength shimmering large inner dicts to list rep - if {[catch {dict size [dict get $trie {*}$path]} size]} { + if {[catch {dict size [dict get $trie {*}$path]} size]} { # got to a matching leaf - done return [dict get $trie {*}$path] } else { @@ -424,14 +435,14 @@ tcl::namespace::eval punk::trie { } return $acc } - + #shortest possible string to identify an element in the trie using the same principle as tcl::prefix::match #ie if a stored word is a prefix of any other words - it must be fully specified to identify itself. - #JMN - REVIEW - better algorithms? + #JMN - REVIEW - better algorithms? #caller having retained all members can avoid flatten call #by selecting a single 'which' known not to be in the trie (or empty string) - all idents can be returned. #when all 'which' members are in the tree - scanning stops when they're all found - # - and a dict containing result and scanned keys is returned + # - and a dict containing result and scanned keys is returned # - result contains a dict with keys for each which member # - scanned contains a dict of all words longer than our shortest which - (and a subset of words the same length) method shortest_idents {which {allmembers {}}} { @@ -454,7 +465,7 @@ tcl::namespace::eval punk::trie { dict set scanned $w $w if {$w in $which} { #puts stderr "$w -> $w" - dict set result $w $w + dict set result $w $w if {[dict size $result] == [llength $which]} { return [dict create result $result scanned $scanned] } @@ -537,13 +548,13 @@ tcl::namespace::eval punk::trie { #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]Description of sample1 # #[para] Arguments: # # [list_begin arguments] # # [arg_def tring p1] A description of string argument p1. # # [arg_def integer n] A description of integer argument n. # # [list_end] - # return "ok" + # return "ok" #} @@ -553,30 +564,6 @@ tcl::namespace::eval punk::trie { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# Secondary API namespace -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::trie::lib { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase - tcl::namespace::path [tcl::namespace::parent] - #*** !doctools - #[subsection {Namespace punk::trie::lib}] - #[para] Secondary functions that are part of the API - #[list_begin definitions] - - #proc utility1 {p1 args} { - # #*** !doctools - # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] - # #[para]Description of utility1 - # return 1 - #} - - - - #*** !doctools - #[list_end] [comment {--- end definitions namespace punk::trie::lib ---}] -} -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -586,17 +573,17 @@ tcl::namespace::eval punk::trie::lib { #tcl::namespace::eval punk::trie::system { #*** !doctools #[subsection {Namespace punk::trie::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::trie [tcl::namespace::eval punk::trie { variable pkg punk::trie variable version - set version 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-0.1.0.tm index 451ad7a5..9c44ea72 100644 --- a/src/modules/punkcheck-0.1.0.tm +++ b/src/modules/punkcheck-0.1.0.tm @@ -46,21 +46,16 @@ namespace eval punkcheck { #antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators variable default_antiglob_dir_core [list "#*" "_aside" "_build" ".git" ".fossil*"] variable default_antiglob_file_core "" - proc uuid {} { - set has_twapi 0 - if {"windows" eq $::tcl_platform(platform)} { - if {![catch {package require twapi}]} { - set has_twapi 1 - } - } - if {!$has_twapi} { - if {[catch {package require uuid} errM]} { - error "punkcheck: Unable to load a package for uuid on this platform. Try tcllib's uuid (any platform) - twapi for windows" - } - return [uuid::uuid generate] - } else { - return [twapi::new_uuid] - } + + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + set has_twapi [expr {![catch {package require twapi}]}] + } + if {$has_twapi} { + interp alias "" ::punkcheck::uuid "" ::twapi::new_uuid + } else { + catch {package require uuid} + interp alias "" ::punkcheck::uuid "" ::uuid::uuid generate } proc default_antiglob_dir_core {} { diff --git a/src/modules/test/punk/#modpod-lib-999999.0a1.0/files/testscript_parsing.tcl b/src/modules/test/punk/#modpod-lib-999999.0a1.0/files/testscript_parsing.tcl new file mode 100644 index 00000000..0dcf55e3 --- /dev/null +++ b/src/modules/test/punk/#modpod-lib-999999.0a1.0/files/testscript_parsing.tcl @@ -0,0 +1,68 @@ +#file should load as list of lists with punk::lib::tclscript_to_scriptlist + + + \ + \ +puts test1 + +# extended comment with trailing whitespace \ +etc\ + +puts test2 + +list\ +test3\ +# hmm + +set x [list\ +#blah \ +etc +] +puts "x = $x" + +set y [list A B +] +puts "y = $y" + +set z [list not in z because next line is a new command which becomes result of the script delimited by square brackets +set j 1 +] +#z will be just 1 +puts "z = $z" + +set hmm { + #seemingly unbalanced comment,but is just part of hmm data - still requires balancing close curly within the data { + #syntax highlighters usually get this wrong. + } +# also not really a comment, but closing curly is not part of data } +puts $hmm + +;# } +# unbalanced curly in *toplevel* comment is unwise, but not really a problem. info complete for this line will be true. { + +set data " + # { +" + +set j 123;set k 345 +;list\ +a b c + +set etc { + \{ a test +;} + + +list \ #etc + +list \ \" ;#etc + +proc { x } {a} { + return $a +} + + +\ x\ blah + +#the end + diff --git a/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/index_functions.test b/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/index_functions.test index a498dafe..c11360ca 100644 --- a/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/index_functions.test +++ b/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/index_functions.test @@ -32,26 +32,26 @@ namespace eval ::testspace { #e.g indices {0 1 2 3 4} n = 5 - lappend result [punk::lib::lindex_resolve 5 end+1] ;# -> -2 out of bounds on upper side - lappend result [punk::lib::lindex_resolve 5 end--1] ;# equiv to +1 -> -2 + lappend result [punk::lib::lindex_resolve 5 end+1] ;# -> Inf out of bounds on upper side + lappend result [punk::lib::lindex_resolve 5 end--1] ;# equiv to +1 -> Inf - lappend result [punk::lib::lindex_resolve 5 4--5] ;# -> -2 out of bounds on upper side - lappend result [punk::lib::lindex_resolve 5 end--5] ;# -> -2 out of bounds on upper side + lappend result [punk::lib::lindex_resolve 5 4--5] ;# -> Inf out of bounds on upper side + lappend result [punk::lib::lindex_resolve 5 end--5] ;# -> Inf out of bounds on upper side - lappend result [punk::lib::lindex_resolve 5 4-5] ;# -> -3 out of bounds on lower side - lappend result [punk::lib::lindex_resolve 5 end-5] ;# -> -3 out of bounds on lower side + lappend result [punk::lib::lindex_resolve 5 4-5] ;# -> -Inf out of bounds on lower side + lappend result [punk::lib::lindex_resolve 5 end-5] ;# -> -Inf out of bounds on lower side - lappend result [punk::lib::lindex_resolve 5 4+-5] ;# -> -3 out of bounds on lower side - lappend result [punk::lib::lindex_resolve 5 end+-5] ;# -> -3 out of bounds on lower side + lappend result [punk::lib::lindex_resolve 5 4+-5] ;# -> -Inf out of bounds on lower side + lappend result [punk::lib::lindex_resolve 5 end+-5] ;# -> -Inf out of bounds on lower side - lappend result [punk::lib::lindex_resolve 5 4-+5] ;# -> -3 out of bounds on lower side - lappend result [punk::lib::lindex_resolve 5 end-+5] ;# -> -3 out of bounds on lower side + lappend result [punk::lib::lindex_resolve 5 4-+5] ;# -> -Inf out of bounds on lower side + lappend result [punk::lib::lindex_resolve 5 end-+5] ;# -> -Inf out of bounds on lower side }\ -cleanup { }\ -result [list\ - -2 -2 -2 -2 -3 -3 -3 -3 -3 -3 + Inf Inf Inf Inf -Inf -Inf -Inf -Inf -Inf -Inf ] test lindex_resolve_endoffset_errors {test some end-like offsets that should error}\ diff --git a/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/parse.test b/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/parse.test new file mode 100644 index 00000000..c515fa5d --- /dev/null +++ b/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/lib/parse.test @@ -0,0 +1,43 @@ +package require tcltest + +namespace eval ::testspace { + namespace import ::tcltest::* + variable common { + set result "" + } + + test parse_tcl_script_switchargs {test basic parse of switch args (switch form 1) tclscript_to_scriptlist}\ + -setup $common -body { + # + set scr {-exact -- [lindex $args 0] {a - b {expr 33} c {expr 44}} } + set lol [punk::lib::tclscript_to_scriptlist $scr] + lappend result [llength $lol] ;#single toplevel script + lappend result [llength [lindex $lol 0]] + #final arg to switch -form 1 is a scriptblock consisting of pattern/script pairs + set patternblock_script [lindex $lol 0 end] + set patternblock_contents [lindex $patternblock_script 0] ;#it's braced + #we should be able to treat the data within the braces as a dict. + lappend result [dict keys $patternblock_contents] + }\ + -cleanup { + }\ + -result [list\ + 1 4 {a b c} + ] + + test parse_tcl_script_oneline {test basic parse of single-line script to list of lists with tclscript_to_scriptlist}\ + -setup $common -body { + set scr {puts [info name]; dict get {a A b "B B"} a} + set lol [punk::lib::tclscript_to_scriptlist $scr] + lappend result [llength $lol] ;#2 toplevel scripts + lappend result [llength [lindex $lol 0]] + lappend result [llength [lindex $lol 1]] + + }\ + -cleanup { + }\ + -result [list\ + 2 2 4 + ] + +} \ No newline at end of file diff --git a/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/tests/parse.test#..+lib+parse.test.fauxlink b/src/modules/test/punk/#modpod-lib-999999.0a1.0/lib-0.1.3_testsuites/tests/parse.test#..+lib+parse.test.fauxlink new file mode 100644 index 00000000..e69de29b diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 3712caf7..82461639 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -5724,7 +5724,7 @@ tcl::namespace::eval textblock { #join without regard to each line length in a block (no padding added to make each block uniform) proc ::textblock::join_basic {args} { - set argd [punk::args::parse $args -cache 1 withid ::textblock::join_basic] + set argd [punk::args::parse $args -cache 0 withid ::textblock::join_basic] set ansiresets [tcl::dict::get $argd opts -ansiresets] set blocks [tcl::dict::get $argd values blocks] @@ -7798,21 +7798,22 @@ tcl::namespace::eval textblock { variable frame_cache set frame_cache [tcl::dict::create] - - punk::args::define { - @id -id ::textblock::frame_cache - @cmd -name textblock::frame_cache -help\ - "Display or clear the frame cache." - -pretty -default 1 -help\ - "Uses 'pdict textblock::frame_cache */*' for prettier output - Either way this is set, output requires long lines and may - still wrap in an ugly manner. Try 'textblock::use_cache md5' - to shorten the argument display and reduce wrapping. - " - @values -min 0 -max -1 - action -default {display} -choices {clear size info display} -choicelabels { - clear "Clear the textblock::frame_cache dictionary." - } -help "Perform an action on the frame cache." + namespace eval argdoc { + punk::args::define { + @id -id ::textblock::frame_cache + @cmd -name textblock::frame_cache -help\ + "Display or clear the frame cache." + -pretty -default 1 -help\ + "Uses '${$B}pdict${$N} textblock::frame_cache */*' for prettier output + Either way this is set, output requires long lines and may + still wrap in an ugly manner. Try 'textblock::use_cache md5' + to shorten the argument display and reduce wrapping. + " + @values -min 0 -max -1 + action -default {display} -choices {clear size info display} -choicelabels { + clear "Clear the textblock::frame_cache dictionary." + } -help "Perform an action on the frame cache." + } } proc frame_cache {args} { set argd [punk::args::parse $args withid ::textblock::frame_cache] @@ -7847,7 +7848,6 @@ tcl::namespace::eval textblock { } } punk::args::define { - @dynamic @id -id ::textblock::frame_cache_display @opts ${[::punk::args::resolved_def -types opts ::textblock::frame_cache -pretty]} @@ -7966,6 +7966,8 @@ tcl::namespace::eval textblock { #todo punk::args alias for centre center etc? namespace eval argdoc { + set DYN_FRAMETYPES {${[textblock::frametypes]}} + set DYN_FRAMESAMPLES {${[textblock::frame_samples]}} punk::args::define { @dynamic @id -id ::textblock::frame @@ -7997,10 +7999,11 @@ tcl::namespace::eval textblock { -type -default light\ -type dict\ -typesynopsis {${$I}choice${$NI}|<${$I}dict${$NI}>}\ - -choices {${[textblock::frametypes]}}\ + -choices {${$DYN_FRAMETYPES}}\ -choicerestricted 0 -choicecolumns 8\ + -unindentedfields {-choicelabels}\ -choicelabels { - ${[textblock::frame_samples]} + ${$DYN_FRAMESAMPLES} }\ -help "Type of border for frame." -boxlimits -default {hl vl tlc blc trc brc} -type list -help "Limit the border box to listed elements. diff --git a/src/vendormodules/overtype-1.7.2.tm b/src/vendormodules/overtype-1.7.2.tm new file mode 100644 index 00000000..aa7405e2 --- /dev/null +++ b/src/vendormodules/overtype-1.7.2.tm @@ -0,0 +1,4892 @@ +# -*- 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.2 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin overtype_module_overtype 0 1.7.2] +#[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] + + + + #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r + #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. + #The underlay and overlay can be multiline blocks of text of varying line lengths. + #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. + #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. + # a cursor start position other than top-left is a possible addition to consider. + #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline + proc renderspace {args} { + #*** !doctools + #[call [fun overtype::renderspace] [arg args] ] + #[para] usage: ?-transparent [lb]0|1[rb]? ?-expand_right [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext + + # @c overtype starting at left (overstrike) + # @c can/should we use something like this?: 'format "%-*s" $len $overtext + variable default_ellipsis_horizontal + + if {[llength $args] < 2} { + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-expand_right [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + } + set optargs [lrange $args 0 end-2] + if {[llength $optargs] % 2 == 0} { + set overblock [lindex $args end] + set underblock [lindex $args end-1] + #lassign [lrange $args end-1 end] underblock overblock + set argsflags [lrange $args 0 end-2] + } else { + set optargs [lrange $args 0 end-1] + if {[llength $optargs] %2 == 0} { + set overblock [lindex $args end] + set underblock "" + set argsflags [lrange $args 0 end-1] + } else { + error "renderspace expects opt-val pairs followed by: or just " + } + } + set opts [tcl::dict::create\ + -bias ignored\ + -width \uFFEF\ + -height \uFFEF\ + -startcolumn 1\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -expand_right 0\ + -appendlines 1\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -experimental 0\ + -cp437 0\ + -looplimit \uFFEF\ + -crm_mode 0\ + -reverse_mode 0\ + -insert_mode 0\ + -wrap 0\ + -info 0\ + -console {stdin stdout stderr}\ + ] + #expand_right is perhaps consistent with the idea of the page_size being allowed to grow horizontally.. + # it does not necessarily mean the viewport grows. (which further implies need for horizontal scrolling) + # - it does need to be within some concept of terminal width - as columns must be addressable by ansi sequences. + # - This implies the -width option value must grow if it is tied to the concept of renderspace terminal width! REVIEW. + # - further implication is that if expand_right grows the virtual renderspace terminal width - + # then some sort of reflow/rerender needs to be done for preceeding lines? + # possibly not - as expand_right is distinct from a normal terminal-width change event, + # expand_right being primarily to support other operations such as textblock::table + + #todo - viewport width/height as separate concept to terminal width/height? + #-ellipsis args not used if -wrap is true + foreach {k v} $argsflags { + switch -- $k { + -looplimit - -width - -height - -startcolumn - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace + - -transparent - -exposed1 - -exposed2 - -experimental + - -expand_right - -appendlines + - -reverse_mode - -crm_mode - -insert_mode + - -cp437 + - -info - -console { + tcl::dict::set opts $k $v + } + -wrap - -autowrap_mode { + #temp alias -autowrap_mode for consistency with renderline + #todo - + tcl::dict::set opts -wrap $v + } + default { + error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + #review - expand_left for RTL text? + set opt_expand_right [tcl::dict::get $opts -expand_right] + #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + set opt_startcolumn [tcl::dict::get $opts -startcolumn] + set opt_appendlines [tcl::dict::get $opts -appendlines] + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo + set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo + # -- --- --- --- --- --- + set opt_crm_mode [tcl::dict::get $opts -crm_mode] + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] + set opt_insert_mode [tcl::dict::get $opts -insert_mode] + ##### + # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. + set opt_autowrap_mode [tcl::dict::get $opts -wrap] + #??? wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) + ##### + # -- --- --- --- --- --- + set opt_cp437 [tcl::dict::get $opts -cp437] + set opt_info [tcl::dict::get $opts -info] + + + + # ---------------------------- + # -experimental dev flag to set flags etc + # ---------------------------- + set data_mode 0 + set edit_mode 0 + set opt_experimental [tcl::dict::get $opts -experimental] + foreach o $opt_experimental { + switch -- $o { + data_mode { + set data_mode 1 + } + edit_mode { + set edit_mode 1 + } + } + } + # ---------------------------- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + + #set underlines [split $underblock \n] + + #underblock is a 'rendered' block - so width height make sense + #only non-cursor affecting and non-width occupying ANSI codes should be present. + #ie SGR codes and perhaps things such as PM - although generally those should have been pushed to the application already + #renderwidth & renderheight were originally used with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. + + if {$opt_width eq "\uFFEF" || $opt_height eq "\uFFEF"} { + lassign [blocksize $underblock] _w renderwidth _h renderheight + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } + if {$opt_height ne "\uFFEF"} { + set renderheight $opt_height + } + } else { + set renderwidth $opt_width + set renderheight $opt_height + } + #initial state for renderspace 'terminal' reset + set initial_state [dict create\ + renderwidth $renderwidth\ + renderheight $renderheight\ + crm_mode $opt_crm_mode\ + reverse_mode $opt_reverse_mode\ + insert_mode $opt_insert_mode\ + autowrap_mode $opt_autowrap_mode\ + cp437 $opt_cp437\ + ] + #modes + #e.g insert_mode can be toggled by insert key or ansi IRM sequence CSI 4 h|l + #opt_startcolumn ?? - DECSLRM ? + set vtstate $initial_state + + # -- --- --- --- + #REVIEW - do we need ansi resets in the underblock? + if {$underblock eq ""} { + set underlines [lrepeat $renderheight ""] + } else { + set underblock [textblock::join_basic -- $underblock] ;#ensure properly rendered - ansi per-line resets & replays + set underlines [split $underblock \n] + } + #if {$underblock eq ""} { + # set blank "\x1b\[0m\x1b\[0m" + # #set underlines [list "\x1b\[0m\x1b\[0m"] + # set underlines [lrepeat $renderheight $blank] + #} else { + # #lines_as_list -ansiresets 1 will do nothing if -ansiresets 1 isn't specified - REVIEW + # set underlines [lines_as_list -ansiresets 1 $underblock] + #} + # -- --- --- --- + + #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. + #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output renderwidth + #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. + #(in cases where there are interline moves or cursor jumps anyway) + #This works - but doesn't seem efficient. + #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first + + #a hack until we work out how to avoid infinite loops... + # + set looplimit [tcl::dict::get $opts -looplimit] + if {$looplimit eq "\uFFEF"} { + #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? + #do we need any margin above the length? (telnet mapscii.me test) + set looplimit [expr {[tcl::string::length $overblock] + 10}] + } + + #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height + #lassign [blocksize $overblock] _w overblock_width _h overblock_height + + set scheme 4 + switch -- $scheme { + 0 { + #one big chunk + set inputchunks [list $overblock] + } + 1 { + set inputchunks [punk::ansi::ta::split_codes $overblock] + } + 2 { + + #split into lines if possible first - then into plaintext/ansi-sequence chunks ? + set inputchunks [list ""] ;#put an empty plaintext split in for starters + set i 1 + set lines [split $overblock \n] + foreach ln $lines { + if {$i < [llength $lines]} { + append ln \n + } + set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? + set lastpt [lindex $inputchunks end] + lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] + lappend inputchunks {*}[lrange $sequence_split 1 end] + incr i + } + } + 3 { + #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice + set lflines [list] + set inputchunks [split $overblock \n] + foreach ln $inputchunks { + append ln \n + lappend lflines $ln + } + if {[llength $lflines]} { + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] + } + #set inputchunks $lflines[unset lflines] + set inputchunks [lindex [list $lflines [unset lflines]] 0] + + } + 4 { + set inputchunks [list] + foreach ln [split $overblock \n] { + lappend inputchunks $ln\n + } + if {[llength $inputchunks]} { + lset inputchunks end [tcl::string::range [lindex $inputchunks end] 0 end-1] + } + } + } + + + + + set replay_codes_underlay [tcl::dict::create 1 ""] + #lappend replay_codes_overlay "" + set replay_codes_overlay "[punk::ansi::a]" + set unapplied "" + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + + + set outputlines $underlines + set overidx 0 + + #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext + set row 1 + #if {$data_mode} { + # set col [_get_row_append_column $row] + #} else { + set col $opt_startcolumn + #} + + set instruction_stats [tcl::dict::create] + + set loop 0 + #while {$overidx < [llength $inputchunks]} { } + + while {[llength $inputchunks]} { + #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" + set overtext [lpop inputchunks 0] + if {![tcl::string::length $overtext]} { + incr loop + continue + } + #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" + set undertext [lindex $outputlines [expr {$row -1}]] + set renderedrow $row + + #renderline pads each underaly line to width with spaces and should track where end of data is + + + #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] + set overtext $replay_codes_overlay$overtext + if {[tcl::dict::exists $replay_codes_underlay $row]} { + set undertext [tcl::dict::get $replay_codes_underlay $row]$undertext + } + #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - + #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l + set renderopts [list -experimental $opt_experimental\ + -cp437 $opt_cp437\ + -info 1\ + -crm_mode [tcl::dict::get $vtstate crm_mode]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -reverse_mode [tcl::dict::get $vtstate reverse_mode]\ + -cursor_restore_attributes $cursor_saved_attributes\ + -transparent $opt_transparent\ + -width [tcl::dict::get $vtstate renderwidth]\ + -exposed1 $opt_exposed1\ + -exposed2 $opt_exposed2\ + -expand_right $opt_expand_right\ + -cursor_column $col\ + -cursor_row $row\ + ] + set rinfo [renderline {*}$renderopts $undertext $overtext] + + set instruction [tcl::dict::get $rinfo instruction] + tcl::dict::set vtstate crm_mode [tcl::dict::get $rinfo crm_mode] + tcl::dict::set vtstate insert_mode [tcl::dict::get $rinfo insert_mode] + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# + tcl::dict::set vtstate reverse_mode [tcl::dict::get $rinfo reverse_mode] + #how to support reverse_mode in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? + # - review - the answer is probably that we don't need to - it is set/reset only during application of overtext + + #Note carefully the difference betw overflow_right and unapplied. + #overflow_right may need to be included in next run before the unapplied data + #overflow_right most commonly has data when in insert_mode + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] + set unapplied [tcl::dict::get $rinfo unapplied] + set unapplied_list [tcl::dict::get $rinfo unapplied_list] + set post_render_col [tcl::dict::get $rinfo cursor_column] + set post_render_row [tcl::dict::get $rinfo cursor_row] + set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] + set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] + set visualwidth [tcl::dict::get $rinfo visualwidth] ;#column width of what is 'rendered' for the line + set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] + set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] + tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] + + #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + if {0 && [tcl::dict::get $vtstate reverse_mode]} { + #test branch - todo - prune + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + #review + #JMN3 + set existing_reverse_state 0 + #split_codes_single is single esc sequence - but could have multiple sgr codes within one esc sequence + #e.g \x1b\[0;31;7m has a reset,colour red and reverse + set codeinfo [punk::ansi::codetype::sgr_merge [list $replay_codes_overlay] -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + puts stderr "---->[ansistring VIEW $replay_codes_overlay] rendered: $rendered" + } + + + + #-- todo - detect looping properly + if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { + puts stderr "overtype::renderspace loop?" + puts [ansistring VIEW $rinfo] + break + } + #-- + + if {[tcl::dict::size $c_saved_pos] >= 1} { + set cursor_saved_position $c_saved_pos + set cursor_saved_attributes $c_saved_attributes + } + + + set overflow_handled 0 + + + + set nextprefix "" + + + #todo - handle potential insertion mode as above for cursor restore? + #keeping separate branches for debugging - review and merge as appropriate when stable + set instruction_type [lindex $instruction 0] ;#some instructions have params + tcl::dict::incr instruction_stats $instruction_type + switch -- $instruction_type { + reset { + #reset the 'renderspace terminal' (not underlying terminal) + set row 1 + set col 1 + set vtstate [tcl::dict::merge $vtstate $initial_state] + #todo - clear screen + } + {} { + #end of supplied line input + #lf included in data + set row $post_render_row + set col $post_render_col + if {![llength $unapplied_list]} { + if {$overflow_right ne ""} { + incr row + } + } else { + puts stderr "renderspace end of input line - has unapplied: [ansistring VIEW $unapplied] (review)" + } + set col $opt_startcolumn + } + up { + + #renderline knows it's own line number, and knows not to go above row l + #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. + #row returned should be correct. + #column may be the overflow column - as it likes to report that to the caller. + + #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. + #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review + #puts stderr "up $post_render_row" + #puts stderr "$rinfo" + + #puts stdout "1 row:$row col $col" + set row $post_render_row + #data_mode (naming?) determines if we move to end of existing data or not. + #data_mode 0 means ignore existing line length and go to exact column + #set by -experimental flag + if {$data_mode == 0} { + set col $post_render_col + } else { + #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data + #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $renderwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $renderwidth + } + } + + #puts stdout "2 row:$row col $col" + #puts stdout "-----------------------" + #puts stdout $rinfo + #flush stdout + } + down { + if {$data_mode == 0} { + #renderline doesn't know how far down we can go.. + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + set row $post_render_row + set col $post_render_col + } else { + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $renderwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $renderwidth + } + + } + } + restore_cursor { + #testfile belinda.ans uses this + + #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" + if {[tcl::dict::exists $cursor_saved_position row]} { + set row [tcl::dict::get $cursor_saved_position row] + set col [tcl::dict::get $cursor_saved_position column] + #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" + #set nextprefix $cursor_saved_attributes + #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes + #set replay_codes_overlay $cursor_saved_attributes + set cursor_saved_position [tcl::dict::create] + set cursor_saved_attributes "" + } else { + #TODO + #?restore without save? + #should move to home position and reset ansi SGR? + #puts stderr "overtype::renderspace cursor_restore without save data available" + } + #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it + #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. + if {!$overflow_handled && $overflow_right ne ""} { + #wrap before restore? - possible effect on saved cursor position + #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc + #we can just insert another call to renderline to solve this.. ? + #It would perhaps be more properly handled as a queue of instructions from our initial renderline call + #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks + + puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" + + set sub_info [overtype::renderline\ + -info 1\ + -width [tcl::dict::get $vtstate renderwidth]\ + -insert_mode [tcl::dict::get $vtstate insert_mode]\ + -autowrap_mode [tcl::dict::get $vtstate autowrap_mode]\ + -expand_right [tcl::dict::get $opts -expand_right]\ + ""\ + $overflow_right\ + ] + set foldline [tcl::dict::get $sub_info result] + tcl::dict::set vtstate insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed..? + tcl::dict::set vtstate autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. + linsert outputlines $renderedrow $foldline + #review - row & col set by restore - but not if there was no save.. + } + set overflow_handled 1 + + } + move { + ######## + if {$post_render_row > [llength $outputlines]} { + #Ansi moves need to create new lines ? + #if {$opt_appendlines} { + # set diff [expr {$post_render_row - [llength $outputlines]}] + # if {$diff > 0} { + # lappend outputlines {*}[lrepeat $diff ""] + # } + # set row $post_render_row + #} else { + set row [llength $outputlines] + #} + } else { + set row $post_render_row + } + ####### + set col $post_render_col + #overflow + unapplied? + } + clear_and_move { + #e.g 2J + if {$post_render_row > [llength $outputlines]} { + set row [llength $outputlines] + } else { + set row $post_render_row + } + set col $post_render_col + set overflow_right "" ;#if we're clearing - any overflow due to insert_mode is irrelevant + set clearedlines [list] + foreach ln $outputlines { + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $renderwidth]\x1b\[0m + if 0 { + + set lineparts [punk::ansi::ta::split_codes $ln] + set numcells 0 + foreach {pt _code} $lineparts { + if {$pt ne ""} { + foreach grapheme [punk::char::grapheme_split $pt] { + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + incr numcells 1 + } + default { + if {$grapheme eq "\u0000"} { + incr numcells 1 + } else { + incr numcells [grapheme_width_cached $grapheme] + } + } + } + + } + } + } + #replays/resets each line + lappend clearedlines \x1b\[0m$replay_codes_overlay[string repeat \000 $numcells]\x1b\[0m + } + } + set outputlines $clearedlines + #todo - determine background/default to be in effect - DECECM ? + puts stderr "replay_codes_overlay: [ansistring VIEW $replay_codes_overlay]" + #lset outputlines 0 $replay_codes_overlay[lindex $outputlines 0] + + } + lf_start { + #raw newlines + # ---------------------- + #test with fruit.ans + #test - treating as newline below... + #append rendered $overflow_right + #set overflow_right "" + set row $renderedrow + incr row + if {$row > [llength $outputlines]} { + lappend outputlines "" + } + set col $opt_startcolumn + # ---------------------- + } + lf_mid { + + set edit_mode 0 + if {$edit_mode} { + set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] + set overflow_right "" + set unapplied "" + set row $post_render_row + #set col $post_render_col + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + if 1 { + if {$overflow_right ne ""} { + if {$opt_expand_right} { + append rendered $overflow_right + set overflow_right "" + } else { + #review - we should really make renderline do the work...? + set overflow_width [punk::ansi::printing_length $overflow_right] + if {$visualwidth + $overflow_width <= $renderwidth} { + append rendered $overflow_right + set overflow_right "" + } else { + if {[tcl::dict::get $vtstate autowrap_mode]} { + set outputlines [linsert $outputlines $renderedrow $overflow_right] + set overflow_right "" + set row [expr {$renderedrow + 2}] + } else { + set overflow_right "" ;#abandon + } + + if {0 && $visualwidth < $renderwidth} { + puts stderr "visualwidth: $visualwidth < renderwidth:$renderwidth" + error "incomplete - abandon?" + set overflowparts [punk::ansi::ta::split_codes $overflow_right] + set remaining_overflow $overflowparts + set filled 0 + foreach {pt code} $overflowparts { + lpop remaining_overflow 0 + if {$pt ne ""} { + set graphemes [punk::char::grapheme_split $pt] + set add "" + set addlen $visualwidth + foreach g $graphemes { + set w [overtype::grapheme_width_cached $g] + if {$addlen + $w <= $renderwidth} { + append add $g + incr addlen $w + } else { + set filled 1 + break + } + } + append rendered $add + } + if {!$filled} { + lpop remaining_overflow 0 ;#pop code + } + } + set overflow_right [join $remaining_overflow ""] + } + } + } + } + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } else { + #old version - known to work with various ansi graphics - e.g fruit.ans + # - but fails to limit lines to renderwidth when expand_right == 0 + append rendered $overflow_right + set overflow_right "" + set row $post_render_row + set col $opt_startcolumn + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + } + } + } + lf_overflow { + #linefeed after renderwidth e.g at column 81 for an 80 col width + #we may also have other control sequences that came after col 80 e.g cursor save + + if 0 { + set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] + set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] + set rhs "" + + #assertion - there should be no overflow.. + puts $lhs + } + if {![tcl::dict::get $vtstate insert_mode]} { + assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right when not insert_mode + } + + set row $post_render_row + #set row $renderedrow + #incr row + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat 1 ""] + } + set col $opt_startcolumn + + } + newlines_above { + #we get a newlines_above instruction when received at column 1 + #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) + #in other cases - we want to treat at column 1 the same as any other + + puts "--->newlines_above" + puts "rinfo: $rinfo" + #renderline doesn't advance the row for us - the caller has the choice to implement or not + set row $post_render_row + set col $post_render_col + if {$insert_lines_above > 0} { + set row $renderedrow + set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] + incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above + #? set row $post_render_row #can renderline tell us? + } + } + newlines_below { + #obsolete? - use for ANSI insert lines sequence + if {$data_mode == 0} { + puts --->nl_below + set row $post_render_row + set col $post_render_col + if {$insert_lines_below == 1} { + #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] + #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] + #set rhs "" + #if {$overflow_right ne ""} { + # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] + # set rhs [textblock::frame -title overflow_right $rhs] + #} + #puts [textblock::join $lhs $rhs] + + #rendered + append rendered $overflow_right + # + + + set overflow_right "" + set row $renderedrow + #only add newline if we're at the bottom + if {$row > [llength $outputlines]} { + lappend outputlines {*}[lrepeat $insert_lines_below ""] + } + incr row $insert_lines_below + set col $opt_startcolumn + } + } else { + set row $post_render_row + if {$post_render_row > [llength $outputlines]} { + if {$opt_appendlines} { + set diff [expr {$post_render_row - [llength $outputlines]}] + if {$diff > 0} { + lappend outputlines {*}[lrepeat $diff ""] + } + lappend outputlines "" + } + } else { + set existingdata [lindex $outputlines [expr {$post_render_row -1}]] + set lastdatacol [punk::ansi::printing_length $existingdata] + if {$lastdatacol < $renderwidth} { + set col [expr {$lastdatacol+1}] + } else { + set col $renderwidth + } + } + } + } + wrapmoveforward { + #doesn't seem to be used by fruit.ans testfile + #used by dzds.ans + #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO + set c $renderwidth + set r $post_render_row + if {$post_render_col > $renderwidth} { + set i $c + while {$i <= $post_render_col} { + if {$c == $renderwidth+1} { + incr r + if {$opt_appendlines} { + if {$r < [llength $outputlines]} { + lappend outputlines "" + } + } + set c $opt_startcolumn + } else { + incr c + } + incr i + } + set col $c + } else { + #why are we getting this instruction then? + puts stderr "wrapmoveforward - test" + set r [expr {$post_render_row +1}] + set c $post_render_col + } + set row $r + set col $c + } + wrapmovebackward { + set c $renderwidth + set r $post_render_row + if {$post_render_col < 1} { + set c 1 + set i $c + while {$i >= $post_render_col} { + if {$c == 0} { + if {$r > 1} { + incr r -1 + set c $renderwidth + } else { + #leave r at 1 set c 1 + #testfile besthpav.ans first line top left border alignment + set c 1 + break + } + } else { + incr c -1 + } + incr i -1 + } + set col $c + } else { + puts stderr "Wrapmovebackward - but postrendercol >= 1???" + } + set row $r + set col $c + } + overflow { + #normal single-width grapheme overflow + #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" + set row $post_render_row ;#renderline will not advance row when reporting overflow char + if {[tcl::dict::get $vtstate autowrap_mode]} { + incr row + set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? + } else { + set col $post_render_col + #set unapplied "" ;#this seems wrong? + #set unapplied [tcl::string::range $unapplied 1 end] + #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs + #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate + #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' + set idx 0 + set next_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set next_grapheme_index $idx + break + } + incr idx + } + assert {$next_grapheme_index >= 0} + #drop the overflow grapheme - keeping all codes in place. + set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] + #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines + + set overflow_handled 1 + #handled by dropping overflow if any + } + } + overflow_splitchar { + set row $post_render_row ;#renderline will not advance row when reporting overflow char + + #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts + #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc + if {[tcl::dict::get $vtstate autowrap_mode]} { + if {$renderwidth < 2} { + #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } else { + set col $opt_startcolumn + incr row + } + } else { + set overflow_handled 1 + #handled by dropping entire overflow if any + if {$renderwidth < 2} { + set idx 0 + set triggering_grapheme_index -1 + foreach u $unapplied_list { + if {![punk::ansi::ta::detect $u]} { + set triggering_grapheme_index $idx + break + } + incr idx + } + set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] + } + } + + } + vt { + + #can vt add a line like a linefeed can? + set row $post_render_row + set col $post_render_col + } + set_window_title { + set newtitle [lindex $instruction 1] + puts stderr "overtype::renderspace set_window_title [ansistring VIEW $newtitle] instruction '$instruction'" + # + } + reset_colour_palette { + puts stderr "overtype::renderspace instruction '$instruction' unimplemented" + } + default { + puts stderr "overtype::renderspace unhandled renderline instruction '$instruction'" + } + + } + + + if {!$opt_expand_right && ![tcl::dict::get $vtstate autowrap_mode]} { + #not allowed to overflow column or wrap therefore we get overflow data to truncate + if {[tcl::dict::get $opts -ellipsis]} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + set overflow_handled 1 + } else { + #no wrap - no ellipsis - silently truncate + set overflow_handled 1 + } + } + + + + if {$renderedrow <= [llength $outputlines]} { + lset outputlines [expr {$renderedrow-1}] $rendered + } else { + if {$opt_appendlines} { + lappend outputlines $rendered + } else { + #? + lset outputlines [expr {$renderedrow-1}] $rendered + } + } + + if {!$overflow_handled} { + append nextprefix $overflow_right + } + + append nextprefix $unapplied + + if 0 { + if {$nextprefix ne ""} { + set nextoveridx [expr {$overidx+1}] + if {$nextoveridx >= [llength $inputchunks]} { + lappend inputchunks $nextprefix + } else { + #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] + set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] + } + } + } + + if {$nextprefix ne ""} { + set inputchunks [linsert $inputchunks 0 $nextprefix] + } + + + incr overidx + incr loop + if {$loop >= $looplimit} { + puts stderr "overtype::renderspace looplimit reached ($looplimit)" + lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" + set Y [a+ yellow bold] + set RST [a] + set sep_header ----DEBUG----- + set debugmsg "" + append debugmsg "${Y}${sep_header}${RST}" \n + append debugmsg "looplimit $looplimit reached\n" + append debugmsg "data_mode:$data_mode\n" + append debugmsg "opt_appendlines:$opt_appendlines\n" + append debugmsg "prev_row :[tcl::dict::get $renderopts -cursor_row]\n" + append debugmsg "prev_col :[tcl::dict::get $renderopts -cursor_column]\n" + tcl::dict::for {k v} $rinfo { + append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n + } + append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n + + puts stdout $debugmsg + #todo - config regarding error dumps rather than just dumping in working dir + set fd [open [pwd]/error_overtype.txt w] + puts $fd $debugmsg + close $fd + error $debugmsg + break + } + } + + set result [join $outputlines \n] + if {!$opt_info} { + return $result + } else { + #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? + #append result \n$instruction_stats\n + set inforesult [dict create\ + result $result\ + last_instruction $instruction\ + instruction_stats $instruction_stats\ + ] + if {$opt_info == 2} { + return [pdict -channel none inforesult] + } else { + return $inforesult + } + } + } + + #todo - left-right ellipsis ? + proc centre {args} { + variable default_ellipsis_horizontal + if {[llength $args] < 2} { + error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} + } + + foreach {underblock overblock} [lrange $args end-1 end] break + + #todo - vertical vs horizontal overflow for blocks + set opts [tcl::dict::create\ + -bias left\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + ] + set argsflags [lrange $args 0 end-2] + foreach {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- + + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + #set renderwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {$renderwidth - $overblock_width}] + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + set undertext "$undertext[string repeat { } $udiff]" + } + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + #review - right-to-left langs should elide on left! - extra option required + + if {$overflowlength > 0} { + #overlay line wider or equal + #review - we still expand_right for centred for now.. possibly should do something like -expand_leftright with ellipsis each end? + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + #todo - get replay_codes from overflow_right instead of wherever it was truncated? + + #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified + if {![tcl::dict::get $opts -overflow]} { + #lappend outputlines [tcl::string::range $overtext 0 [expr {$renderwidth - 1}]] + #set overtext [tcl::string::range $overtext 0 $renderwidth-1 ] + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::right $rendered $opt_ellipsistext] + } + } + } + lappend outputlines $rendered + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] + } else { + #background block is wider than or equal to data for this line + #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + return [join $outputlines \n] + } + + #overtype::right is for a rendered ragged underblock and a rendered ragged overblock + #ie we can determine the block width for bost by examining the lines and picking the longest. + # + proc right {args} { + #NOT the same as align-right - which should be done to the overblock first if required + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + foreach {underblock overblock} [lrange $args end-1 end] break + + set opts [tcl::dict::create\ + -bias ignored\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -align "left"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { + tcl::dict::set opts $k $v + } + default { + set known_opts [tcl::dict::keys $opts] + error "overtype::centre unknown option '$k'. Known options: $known_opts" + } + } + } + #set opts [tcl::dict::merge $defaults $argsflags] + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_align [tcl::dict::get $opts -align] + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + set left_exposed $under_exposed_max + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_align { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline\ + -info 1\ + -insert_mode 0\ + -transparent $opt_transparent\ + -exposed1 $opt_exposed1 -exposed2 $opt_exposed2\ + -overflow $opt_overflow\ + -startcolumn [expr {1 + $startoffset}]\ + $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set ellipsis $replay_codes$opt_ellipsistext + #todo - overflow on left if allign = right?? + set rendered [overtype::right $rendered $ellipsis] + } + } + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need overflow(exapnd_right) here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + proc left {args} { + overtype::block -blockalign left {*}$args + } + #overtype a (possibly ragged) underblock with a (possibly ragged) overblock + proc block {args} { + variable default_ellipsis_horizontal + # @d !todo - implement overflow, length checks etc + + if {[llength $args] < 2} { + error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} + } + #foreach {underblock overblock} [lrange $args end-1 end] break + lassign [lrange $args end-1 end] underblock overblock + + set opts [tcl::dict::create\ + -ellipsis 0\ + -ellipsistext $default_ellipsis_horizontal\ + -ellipsiswhitespace 0\ + -overflow 0\ + -transparent 0\ + -exposed1 \uFFFD\ + -exposed2 \uFFFD\ + -textalign "left"\ + -textvertical "top"\ + -blockalign "left"\ + -blockalignbias left\ + -blockvertical "top"\ + ] + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { + tcl::dict::set opts $k $v + } + default { + error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_textalign [tcl::dict::get $opts -textalign] + set opt_blockalign [tcl::dict::get $opts -blockalign] + if {$opt_blockalign eq "center"} { + set opt_blockalign "centre" + } + # -- --- --- --- --- --- + + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] + + set underlines [split $underblock \n] + lassign [blocksize $underblock] _w renderwidth _h renderheight + set overlines [split $overblock \n] + #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] + lassign [blocksize $overblock] _w overblock_width _h overblock_height + set under_exposed_max [expr {max(0,$renderwidth - $overblock_width)}] + + switch -- $opt_blockalign { + left { + set left_exposed 0 + } + right { + set left_exposed $under_exposed_max + } + centre { + if {$under_exposed_max > 0} { + #background block is wider + if {$under_exposed_max % 2 == 0} { + #even left/right exposure + set left_exposed [expr {$under_exposed_max / 2}] + } else { + set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division + if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { + set left_exposed $beforehalf + } else { + #bias to the right + set left_exposed [expr {$beforehalf + 1}] + } + } + } else { + set left_exposed 0 + } + } + default { + set left_exposed 0 + } + } + + + + set outputlines [list] + if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { + set replay_codes "[punk::ansi::a]" + } else { + set replay_codes "" + } + set replay_codes_underlay "" + set replay_codes_overlay "" + foreach undertext $underlines overtext $overlines { + set overtext_datalen [punk::ansi::printing_length $overtext] + set ulen [punk::ansi::printing_length $undertext] + if {$ulen < $renderwidth} { + set udiff [expr {$renderwidth - $ulen}] + #puts xxx + append undertext [string repeat { } $udiff] + } + if {$overtext_datalen < $overblock_width} { + set odiff [expr {$overblock_width - $overtext_datalen}] + switch -- $opt_textalign { + left { + set startoffset 0 + } + right { + set startoffset $odiff + } + default { + set half [expr {$odiff / 2}] + #set lhs [string repeat { } $half] + #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left + #set rhs [string repeat { } $righthalf] + set startoffset $half + } + } + } else { + set startoffset 0 ;#negative? + } + + set undertext $replay_codes_underlay$undertext + set overtext $replay_codes_overlay$overtext + + set overflowlength [expr {$overtext_datalen - $renderwidth}] + if {$overflowlength > 0} { + #raw overtext wider than undertext column + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -expand_right $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + if {!$opt_overflow} { + if {$opt_ellipsis} { + set show_ellipsis 1 + if {!$opt_ellipsiswhitespace} { + #we don't want ellipsis if only whitespace was lost + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + set lostdata "" + if {$overflow_right ne ""} { + append lostdata $overflow_right + } + if {$unapplied ne ""} { + append lostdata $unapplied + } + if {[tcl::string::trim $lostdata] eq ""} { + set show_ellipsis 0 + } + } + if {$show_ellipsis} { + set rendered [overtype::block -blockalign right $rendered $opt_ellipsistext] + } + } + + #if {$opt_ellipsis} { + # set show_ellipsis 1 + # if {!$opt_ellipsiswhitespace} { + # #we don't want ellipsis if only whitespace was lost + # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + # if {[tcl::string::trim $lostdata] eq ""} { + # set show_ellipsis 0 + # } + # } + # if {$show_ellipsis} { + # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] + # #todo - overflow on left if allign = right?? + # set rendered [overtype::right $rendered $ellipsis] + # } + #} + } + lappend outputlines $rendered + } else { + #padded overtext + #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] + #Note - we still need expand_right here - as although the overtext is short - it may oveflow due to the startoffset + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -expand_right $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] + #puts stderr "--> [ansistring VIEW -lf 1 -nul 1 $rinfo] <--" + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + lappend outputlines [tcl::dict::get $rinfo result] + } + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] + } + + return [join $outputlines \n] + } + + variable optimise_ptruns 10 ;# can be set to zero to disable the ptruns branches + + namespace eval argdoc { + variable PUNKARGS + + 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 { + 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 {} + + @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} { + # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### + # 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 {}\ + ] + #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller + + #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return + #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs + + #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency, currsor movements to 2nd charcol, or overflow/expand_right + #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error + + set argsflags [lrange $args 0 end-2] + tcl::dict::for {k v} $argsflags { + switch -- $k { + -experimental - -cp437 - -width - -expand_right - -transparent - -startcolumn - -cursor_column - -cursor_row + - -crm_mode - -insert_mode - -autowrap_mode - -reverse_mode + - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { + tcl::dict::set opts $k $v + } + default { + error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_etabs [tcl::dict::get $opts -etabs] + set opt_expand_right [tcl::dict::get $opts -expand_right] + set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay + set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay + set opt_row_context [tcl::dict::get $opts -cursor_row] + if {[string length $opt_row_context]} { + if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { + error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) + set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) + #default is for overtype + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM + set opt_crm_mode [tcl::dict::get $opts -crm_mode];# CRM - show control character mode + # -- --- --- --- --- --- --- --- --- --- --- --- + set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] + + set cp437_glyphs [tcl::dict::get $opts -cp437] + set cp437_map [tcl::dict::create] + if {$cp437_glyphs} { + set cp437_map [set ::punk::ansi::cp437_map] + #for cp437 images we need to map these *after* splitting ansi + #some old files might use newline for its glyph.. but we can't easily support that. + #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? + tcl::dict::unset cp437_map \n + } + + set opt_transparent [tcl::dict::get $opts -transparent] + if {$opt_transparent eq "0"} { + set do_transparency 0 + } else { + set do_transparency 1 + if {$opt_transparent eq "1"} { + set opt_transparent {[\s]} + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_returnextra [tcl::dict::get $opts -info] + # -- --- --- --- --- --- --- --- --- --- --- --- + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + # -- --- --- --- --- --- --- --- --- --- --- --- + + if {$opt_row_context eq ""} { + set cursor_row 1 + } else { + set cursor_row $opt_row_context + } + + set insert_mode $opt_insert_mode ;#default 1 + set autowrap_mode $opt_autowrap_mode ;#default 1 + set crm_mode $opt_crm_mode ;#default 0 (Show Control Character mode) + set reverse_mode $opt_reverse_mode + + #----- + # + if {[info exists punk::console::tabwidth]} { + #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted + #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync + #todo - we also need to handle the new threaded repl where console config is in a different thread. + # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? + set tw $::punk::console::tabwidth + } else { + set tw 8 + } + + set overdata $over + if {!$cp437_glyphs} { + #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text + if {!$opt_etabs} { + if {[string first \t $under] >= 0} { + #set under [textutil::tabify::untabify2 $under] + set under [textutil::tabify::untabifyLine $under $tw] + } + if {[string first \t $over] >= 0} { + #set overdata [textutil::tabify::untabify2 $over] + set overdata [textutil::tabify::untabifyLine $over $tw] + } + } + } + #------- + + #ta_detect ansi and do simpler processing? + + #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, + #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. + + # -- --- --- --- --- --- --- --- + if {$under ne ""} { + if {[punk::ansi::ta::detect $under]} { + set undermap [punk::ansi::ta::split_codes_single $under] + } else { + #single plaintext part + set undermap [list $under] + } + } else { + set undermap [list] + } + set understacks [list] + set understacks_gx [list] + set pm_list [list] + + set i_u -1 ;#underlay may legitimately be empty + set undercols [list] + set u_codestack [list] + #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway + set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) + #set pt_underchars "" ;#for string_columns length calculation for expand_right 0 truncation + set remainder [list] ;#for returnextra + foreach {pt code} $undermap { + #pt = plain text + #append pt_underchars $pt + if {$pt ne ""} { + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set hex [format %x [scan $p1 %c]] ;#punk::char::char_hex + set re [tcl::string::cat {^[} \\U$hex {]+$}] + set is_ptrun [regexp $re $pt] + } + if {$is_ptrun} { + #switch -- $p1 { + # " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + # a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + # z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + # set width 1 + # } + # default { + # if {$p1 eq "\u0000"} { + # #use null as empty cell representation - review + # #use of this will probably collide with some application at some point + # #consider an option to set the empty cell character + # set width 1 + # } else { + # set width [grapheme_width_cached $p1] ;# when zero??? + # } + # } + #} + set width [grapheme_width_cached $p1] ;# when zero??? + set ptlen [string length $pt] + if {$width <= 1} { + #review - 0 and 1? + incr i_u $ptlen + lappend understacks {*}[lrepeat $ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $ptlen $u_gx_stack] + lappend undercols {*}[lrepeat $ptlen $p1] + } else { + incr i_u $ptlen ;#2nd col empty str - so same as above + set 2ptlen [expr {$ptlen * 2}] + lappend understacks {*}[lrepeat $2ptlen $u_codestack] + lappend understacks_gx {*}[lrepeat $2ptlen $u_gx_stack] + set l [concat {*}[lrepeat $ptlen [list $p1 ""]]] + lappend undercols {*}$l + unset l + } + + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance + switch -- $grapheme { + " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - + a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - + z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { + set width 1 + } + default { + if {$grapheme eq "\u0000"} { + #use null as empty cell representation - review + #use of this will probably collide with some application at some point + #consider an option to set the empty cell character + set width 1 + } else { + #zero width still acts as 1 below??? review what should happen + set width [grapheme_width_cached $grapheme] + #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length + #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI + #todo - default to off and add a flag (?) to enable this substitution + set sub_stray_escapes 0 + if {$sub_stray_escapes && $width == 0} { + if {$grapheme eq "\x1b"} { + set gvis [ansistring VIEW $grapheme] ;#can only use with graphemes that have a single replacement char.. + set grapheme $gvis + set width 1 + } + } + } + } + } + + #set width [grapheme_width_cached $grapheme] + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + + lappend undercols $grapheme + if {$width > 1} { + #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) + #but what about emoji combinations etc - can they be wider than 2? + #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop + incr i_u + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + lappend undercols "" + } + } + + } + } + #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #keep any remaining PMs in place + if {$code ne ""} { + set c1c2 [tcl::string::range $code 0 1] + + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + \x1b^ 7PMX\ + \x1bX 7SOS\ + ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars + + switch -- $leadernorm { + 7CSI - 8CSI { + #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse + #REVIEW - what else could end in m but be mistaken as a normal SGR code here? + set maybemouse "" + if {[tcl::string::index $c1c2 0] eq "\x1b"} { + set maybemouse [tcl::string::index $code 2] + } + + if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set u_codestack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set u_codestack [list $code] + } else { + #basic simplification first.. straight dups + set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars + set u_codestack [lremove $u_codestack {*}$dup_posns] + lappend u_codestack $code + } + } + } + 7GFX { + switch -- [tcl::string::index $code 2] { + "0" { + set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess + } + B { + set u_gx_stack [list] + } + } + } + 7PMX - 7SOS { + #we can have PMs or SOS (start of string) in the underlay - though mostly the PMs should have been processed.. + #attach the PM/SOS (entire ANSI sequence) to the previous grapheme! + #It should not affect the size - but terminal display may get thrown out if terminal doesn't support them. + + #note that there may in theory already be ANSI stored - we don't assume it was a pure grapheme string + set graphemeplus [lindex $undercols end] + if {$graphemeplus ne "\0"} { + append graphemeplus $code + } else { + set graphemeplus $code + } + lset undercols end $graphemeplus + #The grapheme_width_cached function will be called on this later - and doesn't account for ansi. + #we need to manually cache the item with it's proper width + variable grapheme_widths + #stripped and plus version keys pointing to same length + dict set grapheme_widths $graphemeplus [grapheme_width_cached [::punk::ansi::ansistrip $graphemeplus]] + + } + default { + + } + + } + + #if {[punk::ansi::codetype::is_sgr_reset $code]} { + # #set u_codestack [list] + #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + #} elseif {[punk::ansi::codetype::is_sgr $code]} { + #} else { + # #leave SGR stack as is + # if {[punk::ansi::codetype::is_gx_open $code]} { + # } elseif {[punk::ansi::codetype::is_gx_close $code]} { + # } + #} + } + #consider also if there are other codes that should be stacked..? + } + + #NULL empty cell indicator + if {$opt_width ne "\uFFEF"} { + if {[llength $understacks]} { + set cs $u_codestack + set gs $u_gx_stack + } else { + set cs [list] + set gs [list] + } + if {[llength $undercols]< $opt_width} { + set diff [expr {$opt_width- [llength $undercols]}] + if {$diff > 0} { + #set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower + lappend undercols {*}[lrepeat $diff "\u0000"] + lappend understacks {*}[lrepeat $diff $cs] + lappend understacks_gx {*}[lrepeat $diff $gs] + } + } + } + + if {$opt_width ne "\uFFEF"} { + set renderwidth $opt_width + } else { + set renderwidth [llength $undercols] + } + + + if 0 { + # ----------------- + # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose + # Review. + # ----------------- + #replay code for last overlay position in input line + # whether or not we get that far - we need to return it for possible replay on next line + if {[llength $understacks]} { + lappend understacks $u_codestack + lappend understacks_gx $u_gx_stack + } else { + #in case overlay onto emptystring as underlay + lappend understacks [list] + lappend understacks_gx [list] + } + # ----------------- + } + + #trailing codes in effect for underlay + if {[llength $u_codestack]} { + #set replay_codes_underlay [join $u_codestack ""] + set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] + } else { + set replay_codes_underlay "" + } + + + # -- --- --- --- --- --- --- --- + #### + #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left containing the right number of columns. + #this will be processed as transparent - and handle doublewidth underlay characters appropriately + set startpadding [string repeat " " [expr {$opt_colstart -1}]] + #overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency + if {$startpadding ne "" || $overdata ne ""} { + if {[punk::ansi::ta::detect $overdata]} { + set overmap [punk::ansi::ta::split_codes_single $startpadding$overdata] + } else { + #single plaintext part + set overmap [list $startpadding$overdata] + } + } else { + set overmap [list] + } + #### + + + #todo - detect plain ascii no-ansi input line (aside from leading ansi reset) + #will that allow some optimisations? + + #todo - detect repeated transparent char in overlay + #regexp {^(.)\1+$} ;#backtracking regexp - relatively slow. + # - try set c [string index $data 0]; regexp [string map [list %c% $c] {^[%c%]+$}] $data + #we should be able to optimize to pass through the underlay?? + + #??? + set colcursor $opt_colstart + #TODO - make a little virtual column object + #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn + #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. + + + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes + + set overstacks [list] + set overstacks_gx [list] + + set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) + set o_gxstack [list] + set pt_overchars "" + set i_o 0 + set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use + #experiment + set overlay_grapheme_control_stacks [list] + foreach {pt code} $overmap { + if {$pt ne ""} { + #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) + if {$cp437_glyphs} { + set pt [tcl::string::map $cp437_map $pt] + } + append pt_overchars $pt + #will get empty pt between adjacent codes + if {!$crm_mode} { + + set is_ptrun 0 + if {$optimise_ptruns && [tcl::string::length $pt] >= $optimise_ptruns} { + set p1 [tcl::string::index $pt 0] + set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+$}] + set is_ptrun [regexp $re $pt] + + #leading only? we would have to check for graphemes at the trailing boundary? + #set re [tcl::string::cat {^[} \\U[format %x [scan $p1 %c]] {]+}] + #set is_ptrun [regexp -indices $re $pt runrange] + #if {$is_ptrun && 1} { + #} + } + if {$is_ptrun} { + #review - in theory a run over a certain length won't be part of some grapheme combo (graphemes can be long e.g 44?, but not as runs(?)) + #could be edge cases for runs at line end? (should be ok as we include trailing \n in our data) + set len [string length $pt] + set g_element [list g $p1] + + #lappend overstacks {*}[lrepeat $len $o_codestack] + #lappend overstacks_gx {*}[lrepeat $len $o_gxstack] + #incr i_o $len + #lappend overlay_grapheme_control_list {*}[lrepeat $len [list g $p1]] + #lappend overlay_grapheme_control_stacks {*}[lrepeat $len $o_codestack] + + set pi 0 + incr i_o $len + while {$pi < $len} { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + lappend overlay_grapheme_control_list $g_element + lappend overlay_grapheme_control_stacks $o_codestack + incr pi + } + } else { + foreach grapheme [punk::char::grapheme_split $pt] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } else { + set tsbegin [clock micros] + foreach grapheme_original [punk::char::grapheme_split $pt] { + set pt_crm [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $grapheme_original] + #puts stderr "ptlen [string length $pt] graphemelen[string length $grapheme_original] pt_crmlen[string length $pt_crm] $pt_crm" + foreach grapheme [punk::char::grapheme_split $pt_crm] { + if {$grapheme eq "\n"} { + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol "\x1b\[00001E"] + } else { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + } + set elapsed [expr {[clock micros] - $tsbegin}] + puts stderr "ptlen [string length $pt] elapsedus:$elapsed" + } + } + + #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc + #order of if-else based on assumptions: + # that pure resets are fairly common - more so than leading resets with other info + # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. + if {$code ne ""} { + #we need to immediately set crm_mode here if \x1b\[3h received + if {$code eq "\x1b\[3h"} { + set crm_mode 1 + } elseif {$code eq "\x1b\[3l"} { + set crm_mode 0 + } + #else crm_mode could be set either way from options + if {$crm_mode && $code ne "\x1b\[00001E"} { + #treat the code as type 'g' like above - only allow through codes to reset mode REVIEW for now just \x1b\[3l ? + #we need to somehow convert further \n in the graphical rep to an instruction for newline that will bypass further crm_mode processing or we would loop. + set code_as_pt [ansistring VIEW -nul 1 -lf 1 -vt 1 -ff 1 $code] + #split using standard split for first foreach loop - grapheme based split when processing 2nd foreach loop + set chars [split $code_as_pt ""] + set codeparts [list] ;#list of 2-el lists each element {crmcontrol } or {g } + foreach c $chars { + if {$c eq "\n"} { + #use CNL (cursor next line) \x1b\[00001E ;#leading zeroes ok for this processor - used as debugging aid to distinguish + lappend codeparts [list crmcontrol "\x1b\[00001E"] + } else { + if {[llength $codeparts] > 0 && [lindex $codeparts end 0] eq "g"} { + set existing [lindex $codeparts end 1] + lset codeparts end [list g [string cat $existing $c]] + } else { + lappend codeparts [list g $c] + } + } + } + + set partidx 0 + foreach record $codeparts { + lassign $record rtype rval + switch -exact -- $rtype { + g { + append pt_overchars $rval + foreach grapheme [punk::char::grapheme_split $rval] { + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + incr i_o + lappend overlay_grapheme_control_list [list g $grapheme] + lappend overlay_grapheme_control_stacks $o_codestack + } + } + crmcontrol { + #leave o_codestack + lappend overlay_grapheme_control_stacks $o_codestack + lappend overlay_grapheme_control_list [list crmcontrol $rval] + } + } + } + } else { + lappend overlay_grapheme_control_stacks $o_codestack + #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set o_codestack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #basic simplification first - remove straight dupes + set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars + set o_codestack [lremove $o_codestack {*}$dup_posns] + lappend o_codestack $code + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[regexp {\x1b7|\x1b\[s} $code]} { + #experiment + #cursor_save - for the replays review. + #jmn + #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + lappend overlay_grapheme_control_list [list other $code] + } elseif {[regexp {\x1b8|\x1b\[u} $code]} { + #experiment + #cursor_restore - for the replays + set o_codestack [list $temp_cursor_saved] + lappend overlay_grapheme_control_list [list other $code] + } else { + #review + if {[punk::ansi::codetype::is_gx_open $code]} { + set o_gxstack [list "gx0_on"] + lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } elseif {[punk::ansi::codetype::is_gx_close $code]} { + set o_gxstack [list] + lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets + } else { + lappend overlay_grapheme_control_list [list other $code] + } + } + } + } + + } + #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme + set max_overlay_grapheme_index [expr {$i_o -1}] + lappend overstacks $o_codestack + lappend overstacks_gx $o_gxstack + + #set replay_codes_overlay [join $o_codestack ""] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] + + #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { + # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] + #} else { + # set replay_codes_overlay "" + #} + # -- --- --- --- --- --- --- --- + + + #potential problem - combinining diacritics directly following control chars like \r \b + + # -- --- --- + #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 + if {$opt_expand_right} { + #expand_right true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. + #we currently only support horizontal expansion to the right (review regarding RTL text!) + set overflow_idx -1 + } else { + #expand_right zero - we can't grow beyond our column width - so we get ellipsis or truncation + if {$opt_width ne "\uFFEF"} { + set overflow_idx [expr {$opt_width}] + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } + # -- --- --- + + set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. + + set unapplied "" ;#if we break for move row (but not for /v ?) + set unapplied_list [list] + + set insert_lines_above 0 ;#return key + set insert_lines_below 0 + set instruction "" + + # -- --- --- + #cursor_save_dec, cursor_restore_dec etc + set cursor_restore_required 0 + set cursor_saved_attributes "" + set cursor_saved_position "" + # -- --- --- + + #set idx 0 ;# line index (cursor - 1) + #set idx [expr {$opt_colstart + $opt_colcursor} -1] + + #idx is the per column output index + set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 + #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. + #(for now we are incrementing/decrementing both in sync - which is a bit silly) + set cursor_column $opt_colcursor + + #idx_over is the per grapheme overlay index + set idx_over -1 + + + #movements only occur within the overlay range. + #an underlay is however not necessary.. e.g + #renderline -expand_right 1 "" data + + #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM + #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} + #set re_row_move {\x1b\[([0-9]*)(A|B)$} + #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? + #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} + #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! + #set re_cursor_restore {\x1b\[u$} + #set re_cursor_save_dec {\x1b7$} + #set re_cursor_restore_dec {\x1b8$} + #set re_other_single {\x1b(D|M|E)$} + #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins + + #puts "-->$overlay_grapheme_control_list<--" + #puts "-->overflow_idx: $overflow_idx" + for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { + set gc [lindex $overlay_grapheme_control_list $gci] + lassign $gc type item + + #emit plaintext chars first using existing SGR codes from under/over stack as appropriate + #then check if the following code is a cursor movement within the line and adjust index if so + #foreach ch $overlay_graphemes {} + switch -- $type { + g { + set ch $item + #crm_mode affects both graphic and control + if {0 && $crm_mode} { + set chars [ansistring VIEW -nul 1 -lf 2 -vt 2 -ff 2 $ch] + set chars [string map [list \n "\x1b\[00001E"] $chars] + if {[llength [split $chars ""]] > 1} { + priv::render_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + #incr idx_over + break + } else { + set ch $chars + } + } + incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. + if {($idx < ($opt_colstart -1))} { + incr idx [grapheme_width_cached $ch] + continue + } + #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width + set within_undercols [expr {$idx <= $renderwidth-1}] + + #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters + #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, + #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. + #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable + #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE + + set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] + #puts --->chtest:$chtest + #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached + switch -- $chtest { + "" { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + if {$idx == 0} { + #puts "---a at col 1" + #linefeed at column 1 + #leave the overflow_idx ;#? review + set instruction lf_start ;#specific instruction for newline at column 1 + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { + #linefeed after final column + #puts "---c at overflow_idx=$overflow_idx" + incr cursor_row + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + #linefeed occurred in middle or at end of text + #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" + if {$insert_mode == 0} { + incr cursor_row + if {$idx == -1 || $overflow_idx > $idx} { + #don't set overflow_idx higher if it's already set lower and we're adding graphemes to overflow + set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to expand_right = 1 + } + set instruction lf_mid + priv::render_unapplied $overlay_grapheme_control_list $gci + break + } else { + incr cursor_row + #don't adjust the overflow_idx + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction lf_mid + break ;# could have overdata following the \n - don't keep processing + } + } + + } + "" { + #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) + #So far we are assuming the caller has translated to and handle above.. REVIEW. + + #consider also the old space-carriagereturn softwrap convention used in some terminals. + #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. + set idx [expr {$opt_colstart -1}] + set cursor_column $opt_colstart ;#? + } + "" { + #literal backspace char - not necessarily from keyboard + #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype + #(important for -transparent option - hence replacement chars for half-exposed etc) + #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) + if {$idx > ($opt_colstart -1)} { + incr idx -1 + incr cursor_column -1 + } else { + set flag 0 + if $flag { + #review - conflicting requirements? Need a different sequence for destructive interactive backspace? + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction backspace_at_start + break + } + } + } + "" { + #literal del character - some terminals send just this for what is generally expected to be a destructive backspace + #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. + priv::render_delchar $idx + } + "" { + #end processing this overline. rest of line is remainder. cursor for column as is. + #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) + #e.g it could be configured to jump down 6 rows. + #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. + #todo? + incr cursor_row + set overflow_idx $idx + #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction vt + break + } + default { + if {$overflow_idx != -1} { + #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? + #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? + #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc + if {$idx == $overflow_idx-1} { + set owidth [grapheme_width_cached $ch] + if {$owidth == 2} { + #review split 2w overflow? + #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line + #better to consider the overlay char as unable to be applied to the line + #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied + #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. + priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #change the overflow_idx + set overflow_idx $idx + incr idx + incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used + priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci + #throw back to caller's loop - add instruction to caller as this is not the usual case + #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line + set instruction overflow_splitchar + break + } elseif {$owidth > 2} { + #? tab? + #TODO! + puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" + #tab of some length dependent on tabstops/elastic tabstop settings? + } + } elseif {$idx >= $overflow_idx} { + #REVIEW + set next_gc [lindex $overlay_grapheme_control_list $gci+1] ;#next grapheme or control + lassign $next_gc next_type next_item + if {$autowrap_mode || $next_type ne "g"} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #don't incr idx beyond the overflow_idx + #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied + incr idx_over -1 + #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too + priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# + set instruction overflow + break + } else { + #no point throwing back to caller for each grapheme that is overflowing + #without this branch - renderline would be called with overtext reducing only by one grapheme per call + #processing a potentially long overtext each time (ie - very slow) + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #JMN4 + + } + } + } else { + #review. + #overflow_idx = -1 + #This corresponds to expand_right being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) + } + + if {($do_transparency && [regexp $opt_transparent $ch])} { + #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) + if {$idx > [llength $outcols]-1} { + lappend outcols " " + #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? + #lset understacks $idx [list] ;#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_unapplied $overlay_grapheme_control_list $gci + #prefix the unapplied controls with the string version of this control + set unapplied_list [linsert $unapplied_list 0 {*}[split $chars ""]] + set unapplied [join $unapplied_list ""] + + break + } + } + + #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. + #we should possibly therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore? + set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] + #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' + + + #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI + #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping + #review - cost/benefit of function calls within these switch-arms instead of inline code? + + set c1 [tcl::string::index $code 0] + set c1c2c3 [tcl::string::range $code 0 2] + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. + #(somewhat surprising) + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[< 1006\ + \x1b\[ 7CSI\ + \x1bY 7MAP\ + \x1bP 7DCS\ + \x90 8DCS\ + \x9b 8CSI\ + \x1b\] 7OSC\ + \x9d 8OSC\ + \x1b 7ESC\ + ] $c1c2c3] 0 3] ;#leadernorm is 1st 1,2 or 3 chars mapped to 4char normalised indicator - or is original first chars (1,2 or 3 len) + + #we leave the tail of the code unmapped for now + switch -- $leadernorm { + 1006 { + #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html + #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] + } + 7CSI - 7OSC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + set codenorm $leadernorm[tcl::string::range $code 2 end] + } + 7DCS { + #ESC P + #Device Control String https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h4-Controls-beginning-with-ESC:ESC-F.C74 + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] + } + 8DCS { + #8-bit Device Control String + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + 7MAP { + #map to another type of code to share implementation branch + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 7ESC { + #set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + set codenorm $leadernorm[tcl::string::range $code 1 end] + } + 8CSI - 8OSC { + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] + } + default { + puts stderr "Sequence detected as ANSI, but not handled in leadernorm switch. code: [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #we haven't made a mapping for this + #could in theory be 1,2 or 3 in len + #although we shouldn't be getting here if the regexp for ansi codes is kept in sync with our switch branches + set codenorm $code + } + } + + switch -- $leadernorm { + 7MAP { + switch -- [lindex $codenorm 4] { + Y { + #vt52 movement. we expect 2 chars representing position (limited range) + set params [tcl::string::range $codenorm 5 end] + if {[tcl::string::length $params] != 2} { + #shouldn't really get here or need this branch if ansi splitting was done correctly + puts stderr "overtype::renderline ESC Y recognised as vt52 move, but incorrect parameters length ([string length $params] vs expected 2) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + set line [tcl::string::index $params 5] + set column [tcl::string::index $params 1] + set r [expr {[scan $line %c] -31}] + set c [expr {[scan $column %c] -31}] + + #MAP to: + #CSI n;m H - CUP - Cursor Position + set leadernorm 7CSI + set codenorm "$leadernorm${r}\;${c}H" + } + } + } + } + + #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. + switch -- $leadernorm { + 1006 { + #TODO + # + switch -- [tcl::string::index $codenorm end] { + M { + puts stderr "mousedown $codenorm" + } + m { + puts stderr "mouseup $codenorm" + } + } + + } + {7CSI} - {8CSI} { + set param [tcl::string::range $codenorm 4 end-1] + #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" + set code_end [tcl::string::index $codenorm end] ;#used for e.g h|l set/unset mode + + switch -exact -- $code_end { + A { + #Row move - up + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #todo + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + + if {$num eq ""} {set num 1} + incr cursor_row -$num + + if {$cursor_row < 1} { + set cursor_row 1 + } + + #ensure rest of *overlay* is emitted to remainder + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up + #retain cursor_column + break + } + B { + #CUD - Cursor Down + #Row move - down + lassign [split $param {;}] num modifierkey + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move down + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + incr cursor_row $num + + + incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + C { + #CUF - Cursor Forward + #Col move + #puts stdout "->forward" + #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. + #cursor forward + #right-arrow/move forward + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + #todo - retrict to moving 1 position past datalen? restrict to column width? + #should ideally wrap to next line when interactive and not on last row + #(some ansi art seems to expect this behaviour) + #This presumably depends on the terminal's wrap mode + #e.g DECAWM autowrap mode + # CSI ? 7 h - set: autowrap (also tput smam) + # CSI ? 7 l - reset: no autowrap (also tput rmam) + set version 2 + if {$version eq "2"} { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$cursor_column == $max+1} { + #move_forward while in overflow + incr cursor_column -1 + } + + if {($cursor_column + $num) <= $max} { + incr idx $num + incr cursor_column $num + } else { + if {$autowrap_mode} { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #jmn + if {$idx == $overflow_idx} { + incr num + } + + #horizontal movement beyond line extent needs to wrap - throw back to caller + #we may have both overflow_right and unapplied data + #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) + #leave row as is - caller will need to determine how many rows the column-movement has consumed + incr cursor_column $num ;#give our caller the necessary info as columns from start of row + #incr idx_over + #should be gci following last one applied + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmoveforward + break + } else { + set cursor_column $max + set idx [expr {$cursor_column -1}] + } + } + } else { + #review - dead branch + if {!$expand_right || ($cursor_column + $num) <= [llength $outcols+1]} { + incr idx $num + incr cursor_column $num + } else { + if {!$insert_mode} { + #block editing style with arrow keys + #overtype mode + set idxstart $idx + set idxend [llength $outcols] + set moveend [expr {$idxend - $idxstart}] + if {$moveend < 0} {set moveend 0} ;#sanity? + #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" + incr idx $moveend + incr cursor_column $moveend + #if {[tcl::dict::exists $understacks $idx]} { + # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + #} else { + # set stackinfo [list] + #} + if {$idx < [llength $understacks]} { + set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + } else { + set stackinfo [list] + } + if {$idx < [llength $understacks_gx]} { + #set gxstackinfo [tcl::dict::get $understacks_gx $idx] + set gxstackinfo [lindex $understacks_gx $idx] + } else { + set gxstackinfo [list] + } + #pad outcols + set movemore [expr {$num - $moveend}] + #assert movemore always at least 1 or we wouldn't be in this branch + for {set m 1} {$m <= $movemore} {incr m} { + incr idx + incr cursor_column + priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode + } + } else { + #normal - insert + incr idx $num + incr cursor_column $num + if {$idx > [llength $outcols]} { + set idx [llength $outcols];#allow one beyond - for adding character at end of line + set cursor_column [expr {[llength $outcols]+1}] + } + } + } + } + } + D { + #Col move + #puts stdout "<-back" + #cursor back + #left-arrow/move-back when ltr mode + lassign [split $param {;}] num modifierkey + if {$modifierkey ne ""} { + puts stderr "modifierkey:$modifierkey" + } + if {$num eq ""} {set num 1} + + set version 2 + if {$version eq "2"} { + #todo - startcolumn offset! + if {$cursor_column - $num >= 1} { + incr idx -$num + incr cursor_column -$num + } else { + if {!$autowrap_mode} { + set cursor_column 1 + set idx 0 + } else { + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr cursor_column -$num + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction wrapmovebackward + break + } + } + } else { + incr idx -$num + incr cursor_column -$num + if {$idx < $opt_colstart-1} { + #wrap to previous line and position cursor at end of data + set idx [expr {$opt_colstart-1}] + set cursor_column $opt_colstart + } + } + } + E { + #CNL - Cursor Next Line + if {$param eq ""} { + set downmove 1 + } else { + set downmove [expr {$param}] + } + puts stderr "renderline CNL down-by-$downmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row + $downmove}] + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + F { + #CPL - Cursor Previous Line + if {$param eq ""} { + set upmove 1 + } else { + set upmove [expr {$param}] + } + puts stderr "renderline CPL up-by-$upmove" + set cursor_column 1 + set cursor_row [expr {$cursor_row -$upmove}] + if {$cursor_row < 1} { + set cursor_row 1 + } + set idx [expr {$cursor_column - 1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + + } + G { + #CHA - Cursor Horizontal Absolute (move to absolute column no) + if {$param eq ""} { + set targetcol 1 + } else { + set targetcol $param + if {![string is integer -strict $targetcol]} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Unrecognised parameter '$param'" + } + set targetcol [expr {$param}] + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$targetcol > $max} { + puts stderr "renderline CHA (Cursor Horizontal Absolute) error. Param '$param' > max: $max" + set targetcol $max + } + } + #adjust to colstart - as column 1 is within overlay + #??? REVIEW + set idx [expr {($targetcol -1) + $opt_colstart -1}] + + set cursor_column $targetcol + #puts stderr "renderline absolute col move ESC G (TEST)" + } + H - f { + #CSI n;m H - CUP - Cursor Position + + #CSI n;m f - HVP - Horizontal Vertical Position REVIEW - same as CUP with differences (what?) in some terminal modes + # - 'counts as effector format function (like CR or LF) rather than an editor function (like CUD or CNL)' + # - REVIEW + #see Annex A at: https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf + + #test e.g ansicat face_2.ans + #$re_both_move + lassign [split $param {;}] paramrow paramcol + #missing defaults to 1 + #CSI ;5H = CSI 1;5H -> row 1 col 5 + #CSI 17;H = CSI 17H = CSI 17;1H -> row 17 col 1 + + if {$paramcol eq ""} {set paramcol 1} + if {$paramrow eq ""} {set paramrow 1} + if {![string is integer -strict $paramcol] || ![string is integer -strict $paramrow]} { + puts stderr "renderline CUP (CSI H) unrecognised param $param" + #ignore? + } else { + set max [llength $outcols] + if {$overflow_idx == -1} { + incr max + } + if {$paramcol > $max} { + set target_column $max + } else { + set target_column [expr {$paramcol}] + } + + + if {$paramrow < 1} { + puts stderr "renderline CUP (CSI H) bad row target 0. Assuming 1" + set target_row 1 + } else { + set target_row [expr {$paramrow}] + } + if {$target_row == $cursor_row} { + #col move only - no need for break and move + #puts stderr "renderline CUP col move only to col $target_column param:$param" + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + } else { + set cursor_row $target_row + set cursor_column $target_column + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move + break + } + } + } + J { + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + #CSI ? Pn J - selective erase + puts stderr "overtype::renderline ED - SELECTIVE ERASE IN DISPLAY (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ED - ERASE IN DISPLAY (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of screen + } + 1 { + #clear from cursor to beginning of screen + } + 2 { + #clear entire screen + #ansi.sys - move cursor to upper left REVIEW + set cursor_row 1 + set cursor_column 1 + set idx [expr {$cursor_column -1}] + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + incr idx_over + if {[llength $outcols]} { + priv::render_erasechar 0 [llength $outcols] + } + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction clear_and_move + break + } + 3 { + #clear entire screen. presumably cursor doesn't move - otherwise it would be same as 2J ? + + } + default { + } + } + + } + } + } + K { + #see DECECM regarding background colour + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? + switch -exact -- $modegroup { + ? { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE (UNIMPLEMENTED) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + set param [string range $param 1 end] ;#chop qmark + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line - depending on DECSCA + } + 1 { + #clear from cursor to beginning of line - depending on DECSCA + + } + 2 { + #clear entire line - depending on DECSCA + } + default { + puts stderr "overtype::renderline DECSEL - SELECTIVE ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE (TESTING) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$param eq ""} {set param 0} + switch -exact -- $param { + 0 { + #clear from cursor to end of line + } + 1 { + #clear from cursor to beginning of line + + } + 2 { + #clear entire line + } + default { + puts stderr "overtype::renderline EL - ERASE IN LINE PARAM '$param' unrecognised [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + } + } + } + L { + puts stderr "overtype::renderline IL - Insert Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + M { + #CSI Pn M - DL - Delete Line + puts stderr "overtype::renderline DL - Delete Line - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + } + T { + #CSI Pn T - SD Pan Up (empty lines introduced at top) + #CSI Pn+T - kitty extension (lines at top come from scrollback buffer) + #Pn new lines appear at top of the display, Pn old lines disappear at the bottom of the display + if {$param eq "" || $param eq "0"} {set param 1} + if {[string index $param end] eq "+"} { + puts stderr "overtype::renderline CSI Pn + T - kitty Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } else { + puts stderr "overtype::renderline CSI Pn T - SD Pan Up - not implemented [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + X { + puts stderr "overtype::renderline X ECH ERASE CHARACTER - $param" + #ECH - erase character + if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase + priv::render_erasechar $idx $param + #cursor position doesn't change. + } + q { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + {"} { + #DECSCA - Select Character Protection Attribute + #(for use with selective erase: DECSED and DECSEL) + set param [tcl::string::range $codenorm 4 end-2] + if {$param eq ""} {set param 0} + #TODO - store like SGR in stacks - replays? + switch -exact -- $param { + 0 - 2 { + #canerase + puts stderr "overtype::renderline - DECSCA canerase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 1 { + #cannoterase + puts stderr "overtype::renderline - DECSCA cannoterase not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline DECSCA param '$param' not understood [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + puts stderr "overtype::renderline - CSI ... q not implemented - [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + r { + #$re_decstbm + #https://www.vt100.net/docs/vt510-rm/DECSTBM.html + #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins + lassign [split $param {;}] margin_top margin_bottom + + #todo - return these for the caller to process.. + puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" + #Also moves the cursor to col 1 line 1 of the page + set cursor_column 1 + set cursor_row 1 + + incr idx_over + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction move ;#own instruction? decstbm? + break + } + s { + #code conflict between ansi emulation and DECSLRM - REVIEW + #ANSISYSSC (when no parameters) - like other terminals - essentially treat same as DECSC + # todo - when parameters - support DECSLRM instead + + if {$param ne ""} { + #DECSLRM - should only be recognised if DECLRMM is set (vertical split screen mode) + lassign [split $param {;}] margin_left margin_right + puts stderr "overtype DECSLRM not yet supported - got [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + if {$margin_left eq ""} { + set margin_left 1 + } + set columns_per_page 80 ;#todo - set to 'page width (DECSCPP set columns per page)' - could be 132 or?? + if {$margin_right eq ""} { + set margin_right $columns_per_page + } + puts stderr "DECSLRM margin left: $margin_left margin right: $margin_right" + if {![string is integer -strict $margin_left] || $margin_left < 0} { + puts stderr "DECSLRM invalid margin_left" + } + if {![string is integer -strict $margin_right] || $margin_right < 0} { + puts stderr "DECSLRM invalid margin_right" + } + set scrolling_region_size [expr {$margin_right - $margin_left}] + if {$scrolling_region_size < 2 || $scrolling_region_size > $columns_per_page} { + puts stderr "DECSLRM region size '$scrolling_regsion_size' must be between 1 and $columns_per_page" + } + #todo + + + } else { + #DECSC + #//notes on expected behaviour: + #DECSC - saves following items in terminal's memory + #cursor position + #character attributes set by the SGR command + #character sets (G0,G1,G2 or G3) currently in GL and GR + #Wrap flag (autowrap or no autowrap) + #State of origin mode (DECOM) + #selective erase attribute + #any single shift 2 (SS2) or single shift 3(SSD) functions sent + + #$re_cursor_save + #cursor save could come after last column + if {$overflow_idx != -1 && $idx == $overflow_idx} { + #bartman2.ans test file - fixes misalignment at bottom of dialog bubble + #incr cursor_row + #set cursor_column 1 + #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) + set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] + } else { + set cursor_saved_position [list row $cursor_row column $cursor_column] + } + #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. + #we need the SGR and gx overlay codes prior to the cursor_save + + #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. + #set sgr_stack [lindex $understacks $idx] + #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) + + set sgr_stack [list] + set gx_stack [list] + + #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. + #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. + + foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { + lassign $gc type code + #types g other sgr gx0 + switch -- $type { + gx0 { + #code is actually a stand-in for the graphics on/off code - not the raw code + #It is either gx0_on or gx0_off + set gx_stack [list $code] + } + sgr { + #code is the raw code + if {[punk::ansi::codetype::is_sgr_reset $code]} { + #jmn + set sgr_stack [list "\x1b\[m"] + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set sgr_stack [list $code] + lappend overlay_grapheme_control_list [list sgr $code] + } elseif {[priv::is_sgr $code]} { + #often we don't get resets - and codes just pile up. + #as a first step to simplifying - at least remove earlier straight up dupes + set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) + set sgr_stack [lremove $sgr_stack {*}$dup_posns] + lappend sgr_stack $code + } + } + } + } + set cursor_saved_attributes "" + switch -- [lindex $gx_stack 0] { + gx0_on { + append cursor_saved_attributes "\x1b(0" + } + gx0_off { + append cursor_saved_attributes "\x1b(B" + } + } + #append cursor_saved_attributes [join $sgr_stack ""] + append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] + + #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. + + #don't incr index - or the save will cause cursor to move to the right + #carry on + } + } + u { + #ANSISYSRC save cursor (when no parameters) (DECSC) + + #$re_cursor_restore + #we are going to jump somewhere.. for now we will assume another line, and process accordingly. + #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) + #don't set overflow at this point. The existing underlay to the right must be preserved. + #we only want to jump and render the unapplied at the new location. + + #lset overstacks $idx_over [list] + #set replay_codes_overlay "" + + #if {$cursor_saved_attributes ne ""} { + # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk + #} else { + #jj + #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + set replay_codes_overlay "" + #} + + #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code + incr idx_over + + set unapplied "" + set unapplied_list [list] + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + #incr idx_over + } + set unapplied [join $unapplied_list ""] + #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. + set instruction restore_cursor + break + } + "{" { + + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + "}" { + set code_secondlast [tcl::string::index $codenorm end-1] + switch -exact -- $code_secondlast { + ' { + puts stderr "renderline warning - DECIC - Insert Column - CSI...' - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + default { + puts stderr "renderline warning - CSI.. - unimplemented [ansistring VIEW -lf 1 -nul 1 $code]" + } + } + } + ~ { + set code_secondlast [tcl::string::index $codenorm end-1] ;#used for e.g CSI x '~ + switch -exact -- $code_secondlast { + ' { + #DECDC - editing sequence - Delete Column + puts stderr "renderline warning - DECDC - unimplemented" + } + default { + #$re_vt_sequence + lassign [split $param {;}] key mod + + #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ + # + #e.g esc \[2~ insert esc \[2;2~ shift-insert + #mod - subtract 1, and then use bitmask + #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) + #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" + if {$key eq "1"} { + #home + } elseif {$key eq "2"} { + #Insert + if {$mod eq ""} { + #no modifier key + set insert_mode [expr {!$insert_mode}] + #rather than set the cursor - we return the insert mode state so the caller can decide + } + } elseif {$key eq "3"} { + #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end + switch -- $mod { + "" { + priv::render_delchar $idx + } + "5" { + #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) + } + } + } elseif {$key eq "4"} { + #End + } elseif {$key eq "5"} { + #pgup + } elseif {$key eq "6"} { + #pgDn + } elseif {$key eq "7"} { + #Home + #?? + set idx [expr {$opt_colstart -1}] + set cursor_column 1 + } elseif {$key eq "8"} { + #End + } elseif {$key eq "11"} { + #F1 - or ESCOP or e.g shift F1 ESC\[1;2P + } elseif {$key eq "12"} { + #F2 - or ESCOQ + } elseif {$key eq "13"} { + #F3 - or ESCOR + } elseif {$key eq "14"} { + #F4 - or ESCOS + } elseif {$key eq "15"} { + #F5 or shift F5 ESC\[15;2~ + } elseif {$key eq "17"} { + #F6 + } elseif {$key eq "18"} { + #F7 + } elseif {$key eq "19"} { + #F8 + } elseif {$key eq "20"} { + #F9 + } elseif {$key eq "21"} { + #F10 + } elseif {$key eq "23"} { + #F11 + } elseif {$key eq "24"} { + #F12 + } + + } + } + + } + h - l { + #set mode unset mode + #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? + + #$re_mode if first after CSI is "?" + #some docs mention ESC=h|l - not seen on windows terminals.. review + #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html + set modegroup [tcl::string::index $codenorm 4] ;#e.g ? = + switch -exact -- $modegroup { + ? { + set smparams [tcl::string::range $codenorm 5 end-1] ;#params between ? and h|l + #one or more modes can be set + set smparam_list [split $smparams {;}] + foreach num $smparam_list { + switch -- $num { + "" { + #ignore empties e.g extra/trailing semicolon in params + } + 5 { + #DECSNM - reverse video + #How we simulate this to render within a block of text is an open question. + #track all SGR stacks and constantly flip based on the current SGR reverse state? + #It is the job of the calling loop to do this - so at this stage we'll just set the states + + if {$code_end eq "h"} { + #set (enable) + set reverse_mode 1 + } else { + #reset (disable) + set reverse_mode 0 + } + + } + 7 { + #DECAWM autowrap + if {$code_end eq "h"} { + #set (enable) + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? + # presume not usually - but sanity check with warning for now. + if {$idx >= $overflow_idx} { + puts stderr "renderline warning - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" + } + } else { + #reset (disable) + set autowrap_mode 0 + #REVIEW! + set overflow_idx -1 + } + } + 25 { + if {$code_end eq "h"} { + #visible cursor + + } else { + #invisible cursor + + } + } + 117 { + #DECECM - Erase Color Mode + #https://invisible-island.net/ncurses/ncurses.faq.html + #The Erase color selection controls the background color used when text is erased or new + #text is scrolled on to the screen. Screen background causes newly erased areas or + #scrolled text to be written using color index zero, the screen background. This is VT + #and DECterm compatible. Text background causes erased areas or scrolled text to be + #written using the current text background color. This is PC console compatible and is + #the factory default. + + #see also: https://unix.stackexchange.com/questions/251726/clear-to-end-of-line-uses-the-wrong-background-color-in-screen + } + } + } + } + = { + set num [tcl::string::range $codenorm 5 end-1] ;#param between = and h|l + puts stderr "overtype::renderline CSI=...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + default { + #e.g CSI 4 h + set num [tcl::string::range $codenorm 4 end-1] ;#param before h|l + switch -exact -- $num { + 3 { + puts stderr "CRM MODE $code_end" + #CRM - Show control character mode + # 'No control functions are executed except LF,FF and VT which are represented in the CRM FONT before a CRLF(new line) is executed' + # + #use ansistring VIEW -nul 1 -lf 2 -ff 2 -vt 2 + #https://vt100.net/docs/vt510-rm/CRM.html + #NOTE - vt100 CRM always does auto-wrap at right margin. + #disabling auto-wrap in set-up or by sequence is disabled. + #We should default to turning off auto-wrap when crm_mode enabled.. but + #displaying truncated (on rhs) crm can still be very useful - and we have optimisation in overflow to avoid excess renderline calls (per grapheme) + #we therefore could reasonably put in an exception to allow auto_wrap to be disabled after crm_mode is engaged, + #although this would be potentially an annoying difference to some.. REVIEW + if {$code_end eq "h"} { + set crm_mode 1 + set autowrap_mode 1 + if {$opt_width ne "\uFFEF"} { + set overflow_idx $opt_width + } else { + #review - this is also the cursor position when adding a char at end of line? + set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it + } + } else { + set crm_mode 0 + } + } + 4 { + #IRM - Insert/Replace Mode + if {$code_end eq "h"} { + #CSI 4 h + set insert_mode 1 + } else { + #CSI 4 l + #replace mode + set insert_mode 0 + } + } + default { + puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + } + } + | { + switch -- [tcl::string::index $codenorm end-1] { + {$} { + #CSI ... $ | DECSCPP set columns per page- (recommended in vt510 docs as preferable to DECCOLM) + #real terminals generally only supported 80/132 + #some other virtuals support any where from 2 to 65,536? + #we will allow arbitrary widths >= 2 .. to some as yet undetermined limit. + #CSI $ | + #empty or 0 param is 80 for compatibility - other numbers > 2 accepted + set page_width -1 ;#flag as unset + if {$param eq ""} { + set page_width 80 + } elseif {[string is integer -strict $param] && $param >=2} { + set page_width [expr {$param}] ;#we should allow leading zeros in the number - but lets normalize using expr + } else { + puts stderr "overtype::renderline unacceptable DECSPP value '$param'" + } + + if {$page_width > 2} { + puts stderr "overtype::renderline DECSCPP - not implemented - but selected width '$page_width' looks ok" + #if cursor already beyond new page_width - will move to right colum - otherwise no cursor movement + + } + + } + default { + puts stderr "overtype::renderline unrecognised CSI code ending in pipe (|) [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + default { + puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" + } + } + } + 7ESC { + # + #re_other_single {\x1b(D|M|E)$} + #also vt52 Y.. + #also PM \x1b^...(ST) + switch -- [tcl::string::index $codenorm 4] { + c { + #RIS - reset terminal to initial state - where 'terminal' in this case is the renderspace - not the underlying terminal! + puts stderr "renderline reset" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction reset + break + } + D { + #\x84 + #index (IND) + #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" + puts stderr "renderline ESC D not fully implemented" + incr cursor_row + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction down + #retain cursor_column + break + } + E { + #\x85 + #review - is behaviour different to lf? + #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL + #leave implementation until logic for is set in stone... still under review + #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. + # + #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" + puts stderr "overtype::renderline ESC E unimplemented" + + } + H { + #\x88 + #Tab Set + puts stderr "overtype::renderline ESC H tab set unimplemented" + } + M { + #\x8D + #Reverse Index (RI) + #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" + puts stderr "overtype::renderline ESC M not fully implemented" + + set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] + #move up + incr cursor_row -1 + if {$cursor_row < 1} { + set cursor_row 1 + } + #ensure rest of *overlay* is emitted to remainder + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction up ;#need instruction for scroll-down? + #retain cursor_column + break + } + N { + #\x8e - affects next character only + puts stderr "overtype::renderline single shift select G2 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + O { + #\x8f - affects next character only + puts stderr "overtype::renderline single shift select G3 command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + P { + #\x90 + #DCS - shouldn't get here - handled in 7DCS branch + #similarly \] OSC (\x9d) and \\ (\x9c) ST + } + V { + #\x96 + + } + W { + #\x97 + } + X { + #\x98 + #SOS + if {[string index $code end] eq "\007"} { + set sos_content [string range $code 2 end-1] ;#ST is \007 + } else { + set sos_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #return in some useful form to the caller + #TODO! + lappend sos_list [list string $sos_content row $cursor_row column $cursor_column] + puts stderr "overtype::renderline ESCX SOS UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + ^ { + #puts stderr "renderline PM" + #Privacy Message. + if {[string index $code end] eq "\007"} { + set pm_content [string range $code 2 end-1] ;#ST is \007 + } else { + set pm_content [string range $code 2 end-2] ;#ST is \x1b\\ + } + #We don't want to render it - but we need to make it available to the application + #see the textblock library in punk, for the exception we make here for single backspace. + #It is unlikely to be encountered as a useful PM - so we hack to pass it through as a fix + #for spacing issues on old terminals which miscalculate the single-width 'Symbols for Legacy Computing' + if {$pm_content eq "\b"} { + #puts stderr "renderline PM sole backspace special handling for \U1FB00 - \U1FBFF" + #esc^\b\007 or esc^\besc\\ + #HACKY pass-through - targeting terminals that both mis-space legacy symbols *and* don't support PMs + #The result is repair of the extra space. If the terminal is a modern one and does support PM - the \b should be hidden anyway. + #If the terminal has the space problem AND does support PMs - then this just won't fix it. + #The fix relies on the symbol-supplier to cooperate by appending esc^\b\esc\\ to the problematic symbols. + + #priv::render_addchar $idx $code [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode + #idx has been incremented after last grapheme added + priv::render_append_to_char [expr {$idx -1}] $code + } + #lappend to a dict element in the result for application-specific processing + lappend pm_list $pm_content + } + _ { + #APC Application Program Command + #just warn for now.. + puts stderr "overtype::renderline ESC_ APC command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + default { + puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented codenorm:[ansistring VIEW -lf 1 -vt 1 -nul 1 $codenorm]" + } + } + + } + 7DCS - 8DCS { + puts stderr "overtype::renderline DCS - DEVICE CONTROL STRING command UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + #ST (string terminator) \x9c or \x1b\\ + if {[tcl::string::index $codenorm end] eq "\x9c"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is 8-bit 0x9c + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + + } + 7OSC - 8OSC { + # OSCs are terminated with ST of either \007 or \x1b\\ - we allow either whether code was 7 or 8 bit + if {[tcl::string::index $codenorm end] eq "\007"} { + set code_content [tcl::string::range $codenorm 4 end-1] ;#ST is \007 + } else { + set code_content [tcl::string::range $codenorm 4 end-2] ;#ST is \x1b\\ + } + set first_colon [tcl::string::first {;} $code_content] + if {$first_colon == -1} { + #there probably should always be a colon - but we'll try to make sense of it without + set osc_code $code_content ;#e.g \x1b\]104\007 vs \x1b\]104\;\007 + } else { + set osc_code [tcl::string::range $code_content 0 $first_colon-1] + } + switch -exact -- $osc_code { + 2 { + set newtitle [tcl::string::range $code_content 2 end] + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list set_window_title $newtitle] + break + } + 4 { + #OSC 4 - set colour palette + #can take multiple params + #e.g \x1b\]4\;1\;red\;2\;green\x1b\\ + set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon + set cmap [dict create] + foreach {cnum spec} [split $params {;}] { + if {$cnum >= 0 && $cnum <= 255} { + #todo - parse spec from names like 'red' to RGB + #todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc) + #also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ? + dict set cmap $cnum $spec + } else { + #todo - log + puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 10 - 11 - 12 - 13 - 14 - 15 - 16 - 17 { + #OSC 10 through 17 - so called 'dynamic colours' + #can take multiple params - each successive parameter changes the next colour in the list + #- e.g if code started at 11 - next param is for 12. 17 takes only one param because there are no more + #10 change text foreground colour + #11 change text background colour + #12 change text cursor colour + #13 change mouse foreground colour + #14 change mouse background colour + #15 change tektronix foreground colour + #16 change tektronix background colour + #17 change highlight colour + set params [tcl::string::range $code_content 2 end] + + puts stderr "overtype::renderline OSC $osc_code set dynamic colours unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + + + } + 18 { + #why is this not considered one of the dynamic colours above? + #https://www.xfree86.org/current/ctlseqs.html + #tektronix cursor color + puts stderr "overtype::renderline OSC 18 - set tektronix cursor color unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 99 { + #kitty desktop notifications + #https://sw.kovidgoyal.net/kitty/desktop-notifications/ + # 99 ; metadata ; payload + puts stderr "overtype::renderline OSC 99 kitty desktop notification unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + 104 { + #reset colour palette + #we want to do it for the current rendering context only (vvt) - not just pass through to underlying vt + puts stderr "overtype::renderline OSC 104 reset colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + priv::render_unapplied $overlay_grapheme_control_list $gci + set instruction [list reset_colour_palette] + break + } + 1337 { + #iterm2 graphics and file transfer + puts stderr "overtype::renderline OSC 1337 iterm2 graphics/file_transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + 5113 { + puts stderr "overtype::renderline OSC 5113 kitty file transfer unimplemented. 1st 100 chars of code [ansistring VIEW -lf 1 -vt 1 -nul 1 [string range $code 0 99]]" + } + default { + puts stderr "overtype::renderline OSC - UNIMPLEMENTED. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" + } + } + + } + default { + } + } + + + } + default { + #don't need to handle sgr or gx0 types + #we have our sgr gx0 codes already in stacks for each overlay grapheme + } + } + } + + #-------- + if {$opt_expand_right == 0} { + #need to truncate to the width of the original undertext + #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? + #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars + } + if {$overflow_idx == -1} { + #overflow was initially unlimited and hasn't been overridden + } else { + + } + #-------- + + + #coalesce and replay codestacks for outcols grapheme list + set outstring "" ;#output prior to overflow + set overflow_right "" ;#remainder after overflow point reached + set i 0 + set cstack [list] + set prevstack [list] + set prev_g0 [list] + #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves + set in_overflow 0 ;#used to stop char-width scanning once in overflow + if {$overflow_idx == 0} { + #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW + set in_overflow 1 + } + set trailing_nulls 0 + foreach ch [lreverse $outcols] { + if {$ch eq "\u0000"} { + incr trailing_nulls + } else { + break + } + } + if {$trailing_nulls} { + set first_tail_null_posn [expr {[llength $outcols] - $trailing_nulls}] + } else { + set first_tail_null_posn -1 + } + + #puts stderr "first_tail_null_posn: $first_tail_null_posn" + #puts stderr "colview: [ansistring VIEW $outcols]" + + foreach ch $outcols { + #puts "---- [ansistring VIEW $ch]" + + set gxleader "" + if {$i < [llength $understacks_gx]} { + #set g0 [tcl::dict::get $understacks_gx $i] + set g0 [lindex $understacks_gx $i] + if {$g0 ne $prev_g0} { + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } else { + set gxleader "\x1b(B" + } + } + set prev_g0 $g0 + } else { + set prev_g0 [list] + } + + set sgrleader "" + if {$i < [llength $understacks]} { + #set cstack [tcl::dict::get $understacks $i] + set cstack [lindex $understacks $i] + if {$cstack ne $prevstack} { + if {[llength $prevstack] && ![llength $cstack]} { + #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? + append sgrleader \033\[m + } else { + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + } + } + set prevstack $cstack + } else { + set prevstack [list] + } + + + + if {$in_overflow} { + if {$i == $overflow_idx} { + set 0 [lindex $understacks_gx $i] + set gxleader "" + if {$g0 eq [list "gx0_on"]} { + set gxleader "\x1b(0" + } elseif {$g0 eq [list "gx0_off"]} { + set gxleader "\x1b(B" + } + append overflow_right $gxleader + set cstack [lindex $understacks $i] + set sgrleader "" + #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right + #if {[llength $prevstack] && ![llength $cstack]} { + # append sgrleader \033\[m + #} + append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] + append overflow_right $sgrleader + append overflow_right $ch + } else { + append overflow_right $gxleader + append overflow_right $sgrleader + append overflow_right $ch + } + } else { + if {$overflow_idx != -1 && $i+1 == $overflow_idx} { + #one before overflow + #will be in overflow in next iteration + set in_overflow 1 + if {[grapheme_width_cached $ch]> 1} { + #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) + set ch $opt_exposed1 + } + } + append outstring $gxleader + append outstring $sgrleader + if {$ch eq "\u0000"} { + if {$cp437_glyphs} { + #map all nulls including at tail to space + append outstring " " + } else { + if {$trailing_nulls && $i < $first_tail_null_posn} { + append outstring " " ;#map inner nulls to space + } else { + append outstring \u0000 + } + } + } else { + append outstring $ch + } + } + incr i + } + #flower.ans good test for null handling - reverse line building + #review - presence of overflow_right doesn't indicate line's trailing nulls should remain. + #The cells could have been erased? + #if {!$cp437_glyphs} { + # #if {![ansistring length $overflow_right]} { + # # set outstring [tcl::string::trimright $outstring "\u0000"] + # #} + # set outstring [tcl::string::trimright $outstring "\u0000"] + # set outstring [tcl::string::map {\u0000 " "} $outstring] + #} + + + #REVIEW + #set overflow_right [tcl::string::trimright $overflow_right "\u0000"] + #set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] + + set replay_codes "" + if {[llength $understacks] > 0} { + if {$overflow_idx == -1} { + #set tail_idx [tcl::dict::size $understacks] + set tail_idx [llength $understacks] + } else { + set tail_idx [llength $undercols] + } + if {$tail_idx-1 < [llength $understacks]} { + #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes + set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes + } + if {$tail_idx-1 < [llength $understacks_gx]} { + set gx0 [lindex $understacks_gx $tail_idx-1] + if {$gx0 eq [list "gx0_on"]} { + #if it was on, turn gx0 off at the point we stop processing overlay + append outstring "\x1b(B" + } + } + } + if {[string length $overflow_right]} { + #puts stderr "remainder:$overflow_right" + } + #pdict $understacks + + if {[punk::ansi::ta::detect_sgr $outstring]} { + append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column + + #close off any open gx? + #probably should - and overflow_right reopen? + } + + if {$opt_returnextra} { + #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review + #replay_codes_underlay is the set of codes in effect at the very end of the original underlay + + #review + #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) + #todo - replay_codes for gx0 mode + + #overflow_idx may change during ansi & character processing + if {$overflow_idx == -1} { + set overflow_right_column "" + } else { + set overflow_right_column [expr {$overflow_idx+1}] + } + set result [tcl::dict::create\ + result $outstring\ + visualwidth [punk::ansi::printing_length $outstring]\ + instruction $instruction\ + stringlen [string length $outstring]\ + overflow_right_column $overflow_right_column\ + overflow_right $overflow_right\ + unapplied $unapplied\ + unapplied_list $unapplied_list\ + insert_mode $insert_mode\ + autowrap_mode $autowrap_mode\ + crm_mode $crm_mode\ + reverse_mode $reverse_mode\ + insert_lines_above $insert_lines_above\ + insert_lines_below $insert_lines_below\ + cursor_saved_position $cursor_saved_position\ + cursor_saved_attributes $cursor_saved_attributes\ + cursor_column $cursor_column\ + cursor_row $cursor_row\ + expand_right $opt_expand_right\ + replay_codes $replay_codes\ + replay_codes_underlay $replay_codes_underlay\ + replay_codes_overlay $replay_codes_overlay\ + pm_list $pm_list\ + ] + if {$opt_returnextra == 1} { + #puts stderr "renderline: $result" + return $result + } else { + #human/debug - map special chars to visual glyphs + set viewop VIEW + switch -- $opt_returnextra { + 2 { + #codes and character data + set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others + } + 3 { + set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. + } + } + tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] + tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] + tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] + tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] + tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] + tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] + tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] + return $result + } + } else { + #puts stderr "renderline returning: result $outstring instruction $instruction unapplied $unapplied overflow_right $overflow_right" + return $outstring + } + #return [join $out ""] + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace overtype ---}] +} + +tcl::namespace::eval overtype::piper { + proc overcentre {args} { + if {[llength $args] < 2} { + error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::centre {*}$argsflags $under $over + } + proc overleft {args} { + if {[llength $args] < 2} { + error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} + } + lassign [lrange $args end-1 end] over under + set argsflags [lrange $args 0 end-2] + tailcall overtype::left {*}$argsflags $under $over + } +} + + +# -- --- --- --- --- --- --- --- --- --- --- +proc overtype::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 + } + # better named render_to_unapplied? + proc render_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + #append unapplied [join [lindex $overstacks $idx_over] ""] + #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + + #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack + proc render_this_unapplied {overlay_grapheme_control_list gci} { + upvar idx_over idx_over + upvar unapplied unapplied + upvar unapplied_list unapplied_list + upvar overstacks overstacks + upvar overstacks_gx overstacks_gx + upvar overlay_grapheme_control_stacks og_stacks + + #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] + set unapplied "" + set unapplied_list [list] + + set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] + if {$sgr_merged ne ""} { + lappend unapplied_list $sgr_merged + } + switch -- [lindex $overstacks_gx $idx_over] { + "gx0_on" { + lappend unapplied_list "\x1b(0" + } + "gx0_off" { + lappend unapplied_list "\x1b(B" + } + } + + foreach gc [lrange $overlay_grapheme_control_list $gci end] { + lassign $gc type item + #types g other sgr gx0 + if {$type eq "gx0"} { + if {$item eq "gx0_on"} { + lappend unapplied_list "\x1b(0" + } elseif {$item eq "gx0_off"} { + lappend unapplied_list "\x1b(B" + } + } else { + lappend unapplied_list $item + } + } + set unapplied [join $unapplied_list ""] + } + proc render_delchar {i} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + set nxt [llength $o] + if {$i < $nxt} { + set o [lreplace $o $i $i] + set ustacks [lreplace $ustacks $i $i] + set gxstacks [lreplace $gxstacks $i $i] + } elseif {$i == 0 || $i == $nxt} { + #nothing to do + } else { + puts stderr "render_delchar - attempt to delchar at index $i >= number of outcols $nxt - shouldn't happen" + } + } + proc render_erasechar {i count} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + upvar replay_codes_overlay replay + #ECH clears character attributes from erased character positions + #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller of render_erasechar should do that mapping and only supply 1 or greater. + if {![tcl::string::is integer -strict $count] || $count < 1} { + error "render_erasechar count must be integer >= 1" + } + set start $i + set end [expr {$i + $count -1}] + #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? + if {$i > [llength $o]-1} { + return + } + if {$end > [llength $o]-1} { + set end [expr {[llength $o]-1}] + } + set num [expr {$end - $start + 1}] + set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? + #DECECM ??? + set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list $replay]]] + set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] ;# ??? review + return + } + proc render_setchar {i c } { + upvar outcols o + lset o $i $c + } + + #Initial usecase is for old-terminal hack to add PM-wrapped \b + #review - can be used for other multibyte sequences that occupy one column? + #combiners? diacritics? + proc render_append_to_char {i c} { + upvar outcols o + if {$i > [llength $o]-1} { + error "render_append_to_char cannot append [ansistring VIEW -lf 1 -nul 1 $c] to existing char at index $i while $i >= llength outcols [llength $o]" + } + set existing [lindex $o $i] + if {$existing eq "\0"} { + lset o $i $c + } else { + lset o $i $existing$c + } + } + #is actually addgrapheme? + proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { + upvar outcols o + upvar understacks ustacks + upvar understacks_gx gxstacks + + # -- --- --- + #this is somewhat of a hack.. probably not really the equivalent of proper reverse video? review + #we should ideally be able to reverse the video of a sequence that already includes SGR reverse/noreverse attributes + upvar reverse_mode do_reverse + #if {$do_reverse} { + # lappend sgrstack [a+ reverse] + #} else { + # lappend sgrstack [a+ noreverse] + #} + + #JMN3 + if {$do_reverse} { + #note we can't just look for \x1b\[7m or \x1b\[27m + # it may be a more complex sequence like \x1b\[0\;\;7\;31m etc + + set existing_reverse_state 0 + set codeinfo [punk::ansi::codetype::sgr_merge $sgrstack -info 1] + set codestate_reverse [dict get $codeinfo codestate reverse] + switch -- $codestate_reverse { + 7 { + set existing_reverse_state 1 + } + 27 { + set existing_reverse_state 0 + } + "" { + } + } + if {$existing_reverse_state == 0} { + set rflip [a+ reverse] + } else { + #reverse of reverse + set rflip [a+ noreverse] + } + #note that mergeresult can have multiple esc (due to unmergeables or non sgr codes) + set sgrstack [list [dict get $codeinfo mergeresult] $rflip] + #set sgrstack [punk::ansi::codetype::sgr_merge [list [dict get $codeinfo mergeresult] $rflip]] + } + + # -- --- --- + + set nxt [llength $o] + if {!$insert_mode} { + if {$i < $nxt} { + #These lists must always be in sync + lset o $i $c + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + lset ustacks $i $sgrstack + lset gxstacks $i $gx0stack + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } else { + #insert of single-width vs double-width when underlying is double-width? + if {$i < $nxt} { + set o [linsert $o $i $c] + } else { + lappend o $c + } + if {$i < [llength $ustacks]} { + set ustacks [linsert $ustacks $i $sgrstack] + set gxstacks [linsert $gxstacks $i $gx0stack] + } else { + lappend ustacks $sgrstack + lappend gxstacks $gx0stack + } + } + } + +} + + + +# -- --- --- --- --- --- --- --- --- --- --- +tcl::namespace::eval overtype { + interp alias {} ::overtype::center {} ::overtype::centre +} + + +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.2 +}] +return + +#*** !doctools +#[manpage_end]