diff --git a/src/bootsupport/modules/overtype-1.7.2.tm b/src/bootsupport/modules/overtype-1.7.2.tm new file mode 100644 index 00000000..aa7405e2 --- /dev/null +++ b/src/bootsupport/modules/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] diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index 5045579b..2b2118cf 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 0ab37079..fb5adce3 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.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/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index ccc6bb78..3d9988b1 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.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/bootsupport/modules/punk/args-0.2.1.tm b/src/bootsupport/modules/punk/args-0.2.1.tm index c20e3b51..3071ebd3 100644 --- a/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/bootsupport/modules/punk/args-0.2.1.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/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm index 3a74754f..3f25023e 100644 --- a/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.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/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index e1f2a440..39eeccd2 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::console 0 0.1.1] #[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 0.1.1 + set version 0.1.1 }] return diff --git a/src/bootsupport/modules/punk/fileline-0.1.1.tm b/src/bootsupport/modules/punk/fileline-0.1.1.tm new file mode 100644 index 00000000..d0e740fa --- /dev/null +++ b/src/bootsupport/modules/punk/fileline-0.1.1.tm @@ -0,0 +1,1739 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::fileline 0.1.1 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::fileline 0 0.1.1] +#[copyright "2024"] +#[titledesc {file line-handling utilities}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] +#[require punk::fileline] +#[keywords module text parse file encoding BOM] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para]Utilities for in-memory analysis of text file data as both line data and byte/char-counted data whilst preserving the line-endings (even if mixed) +#[para]This is important for certain text files where examining the number of chars/bytes is important +#[para]For example - windows .cmd/.bat files need some byte counting to determine if labels lie on chunk boundaries and need to be moved. +#[para]This chunk-size counting will depend on the character encoding. +#[para]Despite including the word 'file', the library doesn't necessarily deal with reading/writing to the filesystem - +#[para]The raw data can be supplied as a string, or loaded from a file using punk::fileline::get_textinfo -file +#[subsection Concepts] +#[para]A chunk of textfile data (possibly representing a whole file - but usually at least a complete set of lines) is loaded into a punk::fileline::class::textinfo instance at object creation. +#[example_begin] +# package require punk::fileline +# package require fileutil +# set rawdata [lb]fileutil::cat data.txt -translation binary[rb] +# punk::fileline::class::textinfo create obj_data $rawdata +# puts stdout [lb]obj_data linecount[rb] +#[example_end] +#[subsection Notes] +#[para]Line records are referred to by a zero-based index instead of a one-based index as is commonly used when displaying files. +#[para]This is for programming consistency and convenience, and the module user should do their own conversion to one-based indexing for line display or messaging if desired. +#[para]No support for lone carriage-returns being interpreted as line-endings. +#[para]CR line-endings that are intended to be interpreted as such should be mapped to something else before the data is supplied to this module. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages needed by punk::fileline +#[list_begin itemized] + + package require Tcl 8.6- + package require punk::args + #*** !doctools + #[item] [package {Tcl 8.6-}] + #[item] [package {punk::args}] + + + # #package require frobz + # #*** !doctools + # #[item] [package {frobz}] + +#*** !doctools +#[list_end] [comment {- end dependencies list -}] + +#*** !doctools +#[subsection {optional dependencies}] +#[para] packages that add functionality but aren't strictly required +#[list_begin itemized] + + #*** !doctools + #[item] [package {punk::ansi}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + #[item] [package {punk::char}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + #[item] [package {overtype}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + + +#*** !doctools +#[list_end] [comment {- end optional dependencies list -}] + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline::class { + namespace export * + #*** !doctools + #[subsection {Namespace punk::fileline::class}] + #[para] class definitions + if {[info commands [namespace current]::textinfo] 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}] + # } + + + #uses zero based indexing. Caller can add 1 for line numbers + oo::class create [namespace current]::textinfo { + #*** !doctools + #[enum] CLASS [class textinfo] + #[list_begin definitions] + # [para] [emph METHODS] + + variable o_chunk ;#current state + variable o_chunkop_store + variable o_lineop_store + + variable o_chunk_epoch + variable o_line_epoch + variable o_payloadlist + variable o_linemap + variable o_LF_C + variable o_CRLF_C + + + variable o_bom_id + variable o_bom + variable o_bom_map + + #review - for now we expect datachunk to be data without BOM and already encoded appropriately + #fileline::get_textinfo has support for interpreting BOM - but we currently have no way to do that for data not coming from a file + #refactor to allow that code to be called from here? + constructor {datachunk args} { + #*** !doctools + #[call class::textinfo [method constructor] [arg datachunk] [opt {option value...}]] + #[para] Constructor for textinfo object which represents a chunk or all of a file + #[para] datachunk should be passed with the file data including line-endings as-is for full functionality. ie use something like: + #[example_begin] + # chan configure $fd -translation binary + # set chunkdata [lb]read $fd[rb]] + #or + # set chunkdata [lb]fileutil::cat -translation binary[rb] + #[example_end] + #[para] when loading the data + namespace eval [namespace current] { + set nspath [namespace path] + foreach p [list ::punk::fileline ::punk::fileline::ansi] { + if {$p ni $nspath} { + lappend nspath $p + } + } + namespace path $nspath + } + + set o_bom_map [list\ + utf-8 \u00ef\u00bb\u00bf\ + utf-16be \u00fe\u00ff\ + utf-16le \u00ff\u00fe\ + utf-32be \u0000\u0000\u00fe\u00ff\ + utf-32le \u00ff\u00fe\u0000\u0000\ + utf-7 \u002b\u002f\u0076\ + utf-1 \u00f7\u0064\u004c\ + utf-ebcdic \u00dd\u0073\u0066\u0073\ + utf-scsu \u0003\u00fe\u00ff\ + utf-bocu-1 \u00fb\u00ee\u0028\ + utf-gb18030 \u0084\u0031\u0095\u0033\ + ] + set o_bom_id "" + set o_bom "" ;#review + + set o_chunk $datachunk + set o_line_epoch [list] + set o_chunk_epoch [list "fromchunkchange-at-[clock micros]"] + set crlf_lf_placeholders [list \uFFFF \uFFFE] ;#defaults - if already exist in file - error out with message + set defaults [dict create\ + -substitutionmap {}\ + -crlf_lf_placeholders $crlf_lf_placeholders\ + -userid ""\ + ] + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "[self] constructor error: unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- + set opt_substitutionmap [dict get $opts -substitutionmap] ;#review - can be done by caller - or a loadable -policy + set opt_crlf_lf_placeholders [dict get $opts -crlf_lf_placeholders] + set opt_userid [dict get $opts -userid] + # -- --- --- --- --- --- --- + + if {[llength $opt_crlf_lf_placeholders] != 2 || [string length [lindex $opt_crlf_lf_placeholders 0]] !=1 || [string length [lindex $opt_crlf_lf_placeholders 1]] !=1} { + error "textinfo::constructor error: -crlf_lf_placeholders requires a list of exactly 2 chars" + } + lassign $opt_crlf_lf_placeholders o_LF_C o_CRLF_C + if {[string first $o_LF_C $o_chunk] >=0} { + set decval [scan $o_LF_C %c] + if {$decval < 32 || $decval > 127} { + set char_desc "(decimal value $decval)" + } else { + set char_desc "'$o_LF_C' (decimal value $decval)" + } + error "textinfo::constructor error: rawfiledata already contains linefeed substitution character $char_desc specified as first element of -crlf_lf_placeholders" + } + if {[string first $o_CRLF_C $o_chunk] >=0} { + set decval [scan $o_CRLF_C %c] + if {$decval < 32 || $decval > 127} { + set char_desc "(decimal value $decval)" + } else { + set char_desc "'$o_CRLF_C' (decimal value $decval)" + } + error "textinfo::constructor error: rawfiledata already contains carriagereturn-linefeed substitution character $char_desc specified as second element of -crlf_lf_placeholders" + } + if {$o_LF_C eq $o_CRLF_C} { + puts stderr "WARNING: same substitution character used for both elements of -crlf_lf_placeholders - byte counting may be off if file contains mixed line-endings" + } + + my regenerate_lines + + } + + method set_bomid {bomid} { + if {$bomid ni [dict keys $o_bom_map]} { + error "Unrecognised bom-id $bomid. Known values: [dict keys $o_bom_map]" + } + set o_bom_id $bomid + set o_bom [dict get $o_bom_map $bomid] + } + method get_bomid {} { + return $o_bom_id + } + method get_bom {} { + return $o_bom + } + + method chunk {chunkstart chunkend} { + #*** !doctools + #[call class::textinfo [method chunk] [arg chunkstart] [arg chunkend]] + #[para]Return a range of bytes from the underlying raw chunk data. + #[para] e.g The following retrieves the entire chunk + #[para] objName chunk 0 end + return [string range $o_chunk $chunkstart $chunkend] + } + method chunklen {} { + #*** !doctools + #[call class::textinfo [method chunklen]] + #[para] Number of bytes/characters in the raw data of the file + return [string length $o_chunk] + } + method chunk_boundary_display {chunkstart chunkend chunksize args} { + #*** !doctools + #[call class::textinfo [method chunk_boundary_display]] + #[para]Returns a string displaying the boundaries at chunksize bytes between chunkstart and chunkend + #[para]Defaults to using ansi colour if punk::ansi module is available. Use -ansi 0 to disable colour + set opts [dict create\ + -ansi $::punk::fileline::ansi::enabled\ + -offset 0\ + -displaybytes 200\ + -truncatedmark "..."\ + -completemark "---"\ + -moremark " + "\ + -continuemark " > "\ + -linemaxwidth 100\ + -linebase 0\ + -limit -1\ + -boundaries {}\ + -showconfig 0\ + -boundaryheader {Boundary %i% at %b%}\ + ] + foreach {k v} $args { + switch -- $k { + -ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader { + dict set opts $k $v + } + default { + error "[self]::chunk_boundary error: unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_ansi [dict get $opts -ansi] + set opt_offset [dict get $opts -offset] + set opt_displaybytes [dict get $opts -displaybytes] + set opt_tmark [dict get $opts -truncatedmark] + set opt_cmark [dict get $opts -completemark] + set opt_linemax [dict get $opts -linemaxwidth] + set opt_linebase [dict get $opts -linebase] + set opt_linebase [string map [list _ ""] $opt_linebase] + set opt_limit [dict get $opts -limit] ;#limit number of boundaries to display + set opt_boundaries [dict get $opts -boundaries] ;#use pre-calculated boundaries if supplied + set opt_showconfig [dict get $opts -showconfig] + set opt_boundaryheader [dict get $opts -boundaryheader] + # -- --- --- --- --- --- + package require overtype + # will require punk::char and punk::ansi + + if {"::punk::fileline::ansi::ansistrip" ne [info commands ::punk::fileline::ansi::ansistrip]} { + namespace eval ::punk::fileline::ansi { + namespace import ::punk::ansi::* + } + } + + #This mechanism for enabling/disabling ansi is a bit clumsy - prone to errors with regard to keeping in sync with any api changes in punk ansi + #It's done here to allow this to be used without the full set of punk modules and/or shell - REVIEW + + #risk of failing to reset on error + set pre_ansi_enabled $::punk::fileline::ansi::enabled + if {$opt_ansi} { + set ::punk::fileline::ansi::enabled 1 + } else { + set ::punk::fileline::ansi::enabled 0 + } + if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { + proc ::punk::fileline::a {args} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::a {*}$args + } else { + return "" + } + } + proc ::punk::fileline::a+ {args} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::a+ {*}$args + } else { + return "" + } + } + proc ::punk::fileline::ansistrip {str} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::ansistrip $str + } else { + return $str + } + } + } + set maxline [lindex [my chunkrange_to_linerange $chunkend $chunkend] 0] + set minline [lindex [my chunkrange_to_linerange $chunkstart $chunkstart] 0] + + #suport simple end+-int (+-)start(+-)int to set linebase to line corresponding to chunkstart or chunkend + #also simple int+int and int-int - nothing more complicated (similar to Tcl lrange etc in that regard) + #commonly this will be something like -start or -end + if {![string is integer -strict $opt_linebase]} { + set sign "" + set errunrecognised "unrecognised -linebase value '$opt_linebase'. Expected positive or negative integer or -start -start-int -start+int -end -end-int -end+int or -eof (where leading - is optional but probably desirable) " + if {[string index $opt_linebase 0] eq "-"} { + set sign - + set tail [string range $opt_linebase 1 end] + } else { + set tail [string trimleft $opt_linebase +];#ignore + + } + #todo - switch -glob -- $tail + if {[string match eof* $tail]} { + set endmath [string range $tail 3 end] + #todo endmath? + if {$tail eq "eof"} { + set lastline [lindex [my chunkrange_to_linerange end end] 0] + set linebase ${sign}$lastline + } else { + error $errunrecognised + } + } elseif {[string match end* $tail]} { + set endmath [string range $tail 3 end] + if {[string length $endmath]} { + set op [string index $endmath 0] + if {$op in {+ -}} { + set operand [string range $endmath 1 end] + if {[string is integer -strict $operand]} { + if {$op eq "+"} { + set linebase [expr {$maxline + $operand}] + } else { + set linebase [expr {$maxline - $operand}] + } + } else { + error $errunrecognised + } + } else { + error $errunrecognised + } + } else { + set linebase $maxline + } + set linebase ${sign}$linebase + } elseif {[string match start* $tail]} { + set endmath [string range $tail 5 end] + if {[string length $endmath]} { + set op [string index $endmath 0] + if {$op in {+ -}} { + set operand [string range $endmath 1 end] + if {[string is integer -strict $operand]} { + if {$op eq "+"} { + set linebase [expr {$minline + $operand}] + } else { + set linebase [expr {$minline - $operand}] + } + } else { + error $errunrecognised + } + } else { + error $errunrecognised + } + } else { + set linebase $minline + } + set linebase ${sign}$linebase + } elseif {[string match *-* $tail]} { + set extras [lassign [split $tail -] int1 int2] + if {[llength $extras]} { + error $errunrecognised + } + if {![string is integer -strict $int1] || ![string is integer -strict $int2]} { + error $errunrecognised + } + set linebase [expr {$int1 - $int2}] + set linebase ${sign}$linebase + } elseif {[string match *+* $tail]} { + set extras [lassign [split $tail +] int1 int2] + if {[llength $extras]} { + error $errunrecognised + } + if {![string is integer -strict $int1] || ![string is integer -strict $int2]} { + error $errunrecognised + } + set linebase [expr {$int1 + $int2}] + set linebase ${sign}$linebase + } else { + error $errunrecognised + } + + } else { + set linebase $opt_linebase + } + + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + + if {![llength $opt_boundaries]} { + set binfo [lib::range_spans_chunk_boundaries $chunkstart $chunkend $chunksize -offset $opt_offset] + set boundaries [dict get $binfo boundaries] + } else { + set boundaries [list] + foreach b $opt_boundaries { + if {$chunkstart <= $b && $chunkend >= $b} { + lappend boundaries [expr {$b + $opt_offset}] + } + } + } + + + if {![llength $boundaries]} { + return "No boundaries found between $chunkstart and $chunkend for chunksize $chunksize (when offset $opt_offset)" + } + if {$opt_showconfig} { + set result "chunk range $chunkstart $chunkend line range $minline $maxline linebase $linebase limit $opt_limit\n" + } else { + set result "" + } + set pre_bytes [expr {$opt_displaybytes /2}] + set post_bytes $pre_bytes + set max_bytes [expr {[my chunklen] -1}] + if {$opt_limit > 0} { + set boundaries [lrange $boundaries[unset boundaries] 0 $opt_limit-1] + } + + set i 0 + foreach b $boundaries { + if {$opt_boundaryheader ne ""} { + set j [expr {$i+1}] + append result [string map [list %b% $b %i% $i %j% $j] $opt_boundaryheader] \n + } + set low [expr {max(($b - $pre_bytes),0)}] + set high [expr {min(($b + $post_bytes),$max_bytes)}] + + set lineinfolist [my chunkrange_to_lineinfolist $low $high -show_truncated 1] + set le_map [list \r\n \r \n ] + set result_list [list] + foreach lineinfo $lineinfolist { + set lineidx [dict get $lineinfo lineindex] + + set linenum [expr {$lineidx + $linebase}] + set s [dict get $lineinfo start] + set e [dict get $lineinfo end] + + set boundarymarker "" + set displayidx "" + set linenum_display $linenum + if {$s <= $b && $e >= $b} { + set idx [expr {$b - $s}] ;#index into whole position in whole line - not so useful if we're viewing a small section of a line + set char [string index [my line $lineidx] $idx] + set char_display [string map [list \r \n ] $char] + if {[dict get $lineinfo is_truncated]} { + set tside [dict get $lineinfo truncatedside] + set truncated [dict get $lineinfo truncated] + set tlen [string length $truncated] + if {"left" in $tside} { + set tleft [dict get $lineinfo truncatedleft] + set tleftlen [string length $tleft] + set displayidx [expr {$idx - $tleftlen}] + } elseif {"right" in $tside} { + set displayidx $idx + } + } else { + set displayidx $idx + } + set boundarymarker "'[a+ green bold]$char_display[a]'@$displayidx" + set linenum_display ${linenum_display},$idx + } + + set lhs_status $opt_cmark ;#default + set rhs_status $opt_cmark ;#default + if {[dict get $lineinfo is_truncated]} { + set line [dict get $lineinfo truncated] + set tside [dict get $lineinfo truncatedside] + if {"left" in $tside && "right" in $tside } { + set lhs_status $opt_tmark + set rhs_status $opt_tmark + } elseif {"left" in $tside} { + set lhs_status $opt_tmark + } elseif {"right" in $tside} { + set rhs_status $opt_tmark + } + + + } else { + set line [my line $lineidx] + } + if {$displayidx ne ""} { + set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] + } + set displayline [string map $le_map $line] + lappend result_list [list $linenum_display $boundarymarker $lhs_status $displayline $rhs_status] + } + set title_linenum "LNUM" + set linenums [lsearch -index 0 -all -inline -subindices $result_list *] + set markers [lsearch -index 1 -all -inline -subindices $result_list *] + set lines [lsearch -index 3 -all -inline -subindices $result_list *] + set title_marker "" + set title_line "Line" + #todo - use punk::char for unicode support of wide chars etc? + set widest_linenum [tcl::mathfunc::max {*}[lmap v [concat [list $title_linenum] $linenums] {string length $v}]] + set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [ansistrip $v]}]] + set widest_status [expr {max([string length $opt_cmark], [string length $opt_tmark])}] + set widest_line [tcl::mathfunc::max {*}[lmap v [concat [list $title_line] $lines] {string length $v}]] + foreach row $result_list { + lassign $row linenum marker lhs_status line rhs_status + append result [format " %-*s " $widest_linenum $linenum] + append result [format " %-*s " $widest_marker $marker] + append result [format " %-*s " $widest_status $lhs_status] + append result [format " %-*s " $widest_line $line] + append result [format " %-*s " $widest_status $rhs_status] \n + } + incr i + } + set ::punk::fileline::ansi::enabled $pre_ansi_enabled + return $result + } + method linecount {} { + #*** !doctools + #[call class::textinfo [method linecount]] + #[para] Number of lines in the raw data of the file, counted as per the policy in effect + return [llength $o_payloadlist] + } + + + method line {lineindex} { + #*** !doctools + #[call class::textinfo [method line] [arg lineindex]] + #[para]Reconstructs and returns the raw line using the payload and per-line stored line-ending metadata + #[para]A 'line' may be returned without a line-ending if the unerlying chunk had trailing data without a line-ending (or the chunk was loaded under a non-standard -policy setting) + #[para]Whilst such data may not conform to definitions (e.g POSIX) of the terms 'textfile' and 'line' - it is useful here to represent it as a line with metadata le set to "none" + #[para]To return just the data which might more commonly be needed for dealing with lines, use the [method linepayload] method - which returns the line data minus line-ending + + lassign [my numeric_linerange $lineindex 0] lineindex + + set le [dict get $o_linemap $lineindex le] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] $le] + return [lindex $o_payloadlist $lineindex]$le_chars + } + method chunk_find_glob {globsearch args} { + #todo - use linepayload_find_glob when -ignore_lineendings is 0 - but check truncations for 1st and last line + error "unimplemented" + } + method linepayload_find_glob {globsearch args} { + #*** !doctools + #[call class::textinfo [method linepayload_find_glob] [arg globsearch] [opt {option value...}]] + #[para]Return a lineinfolist (see [method lineinfo] and [method lineinfolist]) of lines where payload matches the [arg globsearch] string + #[para]To limit the returned results use the -limit n option - where -limit 0 means return all matches. + #[para]For example: [method linepayload_find_glob] "*test*" -limit 1 + #[para]The result is always a list of lineinfo dictionaries even if one item is returned + #[para] -limitfrom can be start|end + #[para]The order of results is always the order as they occur in the data - even if -limitfrom end is specified. + #[para]-limitfrom end means that only the last -limit items are returned + #[para]Note that as glob accepts [lb]chars[rb]] to mean match any character in the set given by chars, searching for literal square brackets should be done by escaping the bracket with a backslash + #[para]This is true even if only a single square bracket is being searched for. e.g {*[lb]file*} will not find the word file followed by a left square-bracket - even though the search didn't close the square brackets. + #[para]In the above case - the literal search should be {*\[lb]file*} + + set opts [dict create\ + -limit 0\ + -strategy 1\ + -start 0\ + -end end\ + -limitfrom start\ + ] + foreach {k v} $args { + switch -- $k { + -limit - -strategy - -start - -end - -limitfrom { + dict set opts $k $v + } + default { + error "linepayload_find_glob unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_limit [dict get $opts -limit] + if {![string is integer -strict $opt_limit] || $opt_limit < 0} { + error "linepayload_find_glob -limit must be positive integer" + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_strategy [dict get $opts -strategy] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_start [dict get $opts -start] + set opt_start [expr {$opt_start}] + if {$opt_start != 0} {error "-start unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_end [dict get $opts -end] + set max_line_index [expr {[llength $o_payloadlist]-1}] + if {$opt_end eq "end"} { + set opt_end $max_line_index + } + #TODO + if {$opt_end < $max_line_index} {error "-end less than max_line_index unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_limitfrom [dict get $opts -limitfrom] + #-limitfrom start|end only + #TODO + if {$opt_limitfrom ne "start"} {error "-limitfrom unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + set lineinfolist [list] + + if {$opt_limit == 1} { + set idx [lsearch -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + if {$idx >=0} { + set i [expr {$opt_start + $idx}] + lappend lineinfolist [list lineindex $i [dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } elseif {$opt_limit == 0} { + set indices [lsearch -all -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + foreach irel $indices { + set i [expr {$opt_start + $irel}] + lappend lineinfolist [list lineindex $i [dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } else { + #todo - auto-strategy based on limit vs number of lines + if {$opt_strategy == 0} { + set posn 0 + for {set r 0} {$r < $opt_limit} {incr r} { + set n [lsearch [lrange $o_payloadlist $posn+$opt_start end] $globsearch] + if {$n >=0} { + set irel [expr {$posn + $n}] + set i [expr {$irel + $opt_start}] + lappend lineinfolist [list lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + set posn [expr {$irel+1}] + } + } + } else { + set indices [lsearch -all -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + set limited [lrange $indices 0 $opt_limit-1] + foreach irel $limited { + set i [expr {$opt_start + $irel}] + lappend lineinfolist [list lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } + } + return $lineinfolist + } + method linepayload {lineindex} { + #*** !doctools + #[call class::textinfo [method linepayload] [arg lineindex]] + #[para]Return the text of the line indicated by the zero-based lineindex + #[para]The line-ending is not returned in the data - but is still stored against this lineindex + #[para]Line Metadata such as the line-ending for a particular line and the byte/character range it occupies within the chunk can be retrieved with the [method linemeta] method + #[para]To retrieve both the line text and metadata in a single call the [method lineinfo] method can be used + #[para]To retrieve an entire line including line-ending use the [method line] method. + lassign [my numeric_linerange $lineindex 0] lineindex + return [lindex $o_payloadlist $lineindex] + } + method linepayloads {startindex endindex} { + #*** !doctools + #[call class::textinfo [method linepayloads] [arg startindex] [arg endindex]] + #[para]Return a list of just the payloads in the specified linindex range, with no metadata. + return [lrange $o_payloadlist $startindex $endindex] + } + method linemeta {lineindex} { + #*** !doctools + #[call class::textinfo [method linemeta] [arg lineindex]] + #[para]Return a dict of the metadata for the line indicated by the zero-based lineindex + #[para]Keys returned include + #[list_begin itemized] + #[item] le + #[para] A string representing the type of line-ending: crlf|lf|none + #[item] linelen + #[para] The number of characters/bytes in the whole line including line-ending if any + #[item] payloadlen + #[para] The number of character/bytes in the line excluding line-ending + #[item] start + #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line begins + #[item] end + #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line ends + #[para] This end-point corresponds to the last character of the line-ending if any - not necessarily the last character of the line's payload + #[list_end] + lassign [my numeric_linerange $lineindex 0] lineindex + dict get $o_linemap $lineindex + } + method lineinfo {lineindex} { + #*** !doctools + #[call class::textinfo [method lineinfo] [arg lineindex]] + #[para]Return a dict of the metadata and text for the line indicated by the zero-based lineindex + #[para]This returns the same info as the [method linemeta] with an added key of 'payload' which is the text of the line without line-ending. + #[para]The 'payload' value is the same as is returned from the [method linepayload] method. + lassign [my numeric_linerange $lineindex 0] lineindex ;#convert lineindex to canonical number e.g 1_000 -> 1000 end -> highest index + return [dict create lineindex $lineindex {*}[dict get $o_linemap $lineindex] payload [lindex $o_payloadlist $lineindex]] + } + method lineinfolist {startidx endidx} { + #*** !doctools + #[call class::textinfo [method lineinfolist] [arg startidx] [arg endidx]] + #[para]Returns list of lineinfo dicts for each line in line index range startidx to endidx + lassign [my numeric_linerange $startidx $endidx] startidx endidx + set chunkstart [dict get $o_linemap $startidx start] + set chunkend [dict get $o_linemap $endidx end] + set line_list [my chunkrange_to_lineinfolist $chunkstart $chunkend] ;# assertion - no need to view truncations as we've picked start and end of complete lines + #verify sanity + set l_start [lindex $line_list 0] + if {[set idx_start [dict get $l_start lineindex]] ne $startidx} { + error "lineinfolist first lineindex $idx_start doesn't match startidx $startidx" + } + set l_end [lindex $line_list end] + if {[set idx_end [dict get $l_end lineindex]] ne $endidx} { + error "lineinfolist last lineindex $idx_end doesn't match endidx $endidx" + } + return $line_list + } + + method linerange_to_chunkrange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linerange_to_chunkrange] [arg startidx] [arg endidx]] + + lassign [my numeric_linerange $startidx $endidx] startidx endidx + #inclusive range + return [list [dict get $o_linemap $startidx start] [dict get $o_linemap $endidx end]] + } + method linerange_to_chunk {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linerange_to_chunk] [arg startidx] [arg endidx]] + set chunkrange [my linerange_to_chunkrange $startidx $endidx] + return [string range $o_chunk [lindex $chunkrange 0] [lindex $chunkrange 1]] + } + method lines {startidx endidx} { + #*** !doctools + #[call class::textinfo [method lines] [arg startidx] [arg endidx]] + lassign [my numeric_linerange $startidx $endidx] startidx endidx + set linelist [list] + set le_map [dict create lf \n crlf \r\n none ""] + for {set i $startidx} {$i <= $endidx} {incr i} { + lappend linelist "[lindex $o_payloadlist $i][dict get $le_map [dict get $o_linemap $i le]]" + } + return $linelist + } + method linepayloads {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linepayloads] [arg startidx] [arg endidx]] + return [lrange $o_payloadlist $startidx $endidx] + } + method chunkrange_to_linerange {chunkstart chunkend} { + #*** !doctools + #[call class::textinfo [method chunkrange_to_linerange] [arg chunkstart] [arg chunkend]] + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + + set linestart -1 + for {set i 0} {$i < [llength $o_payloadlist]} {incr i} { + if {($chunkstart >= [dict get $o_linemap $i start]) && ($chunkstart <= [dict get $o_linemap $i end])} { + set linestart $i + break + } + } + if {$linestart == -1} { + error "Line with range in chunk spanning start index $chunkstart not found" + } + set lineend -1 + for {set i [expr {[llength $o_payloadlist] -1}]} {$i >=0} {incr i -1} { + if {($chunkend >= [dict get $o_linemap $i start]) && ($chunkend <= [dict get $o_linemap $i end])} { + set lineend $i + break + } + } + if {$lineend == -1} { + error "Line with range spanning end index $chunkend not found" + } + return [list $linestart $lineend] + } + method chunkrange_to_lineinfolist {chunkstart chunkend args} { + #*** !doctools + #[call class::textinfo [method chunkrange_to_lineinfolist] [arg chunkstart] [arg chunkend] [opt {option value...}]] + #[para]Return a list of dicts each with structure like the result of the [method lineinfo] method - but possibly with extra keys for truncation information if -show_truncated 1 is supplied + #[para]The truncation key in a lineinfo dict may be returned for first and/or last line in the resulting list. + #[para]truncation shows the shortened (missing bytes on left and/or right side) part of the entire line (potentially including line-ending or even partial line-ending) + #[para]Note that this truncation info is only in the return value of this method - and will not be reflected in [method lineinfo] queries to the main chunk. + + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + set defaults [dict create\ + -show_truncated 0\ + ] + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "chunkrange_to_lines error: unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- + set opt_show_truncated [dict get $opts -show_truncated] + # -- --- --- --- --- --- --- --- + + set infolist [list] + set linerange [my chunkrange_to_linerange $chunkstart $chunkend] + lassign $linerange start_lineindex end_lineindex + + #if -show_truncated + #return extra keys for first and last items (which may be the same item if chunkrange is entirely within a line) + #add is_truncated 0|1 to all lines + #Even if the start/end line is not fully within the chunkrange ie truncated - the 'payload' key will contain the original untruncated data + ########################### + # first line may have payload tail truncated - or just linefeed, or even a split linefeed + ########################### + set first [dict create lineindex $start_lineindex {*}[dict get $o_linemap $start_lineindex] payload [lindex $o_payloadlist $start_lineindex]] + set start_info [dict get $o_linemap $start_lineindex] + + + if {$chunkstart > [dict get $start_info start]} { + dict set first is_truncated 1 + dict set first truncatedside [list left] ;#truncatedside is a list which may have 'right' added if last line is same as first line + } else { + dict set first is_truncated 0 + } + + if {$opt_show_truncated} { + #line1 + if {$chunkstart > [dict get $start_info start]} { + #there is lhs truncation + set payload [lindex $o_payloadlist $start_lineindex] + set line_start [dict get $start_info start] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] [dict get $start_info le]] + set payload_and_le "${payload}${le_chars}" + set split [expr {$chunkstart - $line_start}] + set truncated [string range $payload_and_le $split end] + set lhs [string range $payload_and_le 0 $split-1] + + dict set first truncated $truncated + dict set first truncatedleft $lhs + } + } + ########################### + + ########################### + # middle lines if any - no truncation + ########################### + #difference in indexes of 1 would only mean 2 items to return + set middle_list [list] + if {($end_lineindex - $start_lineindex) > 1} { + for {set i [expr {$start_lineindex +1}]} {$i <= [expr {$end_lineindex -1}] } {incr i} { + #lineindex is key into main list + lappend middle_list [dict create lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i] is_truncated 0] + } + } + ########################### + + ########################### + # tail line may have beginning or all of payload truncated - linefeed may be split if crlf + # may be same line as first line - in which case truncation at beginning as well + if {$end_lineindex == $start_lineindex} { + #same record + set end_info $start_info + + + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation + if {[dict get $first is_truncated]} { + dict set first truncatedside [list left right] + } else { + dict set first is_truncated 1 + dict set first truncatedside [list right] + } + } + + if {$opt_show_truncated} { + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation and we need to return the splits + #do rhs truncation - possibly in addition to existing lhs truncation + # ... + set payload [lindex $o_payloadlist $end_lineindex] + set line_start [dict get $end_info start] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] [dict get $end_info le]] + set payload_and_le "${payload}${le_chars}" + set split [expr {$chunkend - $line_start}] + set truncated [string range $payload_and_le 0 $split] + set rhs [string range $payload_and_le $split+1 end] + dict set first truncatedright $rhs + if {"left" ni [dict get $first truncatedside]} { + #rhs truncation only + puts "payload_and_le: $payload_and_le" + puts "LENGTH: [string length $payload_and_le]" + #--- + #--- + dict set first truncated $truncated + dict set first truncatedside [list right] + } else { + #truncated on both sides + set lhslen [string length [dict get $first truncatedleft]] + #re-truncate the truncation to reapply the original lhs truncation + set truncated [string range $truncated $lhslen end] + dict set first truncated $truncated + } + } + } + #no middle or last to append + lappend infolist $first + } else { + set last [dict create lineindex $end_lineindex {*}[dict get $o_linemap $end_lineindex] payload [lindex $o_payloadlist $end_lineindex]] + set end_info [dict get $o_linemap $end_lineindex] + + + if {$chunkend < [dict get $end_info end]} { + dict set last is_truncated 1 + dict set last truncatedside [list right] + } else { + dict set last is_truncated 0 + } + + if {$opt_show_truncated} { + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation - and last line in range is a different line to first one + set payload [lindex $o_payloadlist $end_lineindex] + set line_start [dict get $end_info start] + set line_end [dict get $end_info end] + set le [dict get $end_info le] + set le_size [dict get {lf 1 crlf 2 none 0} $le] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] $le] + set payload_and_le "${payload}${le_chars}" + + set split [expr {$chunkend - $line_start}] + set truncated [string range $payload_and_le 0 $split] + set rhs [string range $payload_and_le $split+1 end] + + dict set last truncated $truncated + dict set last truncatedright $rhs + #this has the effect that truncating the rhs by 1 can result in truncated being larger than original payload for crlf lines - as payload now sees the cr + #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' + } + } + + + lappend infolist $first + if {[llength $middle_list]} { + lappend infolist {*}$middle_list + } + lappend infolist $last + } + ########################### + #assertion all records have is_truncated key. + #assertion if is_truncated == 1 truncatedside should contain a list of either left, right or both left and right + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. + return $infolist + } + + #need to check truncations so that any split \r\n is counted precisely todo + method chunk_le_counts {chunkstart chunkend} { + set infolines [my chunkrange_to_lineinfolist $chunkstart $chunkend -show_truncated 1] + set lf_count 0 + set crlf_count 0 + set none_count 0 + foreach d $infolines { + set le [dict get $d le] + if {$le eq "lf"} { + incr lf_count + } elseif {$le eq "crlf"} { + incr crlf_count + } else { + incr none_count + } + } + #even without split crlf - this can overcount by counting the lf or crlf in a line which had an ending not in the chunk range specified + + #check first and last infoline for truncations + #Also check if the truncation is directly between an crlf + #both an lhs split and an rhs split could land between cr and lf + #to be precise - we should presumably count the part within our chunk as either a none for cr or an lf + #This means a caller counting chunk by chunk using this method will sometimes get the wrong answer depending on where crlfs lie relative to their chosen chunk size + #This is presumably ok - as it should be a well known thing to watch out for. + #If we're only receiving chunk by chunk we can't reliably detect splits vs lone s in the data + #There are surely more efficient ways for a caller to count line-endings in the way that makes sense for them + #but we should makes things as easy as possible for users of this line/chunk structure anyway. + + set first [lindex $infolines 0] + if {[dict get $first is_truncated]} { + #could be the only line - and truncated at one or both ends. + #both a left and a right truncation could split a crlf + + } + set last [lindex $infolines end] + if {[dict get $first lineindex] != [dict get $last lineindex]} { + #only need to process last if it is a different line + #if so - then split can only be left side + + } + + + return [dict create lf $lf_count crlf $crlf_count unterminated $none_count warning line_ending_splits_unimplemented] + } + + #todo - test last line and merge as necessary with first line from new chunk - generate line data only for appended chunk + method append_chunk {rawchunk} { + error "sorry - unimplemented" + } + + method numeric_linerange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method numeric_linerange] [arg startidx] [arg endidx]] + #[para]A helper to return any Tcl-style end end-x values given to startidx or endidx; converted to their specific values based on the current state of the underlying line data + #[para]This is used internally by API functions such as [method line] to enable it to accept more expressive indices + return [my normalize_indices $startidx $endidx [expr {[dict size $o_linemap]-1}]] + } + method numeric_chunkrange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method numeric_chunkrange] [arg startidx] [arg endidx]] + #[para]A helper to return any Tcl-style end end-x entries supplied to startidx or endidx; converted to their specific values based on the current state of the underlying chunk data + return [my normalize_indices $startidx $endidx [expr {[string length $o_chunk]-1}]] + } + method normalize_indices {startidx endidx max} { + #*** !doctools + #[call class::textinfo [method normalize_indices] [arg startidx] [arg endidx] [arg max]] + #[para]A utility to convert some of the of Tcl-style list-index expressions such as end, end-1 etc to valid indices in the range 0 to the supplied max + #[para]Basic addition and subtraction expressions such as 4-1 5+2 are accepted + #[para]startidx higher than endidx is allowed + #[para]Unlike Tcl's index expressions - we raise an error if the calculated index is out of bounds 0 to max + set original_startidx $startidx + set original_endidx $endidx + set startidx [string map [list _ ""] $startidx] ;#don't barf on Tcl 8.7+ underscores in numbers - we can't just use expr because it will not handle end-x + set endidx [string map [list _ ""] $endidx] + if {![string is digit -strict "$startidx$endidx"]} { + foreach whichvar [list start end] { + upvar 0 ${whichvar}idx index + if {![string is digit -strict $index]} { + switch -glob -- $index { + end { + set index $max + } + "*-*" { + #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions + lassign [split $index -] A B + if {$A eq "end"} { + set index [expr {$max - $B}] + } else { + set index [expr {$A - $B}] + } + } + "*+*" { + lassign [split $index +] A B + if {$A eq "end"} { + #review - this will just result in out of bounds error in final test - as desired + #By calculating here - we will see the result in the error message - but it's probably not particularly useful - as we don't really need end+ support at all. + set index [expr {$max + $B}] + } else { + set index [expr {$A + $B}] + } + } + default { + #May be something like +2 or -0 which braced expr can hanle + #we would like to avoid unbraced expr here - as we're potentially dealing with ranges that may come from external sources. + if {[catch {expr {$index}} index]} { + #could be end+x - but we don't want out of bounds to be valid + #set it to something that the final bounds expr test can deal with + set index Inf + } + } + } + } + } + } + #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. + #show the supplied index and what it was mapped to in the error message. + if {$startidx < 0 || $startidx > $max} { + error "Bad start index '$original_startidx'. $startidx out of bounds 0 - $max" + } + if {$endidx < 0 || $endidx > $max} { + error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" + } + return [list $startidx $endidx] + } + + method regenerate_lines {args} { + #*** !doctools + #[call class::textinfo [method regenerate_lines]] + #[para]generate a list of lines from the current state of the stored raw data chunk and keep a map of line-endings indexed by lineindex + #[para]This is called automatically by the Constructor during object creation + #[para]It is exposed in the API experimentally - as chunk and line manipulation functions are considered. + #[para]TODO - review whether such manual control will be necessary/desirable + + #we don't store the actual line-endings as characters (for better layout of debug/display of data) - instead we store names lf|crlf|none + + # first split on lf - then crlf. As we've replaced with single substution chars - the order doesn't matter. + set o_payloadlist [list] + set o_linemap [dict create] + set crlf_replace [list \r\n $o_CRLF_C \n $o_LF_C] + set normalised_data [string map $crlf_replace $o_chunk] + + set lf_lines [split $normalised_data $o_LF_C] + + set idx 0 + set lf_count 0 + set crlf_count 0 + set filedata_offset 0 + set i 0 + set imax [expr {[llength $lf_lines]-1}] + foreach lfln $lf_lines { + set crlf_parts [split $lfln $o_CRLF_C] + if {[llength $crlf_parts] <= 1} { + #no crlf + set payloadlen [string length $lfln] + set le_size 1 + set le lf + if {$i == $imax} { + #no more lf segments - and no crlfs + if {$payloadlen > 0} { + #last line in split has chars - therefore there was no trailing line-ending + set le_size 0 + set le none + } else { + #empty space after last line-ending + #not really a line - we get here from splitting on our lf-replacement char + #An editor might display this pseudo-line with a line number - but we won't treat it as one here + break + } + } + lappend o_payloadlist $lfln + set linelen [expr {$payloadlen + $le_size}] + #we include line-ending in byte count for a line. + dict set o_linemap $idx [list le $le linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr lf_count + incr idx + } else { + foreach crlfpart [lrange $crlf_parts 0 end-1] { + lappend o_payloadlist $crlfpart + set payloadlen [string length $crlfpart] + set linelen [expr {$payloadlen + 2}] + dict set o_linemap $idx [list le crlf linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr crlf_count + incr idx + } + set lfpart [lindex $crlf_parts end] + set payloadlen [string length $lfpart] + if {$i == $imax} { + #no more lf segments - but we did find crlf in last (or perhaps only) lf line + #last element in our split has no le + if {$payloadlen > 0} { + set le_size 0 + set le none + } else { + #set le_size 2 + #set le crlf + break + } + } else { + #more lf segments to come + set le_size 1 + set le lf + } + + lappend o_payloadlist $lfpart + set linelen [expr {$payloadlen + $le_size}] + dict set o_linemap $idx [list le $le linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr lf_count + incr idx + } + incr i + #incr filedata_offset ;#move up 1 so start entry for next line is greater than end entry for previous line + } + set le_count [expr {$lf_count + $crlf_count}] + if {$le_count != [llength $o_payloadlist]} { + puts stderr "fileline::class::textinfo warning. regenerate_lines lf_count: $lf_count + crlf_count: $crlf_count does not equal length of lines stored: [llength $o_payloadlist]" + } + + } + method regenerate_chunk {} { + #o_payloadlist + #o_linemap + set oldsize [string length $o_chunk] + set newchunk "" + #review - what was the intention here? + puts stderr "regenerate_chunk -warning code incomplete" + dict for {idx lineinfo} $o_linemap { + #??? + #set + + } + + return [list newsize [string length $newchunk] oldsize $oldsize] + } + + + #*** !doctools + #[list_end] + } + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline { + namespace export * + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::fileline}] + #[para] Core API functions for punk::fileline + #[list_begin definitions] + + punk::args::define { + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ + "return: textinfo object instance" + -file -default {} -type existingfile + -translation -default iso8859-1 + -encoding -default "\uFFFF" + -includebom -default 0 + @values -min 0 -max 1 + } + proc get_textinfo {args} { + #*** !doctools + #[call get_textinfo [opt {option value...}] [opt datachunk]] + #[para]Returns textinfo object instance representing data in string datachunk or if -file filename supplied - data loaded from a file + #[para]The encoding used is as specified in the -encoding option - or from the Byte Order Mark (bom) at the beginning of the data + #[para]For Tcl 8.6 - encodings such as utf-16le may not be available - so the bytes are swapped appropriately depending on the platform byteOrder and encoding 'unicode' is used. + #[para]encoding defaults to utf-8 if no -encoding specified and no BOM was found + #[para]Whether -encoding was specified or not - by default the BOM characters are not retained in the line-data + #[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data + #[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered. + #[para] e.g utf-8,utf-16be, utf-16le, utf-32be, utf32-le, SCSU, BOCU-1,GB18030, UTF-EBCDIC, utf-1, utf-7 + #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is. + #[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::parse $args withid ::punk::fileline::get_textinfo]] leaders opts values + # -- --- --- --- + set opt_file [dict get $opts -file] + set opt_translation [dict get $opts -translation] + set opt_encoding [dict get $opts -encoding] + set opt_includebom [dict get $opts -includebom] + # -- --- --- --- + + 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]} { + puts stderr "Ignoring trailing argument [string length [lindex $values 0]] bytes. Not used when -file is specified" + } + } else { + set rawchunk [lindex $values 0] + } + set rawlen [string length $rawchunk] + #examine first 4 bytes for possible BOM + #big-endian BOMs + # ----------------------------------- + #EFBBBF - utf-8 reliabletxt + #FEFF - utf-16be reliabletxt + #FFFE - utf-16le reliabletxt + #0000FEFF - utf-32be reliabletxt + #FFFE0000 - utf-32le + #0000FFFE - utf-32be(2143) non-standard! (not supported) + #FEFF0000 - utf-32le(3412) non-standard! (not supported - will detect as utf-16be) + #2B2F76 - utf-7 (not supported) + #F7644C - utf-1 (not supported) + #DD736673 - UTF-EBCDIC (not supported) + #0EFEFF - SCSU (not supported) + #FBEE28 - BOCU-1 Binary Ordered Compression for Unicode (mime-compatible) - (not supported - fall back to utf-8) + #84319533 - GB18030 - Chinese gov standard (fall back to cp936 with warning if no encoding name) + # ----------------------------------- + + set first32 [string range $rawchunk 0 3] + #scan using capital H for big-endian order + set first32_be [binary scan $first32 H* maybe_bom] ;#we use H* instead of H8 for 8 nibbles (4 bytes) - because our first32 may contain less than 4 bytes - in which case we won't match + set bomid "" + set bomenc "" + set is_reliabletxt 0 ;#see http://reliabletxt.com - only utf-8 with bom, utf-16be, utf-16le, utf-32be supported as at 2024 + set startdata 0 + #todo switch -glob + if {[string match "efbbbf*" $maybe_bom]} { + set bomid utf-8 + set bomenc utf-8 + set is_reliabletxt 1 + set startdata 3 + } elseif {$maybe_bom eq "0000feff"} { + set bomid utf-32be + set bomenc utf-32be + set is_reliabletxt 1 + set startdata 4 + } elseif {$maybe_bom eq "fffe0000"} { + #Technically ambiguous - could be utf-16le bom followed by utf-16 null character (2 byte null) + puts stderr "WARNING - ambiguous BOM fffe0000 found. Treating as utf-32le - but could be utf-16le - consider manually setting -encoding or converting data to another encoding." + set bomid utf-32le + set bomenc utf-32le + set startdata 4 + } elseif {[string match "feff*" $maybe_bom]} { + set bomid utf-16be + set bomenc utf-16be + set is_reliabletxt 1 + set startdata 2 + } elseif {[string match "fffe*" $maybe_bom]} { + set bomid utf-16le + set bomenc utf-16le + set is_reliabletxt 1 + set startdata 2 + } elseif {$maybe_bom eq "0efeff"} { + set bomid scsu + set bomenc "binary" + set startdata 3 + } elseif {$maybe_bom eq "fbee28"} { + set bomid bocu-1 + 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" + 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? + } + set bomid gb18030 + set startdata 4 + } elseif {$maybe_bom eq "f7644c"} { + puts stderr "WARNING utf-1 BOM F7644C found - not supported. Falling back to binary" + set bomid utf-1 + set bomenc binary + set startdata 3 + } elseif {[string match "2b2f76*" $maybe_bom]} { + puts stderr "WARNING utf-7 BOM 2b2f76 found - not supported. Falling back to binary and leaving BOM in data!" + #review - work out how to strip bom - last 2 bits of 4th byte belong to following character + set bomid utf-7 + set bomenc binary + set startdata 0 + } + + #todo - check xml encoding attribute / html content-type + #todo - a separate chardet (https://chardet.readthedocs.io/ ) or mozilla like mechanism that can be manually called to autodetect character encoding + #This should be an explicit operation - not automatially done here unless we provide a flag for it. + + + if {$opt_includebom} { + set startdata 0 + } + + if {$opt_encoding eq "\uFFFF"} { + if {$bomenc ne "" && $bomenc ne "binary"} { + if {[package vcompare [package provide Tcl] 8.7] < 0} { + #tcl 8.6 has unicode encoding but not utf-16le etc + if {$bomenc ni [encoding names]} { + if {$bomenc eq "utf-16le"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } else { + set datachunk [encoding convertfrom unicode [system::wordswap16 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 16)" + } + } elseif {$bomenc eq "utf-16be"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [system::wordswap16 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 16)" + } else { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } + } elseif {$bomenc eq "utf-32le"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } else { + set datachunk [encoding convertfrom unicode [system::wordswap32 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 32)" + } + } elseif {$bomenc eq "utf-32be"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [system::wordswap32 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 32)" + } else { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } + } else { + error "Encoding $bomenc unavailable in this version of Tcl" + } + } else { + set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] + set encoding_selected $bomenc + } + } else { + #tcl 8.7 plus has utf-16le etc + set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] + set encoding_selected $bomenc + } + } else { + #!? + if {$bomenc eq "binary"} { + set datachunk [string range $rawchunk $startdata end] + set encoding_selected binary + } else { + set datachunk [encoding convertfrom utf-8 [string range $rawchunk $startdata end]] + set encoding_selected utf-8 + } + } + } else { + #manually specified encoding overrides bom - but still remove bom-chars REVIEW + #e.g we still want bom info - but specify binary encoding + + if {$opt_encoding eq "binary"} { + set datachunk [string range $rawchunk $startdata end] + } else { + set datachunk [encoding convertfrom $opt_encoding [string range $rawchunk $startdata end]] + } + set encoding_selected $opt_encoding + } + + set textobj [class::textinfo new $datachunk] + if {$bomid ne ""} { + $textobj set_bomid $bomid + } + + + + + set summary "" + append summary "Bytes loaded : $rawlen" \n + append summary "BOM ID : $bomid" \n + append summary "Encoding selected : $encoding_selected" \n + append summary "Characters : [$textobj chunklen]" \n + append summary "Lines recognised : [$textobj linecount]" \n + set leinfo [$textobj chunk_le_counts 0 end] + append summary "crlf endings (windows) : [dict get $leinfo crlf]" \n + append summary "lf endings (unix) : [dict get $leinfo lf]" \n + append summary "unterminated lines : [dict get $leinfo unterminated]" \n + puts stdout $summary + return $textobj + } + + proc file_boundary_display {filename startbyte endbyte chunksize args} { + set fd [open $filename r] ;#use default error if file not readable + chan configure $fd -translation binary + set rawfiledata [read $fd] + close $fd + set textobj [class::textinfo new $rawfiledata] + set result [$textobj chunk_boundary_display $startbyte $endbyte $chunksize {*}$args] + $textobj destroy + return $result + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline::lib { + namespace export * + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::fileline::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + + proc range_spans_chunk_boundaries {start end chunksize args} { + #*** !doctools + #[call [fun lib::range_spans_chunk_boundaries] [arg start] [arg end] [arg chunksize]] + #[para]Takes start and end offset, generally representing bytes or character indices, and computes a list of boundaries at multiples of the chunksize that are spanned by the start and end range. + #[list_begin arguments] + # [arg_def integer start] + # [para] zero-based start index of range + # [arg_def integer end] + # [para] zero-based end index of range + # [arg_def integer chunksize] + # [para] Number of bytes/characters in chunk - must be positive and > 0 + #[list_end] + #[para]returns a dict with the keys is_span and boundaries + #[para]is_span 0|1 indicates if the range specified spans a boundary of chunksize + #[para]boundaries contains a list of the spanned boundaries - which are always multiples of the chunksize + #[para]e.g + #[example_begin] + # range_spans_chunk_boundaries 10 1750 512 + # is_span 1 boundaries {512 1024 1536} + #[example_end] + #[para]The -offset option + #[example_begin] + # range_spans_chunk_boundaries 10 1750 512 -offset 2 + # is_span 1 boundaries {514 1026 1538} + #[example_end] + #[para] This function automatically uses lseq (if Tcl >= 8.7) when number of boundaries spanned is approximately greater than 75 + if {[catch {package require Tcl 8.7-}]} { + #only one implementation available for older Tcl + tailcall punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize {*}$args + } + if {$chunksize < 1} { + error "range_spans_chunk_boundaries chunksize must be >= 1" + } + + if {(abs($end - $start) / $chunksize) < 75} { + tailcall punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize {*}$args + } else { + tailcall punk::fileline::system::_range_spans_chunk_boundaries_lseq $start $end $chunksize {*}$args + } + } + + proc range_boundaries {start end chunksizes args} { + set argd [punk::args::parse $args withdef { + -offset -default 0 + }] + lassign [dict values $argd] leaders opts remainingargs + + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::fileline::system { + #*** !doctools + #[subsection {Namespace punk::fileline::system}] + #[para] Internal functions that are not part of the API + + proc wordswap16 {data} { + #scan in one endianness - format in the other. Whether we scan le/be first doesn't matter as long as we format using the opposite endianness + binary scan $data s* elements ;#scan little endian + return [binary format S* $elements] ;#format big endian + } + proc wordswap32 {data} { + binary scan $data i* elements + return [binary format I* $elements] + } + + proc scan32bit_be {i32} { + if {[binary scan $i32 I x]} { + return $x + } else { + error "couldn't scan $i32" + } + } + + #for 8.7+ using lseq + #much faster when resultant boundary size is large (at least when offset 0) + proc _range_spans_chunk_boundaries_lseq {start end chunksize args} { + if {$chunksize < 1} {error "chunksize must be > 0"} ;#sanitycheck in case called directly + set opts [dict create\ + -offset 0\ + ] + foreach {k v} $args { + switch -- $k { + -offset { + dict set opts $k $v + } + default { + error "unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- + set opt_offset [dict get $opts -offset] + # -- --- --- --- + + set smod [expr {$start % $chunksize}] + if {$smod != 0} { + set start [expr {$start + ($chunksize - $smod)}] + if {$start > $end} { + return [list is_span 0 boundaries {}] + } + } + set boundaries [lseq $start to $end $chunksize] + #offset can be negative + if {$opt_offset} { + if {$opt_offset + [lindex $boundaries end] > $end || $opt_offset + [lindex $boundaries 0] < $start} { + set overflow 1 + } else { + set overflow 0 + } + set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] + if {$overflow} { + #we don't know how many overflowed.. + set inrange [list] + foreach b $boundaries { + if {$b >= $start && $b <= $end} { + lappend inrange $b + } + } + set boundaries $inrange + } + } + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries] + } + + #faster than lseq for small number of resultant boundaries (~< 75) (which is a common use case) + #gets very slow (comparitively) with large resultsets + proc _range_spans_chunk_boundaries_tcl {start end chunksize args} { + if {$chunksize < 1} {error "chunksize must be > 0"} ;#sanitycheck in case called directly + set opts [dict create\ + -offset 0\ + ] + foreach {k v} $args { + switch -- $k { + -offset { + dict set opts $k $v + } + default { + error "unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- + set opt_offset [dict get $opts -offset] + # -- --- --- --- + + set is_span 0 + set smod [expr {$start % $chunksize}] + if {$smod != 0} { + set start [expr {$start + ($chunksize - $smod)}] + } + set boundaries [list] + + #we only need to pre-check the result-range for negative offsets - as our main loop stops before end? + if {$opt_offset < 0} { + #set btrack [expr {$start + $opt_offset}] ;#start back one to make sure we catch the first boundary + set btrack $bstart + set boff [expr {$btrack + $opt_offset}] ;#must be growing even if start and offset are negative - as chunksize is at least 1 + while {$boff < $start} { + incr btrack $chunksize + set boff [expr {$btrack + $opt_offset}] + } + set bstart $btrack + } else { + set bstart $start + } + for {set b $bstart} {[set boff [expr {$b + $opt_offset}]] <= $end} {incr b $chunksize} { + lappend boundaries $boff + } + + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries offset $opt_offset] + } + + proc _range_spans_chunk_boundaries_TIMEIT {start end chunksize {repeat 1}} { + puts "main : [time {punk::fileline::lib::range_spans_chunk_boundaries $start $end $chunksize} $repeat]" + puts "tcl : [time {punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize} $repeat]" + if {![catch {package require Tcl 8.7-}]} { + puts "lseq : [time {punk::fileline::system::_range_spans_chunk_boundaries_lseq $start $end $chunksize} $repeat]" + } + } +} +namespace eval punk::fileline::ansi { + #*** !doctools + #[subsection {Namespace punk::fileline::ansi}] + #[para]These are ansi functions imported from punk::ansi - or no-ops if that package is unavailable + #[para]See [package punk::ansi] for documentation + #[list_begin definitions] + variable enabled 1 + #*** !doctools + #[call [fun ansi::a]] + #[call [fun ansi::a+]] + #[call [fun ansi::ansistrip]] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline::ansi ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::fileline [namespace eval punk::fileline { + variable pkg punk::fileline + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punk/lib-0.1.3.tm b/src/bootsupport/modules/punk/lib-0.1.3.tm index 5ec354a7..f6242f76 100644 --- a/src/bootsupport/modules/punk/lib-0.1.3.tm +++ b/src/bootsupport/modules/punk/lib-0.1.3.tm @@ -4201,6 +4201,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/bootsupport/modules/punk/lib-0.1.4.tm b/src/bootsupport/modules/punk/lib-0.1.4.tm new file mode 100644 index 00000000..a7273752 --- /dev/null +++ b/src/bootsupport/modules/punk/lib-0.1.4.tm @@ -0,0 +1,4935 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::lib 0.1.4 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::lib 0 0.1.4] +#[copyright "2024"] +#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk library}] [comment {-- Description at end of page heading --}] +#[require punk::lib] +#[keywords module utility lib] +#[description] +#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. +#[para]The base set includes string and math functions but has no specific theme + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::lib +#[subsection Concepts] +#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. +#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::lib +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +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]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![string match ::* $extension]} { + set extension [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$extension + } + + if {![tcl::namespace::exists $extension]} { + error [list {no such namespace} $extension] + } + + set extension [tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] current]] + + tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] export *] + + while 1 { + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] + if {[tcl::namespace::which $renamed] eq {}} break + } + + rename $routine $renamed + + tcl::namespace::eval $extension [ + list namespace ensemble create -command $routine -unknown [ + list apply {{renamed ensemble routine args} { + list $renamed $routine + }} $renamed + ] + ] + + return $routine + } +} + +# 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} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + set bug true + } else { + 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 + set bug 0 + } else { + set bug [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}" + 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} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr 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] + } +} + +tcl::namespace::eval punk::lib::compat { + #*** !doctools + #[subsection {Namespace punk::lib::compat}] + #[para] compatibility functions for features that may not be available in earlier Tcl versions + #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. + #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. + + #*** !doctools + #[list_begin definitions] + + + + + if {"::lremove" ne [info commands ::lremove]} { + #puts stderr "Warning - no built-in lremove" + interp alias {} lremove {} ::punk::lib::compat::lremove + } + proc lremove {list args} { + #*** !doctools + #[call [fun lremove] [arg list] [opt {index ...}]] + #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove + + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lsearch -all -inline -index 1 -subindices $keep *] + } + #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers + proc lremove2 {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lmap v $keep {lindex $v 1}] + } + #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 + + if {![info exists ::auto_index(readFile)]} { + if {[info commands ::readFile] eq ""} { + proc ::readFile {filename {mode text}} { + #readFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + + # Read the file + set f [open $filename [dict get {text r binary rb} $mode]] + try { + return [read $f] + } finally { + close $f + } + } + } + } + if {![info exists ::auto_index(writeFile)]} { + if {[info commands ::writeFile] eq ""} { + proc ::writeFile {args} { + #writeFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + switch [llength $args] { + 2 { + lassign $args filename data + set mode text + } + 3 { + lassign $args filename mode data + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + } + default { + set COMMAND [lindex [info level 0] 0] + return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" + } + } + + # Write the File + set f [open $filename [dict get {text w binary wb} $mode]] + try { + puts -nonewline $f $data + } finally { + close $f + } + } + } + } + + if {"::lpop" ne [info commands ::lpop]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lib::compat::lpop + 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 + #[call [fun lpop] [arg listvar] [opt {index}]] + #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop + upvar $lvar l + if {![llength $args]} { + set args [list end] + } + set v [lindex $l {*}$args] + set newlist $l + + set path [list] + set subl $l + for {set i 0} {$i < [llength $args]} {incr i} { + set idx [lindex $args $i] + if {![llength [lrange $subl $idx $idx]]} { + error "tcl_lpop index \"$idx\" out of range" + } + lappend path [lindex $args $i] + set subl [lindex $l {*}$path] + } + + set sublist_path [lrange $args 0 end-1] + set tailidx [lindex $args end] + if {![llength $sublist_path]} { + #set newlist [lremove $newlist $tailidx] + set newlist [lreplace $newlist $tailidx $tailidx] + } else { + set sublist [lindex $newlist {*}$sublist_path] + #set sublist [lremove $sublist $tailidx] + set sublist [lreplace $sublist $tailidx $tailidx] + lset newlist {*}$sublist_path $sublist + } + #puts "[set l] -> $newlist" + set l $newlist + return $v + } + if {"::ledit" ni [info commands ::ledit]} { + interp alias {} ledit {} ::punk::lib::compat::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 { + -Inf { + #index below lower bound + set pre [list] + set fidx -1 + } + Inf { + #first index position is greater than index of last element in the list + set pre [lrange $l 0 end] + set fidx [llength $l] + } + default { + #set pre [lrange $l 0 $first-1] + set pre [lrange $l 0 $fidx-1] + } + } + set lidx [punk::lib::lindex_resolve [llength $l] $last] + switch -exact -- $lidx { + -Inf { + #index below lower bound + set post [lrange $l 0 end] + } + Inf { + #index above upper bound + set post [list] + } + default { + if {$lidx < $fidx} { + #from ledit man page: + #If last is less than first, then any specified elements will be inserted into the list before the element specified by first with no elements being deleted. + set post [lrange $l $fidx end] + } else { + #set post [lrange $l $last+1 end] + set post [lrange $l $lidx+1 end] + } + } + } + set l [list {*}$pre {*}$args {*}$post] + } + + + #slight isolation - varnames don't leak - but calling context vars can be affected + proc lmaptcl2 {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list ::tcl::info::vars]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result [apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + if {"::lmap" ne [info commands ::lmap]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lmap {} ::punk::lib::compat::lmaptcl + } + #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway + proc lmaptcl {varnames list script} { + set result [list] + set varlist [list] + foreach varname $varnames { + upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc + lappend varlist var_$varname + } + foreach $varlist $list { + lappend result [uplevel 1 $script] + } + return $result + } + + #tcl8.7/9 compatibility for 8.6 + if {[info commands ::tcl::string::insert] eq ""} { + #https://wiki.tcl-lang.org/page/string+insert + # Pure Tcl implementation of [string insert] command. + proc ::tcl::string::insert {string index insertString} { + # Convert end-relative and TIP 176 indexes to simple integers. + if {[regexp -expanded { + ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace + |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace + (?:([+-]) # op, omitted when index is "end" + ([+-]?\d+))? # n, omitted when index is "end" + [\t\n\v\f\r ]*$ # optional whitespace (unless "end") + } $index _ m op n]} { + # Convert first index to an integer. + switch $m { + end {set index [string length $string]} + default {scan $m %d index} + } + + # Add or subtract second index, if provided. + switch $op { + + {set index [expr {$index + $n}]} + - {set index [expr {$index - $n}]} + } + } elseif {![string is integer -strict $index]} { + # Reject invalid indexes. + return -code error "bad index \"$index\": must be\ + integer?\[+-\]integer? or end?\[+-\]integer?" + } + + # Concatenate the pre-insert, insertion, and post-insert strings. + string cat [string range $string 0 [expr {$index - 1}]] $insertString\ + [string range $string $index end] + } + + # Bind [string insert] to [::tcl::string::insert]. + tcl::namespace::ensemble configure string -map [tcl::dict::replace\ + [tcl::namespace::ensemble configure string -map]\ + insert ::tcl::string::insert] + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::lib { + variable PUNKARGS + tcl::namespace::export * + variable has_struct_list + set has_struct_list [expr {![catch {package require struct::list}]}] + variable has_struct_set + set has_struct_set [expr {![catch {package require struct::set}]}] + variable has_punk_ansi + set has_punk_ansi [expr {![catch {package require punk::ansi}]}] + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + 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] + } + + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + + # -- --- + #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists + #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 + #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows + # Review and retest as new versions come out. + # -- --- + proc list_multi_append1 {lvar1 lvar2} { + #clear winner in 2024 + upvar $lvar1 l1 $lvar2 l2 + lappend l1 {*}$l2 + return $l1 + } + proc list_multi_append2 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [list {*}$l1 {*}$l2] + } + proc list_multi_append3 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] + } + #testing e.g + #set l1_reset {a b c} + #set l2 {a b c d e f g} + #set l1 $l1_reset + #time {list_multi_append1 l1 l2} 1000 + #set l1 $l1_reset + #time {list_multi_append2 l1 l2} 1000 + # -- --- + + + proc lswap {lvar a z} { + 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 -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 -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 { + -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 { + -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 ""} { + append errmsg \n $a_msg + } + if {$z_msg ne ""} { + append errmsg \n $z_msg + } + error $errmsg + } + set item2 [lindex $l $z] + lset l $z [lindex $l $a] + lset l $a $item2 + return $l + } + #proc lswap2 {lvar a z} { + # upvar $lvar l + # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] + #} + + proc lswap2 {lvar a z} { + upvar $lvar l + #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] + } + + #an experimental test of swapping vars without intermediate variables + #It's an interesting idea - but probably of little to no practical use + # - the swap_intvars3 version using intermediate var is faster in Tcl + # - This is probably unsurprising - as it's simpler code. + # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. + #proc swap_intvars {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] + #} + #proc swap_intvars2 {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {$_x ^ $_y}] + # set _y [expr {$_x ^ $_y}] + # set _x [expr {$_x ^ $_y}] + #} + #proc swap_intvars3 {swapv1 swapv2} { + # #using intermediate variable + # upvar $swapv1 _x $swapv2 _y + # set z $_x + # set _x $_y + # set _y $z + #} + + #*** !doctools + #[subsection {Namespace punk::lib}] + #[para] Core API functions for punk::lib + #[list_begin definitions] + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + #support minimal set from to + proc range {from to} { + lseq $from $to + } + } else { + #lseq accepts basic expressions e.g 4-2 for both arguments + #e.g we can do lseq 0 [llength $list]-1 + #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. + proc range {from to} { + set to [offset_expr $to] + set from [offset_expr $from] + if {$to > $from} { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + #slower methods. + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from] + #} + #return $L + } elseif {$from > $to} { + set count [expr {$from - $to} + 1] + #1) + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from -1];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from -1] + #} + #return $L + } else { + return [list $from] + } + } + } + + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + 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-] || [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 { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + + + 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 { + #*** !doctools + #[call [fun invoke] [arg command]] + #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode + #[example { + # set script { + # puts stdout {hello on stdout} + # puts stderr {hello on stderr} + # exit 42 + # } + # invoke [list tclsh <<$script] + #}] + + #see https://wiki.tcl-lang.org/page/open + lassign [chan pipe] chanout chanin + lappend command 2>@$chanin + set fh [open |$command] + set stdout [read $fh] + close $chanin + set stderr [read $chanout] + close $chanout + if {[catch {close $fh} cres e]} { + dict with e {} + lassign [set -errorcode] sysmsg pid exit + if {$sysmsg eq {NONE}} { + #output to stderr caused [close] to fail. Do nothing + } elseif {$sysmsg eq {CHILDSTATUS}} { + return [list $stdout $stderr $exit] + } else { + return -options $e $stderr + } + } + return [list $stdout $stderr 0] + } + + proc pdict {args} { + package require punk::args + variable has_punk_ansi + if {!$has_punk_ansi} { + set sep " = " + } else { + #set sep " [a+ Web-seagreen]=[a] " + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " + } + set argspec [string map [list %sep% $sep] { + @id -id ::punk::lib::pdict + @cmd -name pdict -help\ + "Print dict keys,values to channel + The pdict function operates on variable names - passing the value to the showdict function which operates on values + (see also showdict)" + + @opts -any 1 + + #default separator to provide similarity to tcl's parray function + -separator -default "%sep%" + -roottype -default "dict" + -substructure -default {} + -channel -default stdout -help\ + "existing channel - or 'none' to return as string" + + @values -min 1 -max -1 + + dictvar -type string -help "name of variable. Can be a dict, list or array" + + patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + 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 */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segment in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + } + }] + #puts stderr "$argspec" + set argd [punk::args::parse $args withdef $argspec] + + 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 ::tcl::array::exists $dvar]] + if {$isarray} { + 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] + } + dict set opts -keysorttype dictionary + } else { + set dvalue [uplevel 1 [list set $dvar]] + } + showdict {*}$opts $dvalue {*}$patterns + } + + #TODO - much. + #showdict needs to be able to show different branches which share a root path + #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) + # - specify ansi colour per pattern so different branches can be highlighted? + # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc + # - The current version is incomplete but passably usable. + # - Copy proc and attempt rework so we can get back to this as a baseline for functionality + proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) + #set sep " [a+ Web-seagreen]=[a] " + variable has_punk_ansi + if {!$has_punk_ansi} { + set RST "" + set sep " = " + #set sep_mismatch " mismatch " + set sep \u2260 ;# equivalent [punk::ansi::convert_g0 [punk::ansi::g0 |]] (not equal symbol) + } else { + set RST [punk::ansi::a] + set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support + #set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]\u2260$RST " + } + package require punk::pipe + #package require punk ;#we need pipeline pattern matching features + package require textblock + + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + @id -id ::punk::lib::showdict + @cmd -name punk::lib::showdict -help "display dictionary keys and values" + #todo - table tableobject + -return -default "tailtohead" -choices {tailtohead sidebyside} + -channel -default none + -trimright -default 1 -type boolean -help\ + "Trim whitespace off rhs of each line. + This can help prevent a single long line that wraps in terminal from making + every line wrap due to long rhs padding." + -separator -default {%sep%} -help\ + "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help\ + "Separator to use when patterns mismatch" + -roottype -default "dict" -help\ + "list,dict,string" + -ansibase_keys -default "" -help\ + "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -substructure -default {} + -ansibase_values -default "" + -keytemplates -default {\$\{$key\}} -type list -help\ + "list of templates for keys at each level" + -keysorttype -default "none" -choices {none dictionary ascii integer real} + -keysortdirection -default increasing -choices {increasing decreasing} + -debug -default 0 -type boolean -help\ + "When enabled, produces some rudimentary debug output on stderr" + -- -type none -optional 1 + @values -min 1 -max -1 + dictvalue -type list -help\ + "dict or list value" + patterns -default "*" -type string -multiple 1 -help\ + "key or key glob pattern" + }]] + + #for punk::lib - we want to reduce pkg dependencies. + # - so we won't even use the tcllib debug pkg here + set opt_debug [dict get $argd opts -debug] + if {$opt_debug} { + if {[info body debug::showdict] eq ""} { + proc ::punk::lib::debug::showdict {args} { + catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} + } + } + } else { + if {[info body debug::showdict] ne ""} { + proc ::punk::lib::debug::showdict {args} {} + } + } + + set opt_sep [dict get $argd opts -separator] + set opt_mismatch_sep [dict get $argd opts -separator_mismatch] + set opt_keysorttype [dict get $argd opts -keysorttype] + set opt_keysortdirection [dict get $argd opts -keysortdirection] + set opt_trimright [dict get $argd opts -trimright] + set opt_keytemplates [dict get $argd opts -keytemplates] + debug::showdict "keytemplates ---> $opt_keytemplates <---" + set opt_ansibase_keys [dict get $argd opts -ansibase_keys] + set opt_ansibase_values [dict get $argd opts -ansibase_values] + set opt_return [dict get $argd opts -return] + set opt_roottype [dict get $argd opts -roottype] + set opt_structure [dict get $argd opts -substructure] + + set dval [dict get $argd values dictvalue] + set patterns [dict get $argd values patterns] + + set result "" + + #pattern hierarchy + # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest + # * @1 @0,%#,%str - segments + # a b 1 0 %# %str - keys + + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated + set pattern_next_substructure [dict create] + set pattern_this_structure [dict create] + + # -- --- --- --- + #REVIEW + #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. + #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #e.g pdict something * + #we want the keys from the result as individual lines on lhs + #e.g pdict something @@ + #we want on lhs result on rhs + # = v0 + #e.g pdict something @0-2,@4 + #we currently return: + #0 = v0 + #1 = v1 + #2 = v2 + #4 = v4 + #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) + #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. + #this is a tradeoff that could create surprises and make things messy and/or inconsistent. + #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. + #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys + #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment + #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) + # -- --- --- --- + + set filtered_keys [list] + 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 { + set keyset [list] + set keyset_structure [list] + + set segments [split $pattern_nest /] + set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns + #we need to use _split_patterns to separate (e.g to protect commas that appear within quotes) + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + #puts stderr "showdict-->_split_patterns: $patterninfo" + foreach v_idx $patterninfo { + lassign $v_idx v idx + #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) + set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern + if {[string index $p 0] eq "!"} { + set get_not 1 + set p [string range $p 1 end] + } else { + set get_not 0 + } + switch -exact -- $p { + * - "" { + if {$opt_roottype eq "list"} { + set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + dict set pattern_this_structure $p list + } elseif {$opt_roottype eq "dict"} { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } else { + lappend keyset %string + lappend keyset_structure string + dict set pattern_this_structure $p string + } + } + %# { + dict set pattern_this_structure $p string + lappend keyset %# + lappend keyset_structure string + } + # { + #todo get_not !# is test for listiness (see punk) + dict set pattern_this_structure $p list + lappend keyset # + lappend keyset_structure list + } + ## { + dict set pattern_this_structure $p dict + lappend keyset [list ## query] + lappend keyset_structure dict + } + @* { + #puts "showdict ---->@*<----" + dict set pattern_this_structure $p list + set keys [punk::lib::range 0 [llength $dval]-1] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } + @@ { + #get first k v from dict + dict set pattern_this_structure $p dict + lappend keyset [list @@ query] + lappend keyset_structure dict + } + @*k@* - @*K@* { + #returns keys only + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @*.@* { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + default { + #puts stderr "===p:$p" + #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key + switch -glob -- $p { + {@k\*@*} - {@K\*@*} { + #value glob return keys + #set search [string range $p 4 end] + #dict for {k v} $dval { + # if {[string match $search $v]} { + # lappend keyset $k + # } + #} + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @@* { + #exact match key - review - should raise error to match punk pipe behaviour? + set k [string range $p 2 end] + if {$get_not} { + if {[dict exists $dval $k]} { + set keys [dict keys [dict remove $dval $k]] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + lappend keyset {*}[dict keys $dval] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + } + } else { + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + } + dict set pattern_this_structure $p dict + } + @k@* - @K@* { + #TODO get_not + set k [string range $p 3 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict + } + {@\*@*} { + #return list of values + #set k [string range $p 3 end] + #lappend keyset {*}[dict keys $dval $k] + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*.@*} { + #TODO get_not + set k [string range $p 4 end] + set keys [dict keys $dval $k] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + {@v\*@*} - {@V\*@*} { + #value-glob return value + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*v@*} - {@\*V@*} { + #key-glob return value + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*@*} - {@\*v@*} - {@\*V@} { + #key glob return val + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @??@* { + #exact key match - no error + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + default { + set this_type $opt_roottype + if {[string match @* $p]} { + #list mode - trim optional list specifier @ + set p [string range $p 1 end] + dict set pattern_this_structure $p list + set this_type list + } elseif {[string match %* $p]} { + dict set pattern_this_structure $p string + lappend keyset $p + lappend keyset_structure string + set this_type string + } + if {$this_type eq "list"} { + dict set pattern_this_structure $p list + if {[string is integer -strict $p]} { + if {$get_not} { + set keys [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $keys $p] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + lappend keyset $p + lappend keyset_structure list + } + } elseif {[string match "?*-?*" $p]} { + #could be either - don't change type + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + #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} == 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 == -Inf} { + ##x + set lower 0 + } else { + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve [llength $dval] $b] + if {$upper == -Inf} { + ##x + #upper bound is below list range - + if {$lower_resolve > -Inf} { + ##x + set upper 0 + } else { + continue + } + } elseif {$upper == Inf} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists + } + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + set keys [punk::lib::range $lower $upper] + if {$get_not} { + set fullrange [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $fullrange {*}$keys] + if {$lower > $upper} { + set keys [lreverse $keys] + } + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + if {$get_not} { + lappend keyset [list !@$p query] + } else { + lappend keyset [list @$p query] + } + lappend keyset_structure list + } + } elseif {$this_type eq "string"} { + dict set pattern_this_structure $p string + } elseif {$this_type eq "dict"} { + #default equivalent to @\*@* + dict set pattern_this_structure $p dict + #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" + set keys [dict keys $dval $p] + if {$get_not} { + set keys [dict keys [dict remove $dval {*}$keys]] + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + puts stderr "list: unrecognised pattern $p" + } + } + } + } + } + } + + # -- --- --- --- + #check next pattern-segment for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $segments 1] + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + if {[llength $patterninfo] == 0} { + # // ? -review - what does this mean? for xpath this would mean at any level + set substructure [lindex $pattern_this_structure end] + } elseif {[llength $patterninfo] == 1} { + #ignore the NOT operator for purposes of query-type detection + if {[string index $pnext 0] eq "!"} { + set pnext [string range $pnext 1 end] + } + # single type in segment e.g /@@something/ + switch -exact -- $pnext { + "" { + set substructure string + } + @*k@* - @*K@* - @*.@* - ## { + set substructure dict + } + # { + set substructure list + } + ## { + set substructure dict + } + %# { + set substructure string + } + * { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + default { + switch -glob -- $pnext { + @??@* - @?@* - @@* { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } + default { + if {[string match @* $pnext]} { + set substructure list + } elseif {[string match %* $pnext]} { + set substructure string + } else { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + } + } + } + } + } else { + #e.g /@0,%str,.../ + #doesn't matter what the individual types are - we have a list result + set substructure list + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + if {$opt_keysorttype ne "none"} { + set int_keyset 1 + foreach k $keyset { + if {![string is integer -strict $k]} { + set int_keyset 0 + break + } + } + if {$int_keyset} { + set sortindices [lsort -indices -integer $keyset] + #set keyset [lsort -integer $keyset] + } else { + #set keyset [lsort -$opt_keysorttype $keyset] + set sortindices [lsort -indices -$opt_keysorttype $keyset] + } + set keyset [lmap i $sortindices {lindex $keyset $i}] + set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] + } + + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + + lappend filtered_keys {*}$keyset + lappend all_keyset_structure {*}$keyset_structure + + #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" + } + } + #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" + } else { + puts stdout "unrecognised roottype: $opt_roottype" + return $dval + } + + if {[llength $filtered_keys]} { + #both keys and values could have newline characters. + #simple use of 'format' won't cut it for more complex dict keys/values + #use block::width or our columns won't align in some cases + switch -- $opt_return { + "tailtohead" { + #last line of key is side by side (possibly with separator) with first line of value + #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values + #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries + + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt {${$key}} + } + #set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] + set display_keys [lmap key $filtered_keys {tstr -ret string -allowcommands $kt}] + set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] + + set kidx 0 + set last_hidekey 0 + foreach keydisplay $display_keys key $filtered_keys { + set thisval "?" + set hidekey 0 + set pattern_nest [lindex $pattern_key_index $kidx] + set pattern_nest_list [split $pattern_nest /] + #set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $key] + set this_type [lindex $all_keyset_structure $kidx] + #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" + + set is_match 1 ;#whether to display the normal separator or bad-match separator + switch -- $this_type { + dict { + #todo? - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict + # - default highlight dupes (ansi underline?) + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + % thisval.= $qry= $dval + } else { + set thisval [tcl::dict::get $dval $key] + } + + #set substructure [lrange $opt_structure 1 end] + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + + set subansibasekeys [lrange $opt_ansibase_keys 1 end] + set nextkeytemplates [lrange $opt_keytemplates 1 end] + #dict set nextopts -substructure $nextsub + dict set nextopts -keytemplates $nextkeytemplates + dict set nextopts -ansibase_keys $subansibasekeys + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" + + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + #puts stderr ">>> nextpatterns:'$nextpatterns' nextopts:'$nextopts'" + set is_match 0 + } + } + } + list { + if {[string is integer -strict $key]} { + set thisval [lindex $dval $key] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + % thisval.= $qry= $dval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + #if {![llength $nextpatterns]} { + # set nextpatterns * + #} + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + set is_match 0 + } + } + } + string { + set hidekey 1 + if {$key eq "%string"} { + set hidekey 1 + set thisval $dval + } elseif {$key eq "%ansiview"} { + set thisval [ansistring VIEW -lf 1 $dval] + } elseif {$key eq "%ansiviewstyle"} { + set thisval [ansistring VIEWSTYLE -lf 1 $dval] + } elseif {[string match *lpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which left -width $width] + } elseif {[string match *lpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which left -width $width -padchar $extra] + } elseif {[string match *rpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which right -width $width] + } elseif {[string match *rpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which right -width $width -padchar $extra] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + set thisval $dval + if {[string index $key 0] ne "%"} { + set key %$key + } + % thisval.= $key= $thisval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + #set nextopts [dict get $argd opts] + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + if {[llength $nextpatterns]} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + + } + } + if {$this_type eq "string" && $hidekey} { + lassign [textblock::size $thisval] _vw vwidth _vh vheight + #set blanks_above [string repeat \n [expr {$kheight -1}]] + set vblock $opt_ansibase_values$thisval$RST + #append result [textblock::join_basic -- $vblock] + #review - we wouldn't need this space if we had a literal %sp %sp-x ?? + append result " $vblock" + } else { + set ansibase_key [lindex $opt_ansibase_keys 0] + + lassign [textblock::size $keydisplay] _kw kwidth _kh kheight + lassign [textblock::size $thisval] _vw vwidth _vh vheight + + set totalheight [expr {$kheight + $vheight -1}] + set blanks_above [string repeat \n [expr {$kheight -1}]] + set blanks_below [string repeat \n [expr {$vheight -1}]] + + if {$is_match} { + set use_sep $opt_sep + } else { + set use_sep $opt_mismatch_sep + } + + + set sepwidth [textblock::width $use_sep] + set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] + set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] + set vblock $blanks_above$opt_ansibase_values$thisval$RST + #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace + if {$last_hidekey} { + append result \n + } + #append result [textblock::join_basic -- $kblock $sblock $vblock] \n + append result [textblock::join_basic_raw $kblock $sblock $vblock] \n + } + set last_hidekey $hidekey + incr kidx + } + } + "sidebyside" { + # TODO - fix + #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. + #use ansibase_key etc to make the output more comprehensible in that situation. + #This is why it is not the default. (review - terminal width detection and wrapping?) + set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] + foreach key $filtered_keys { + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST + #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n + #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic + append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n + } + } + } + } + if {$opt_trimright} { + set result [::join [lines_as_list -line trimright $result] \n] + } + if {[string last \n $result] == [string length $result]-1} { + set result [string range $result 0 end-1] + } + #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) + set chan [dict get $argd opts -channel] + switch -- $chan { + stderr - stdout { + puts $chan $result + } + none { + return $result + } + default { + #review - check member of chan names? + #just try outputting to the supplied channel for now + puts $chan $result + } + } + } + + proc is_list_all_in_list {small large} { + if {[llength $small] > [llength $large]} {return 0} + foreach x $large { + ::set ($x) {} + } + foreach x $small { + if {![info exists ($x)]} { + return 0 + } + } + return 1 + } + #v2 generally seems slower + proc is_list_all_in_list2 {small large} { + set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] + return [struct::list equal [lsort $small] $small_in_large] + } + if {!$has_struct_list || !$has_struct_set} { + set body { + package require struct::list + package require struct::set + } + append body [info body is_list_all_in_list2] + proc is_list_all_in_list2 {small large} $body + } + + proc is_list_all_ni_list {A B} { + foreach x $B { + ::set ($x) {} + } + foreach x $A { + if {[info exists ($x)]} { + return 0 + } + } + return 1 + } + proc is_list_all_ni_list2 {a b} { + set i [struct::set intersect $a $b] + return [expr {[llength $i] == 0}] + } + if {!$has_struct_set} { + set body { + package require struct::list + } + append body [info body is_list_all_ni_list2] + proc is_list_all_ni_list2 {a b} $body + } + + #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist + #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, + # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) + proc ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + #with ledit (also avail in 8.6 using punk::lib::compat::ledit + proc ldiff2 {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + foreach item $removeitems { + set posns [lsearch -all -exact $fromlist $item] + foreach p $posns {ledit fromlist $p $p} + } + return $fromlist + } + proc ldiff3 {fromlist removeitems} { + set doomed [list] + foreach item $removeitems { + lappend doomed {*}[lsearch -all -exact $fromlist $item] + } + lremove $fromlist {*}$doomed + } + + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) + #also struct::set difference with critcl is faster + proc setdiff {A B} { + if {[llength $A] == 0} {return {}} + set d [dict create] + foreach x $A {dict set d $x {}} + foreach x $B {dict unset d $x} + return [dict keys $d] + } + #bulk dict remove is slower than a foreach with dict unset + #proc setdiff2 {fromlist removeitems} { + # #if {[llength $fromlist] == 0} {return {}} + # set d [dict create] + # foreach x $fromlist { + # dict set d $x {} + # } + # return [dict keys [dict remove $d {*}$removeitems]] + #} + #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) + proc setdiff_unordered {A B} { + if {[llength $A] == 0} {return {}} + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] + } + + #default/fallback implementation + proc lunique_unordered {list} { + lunique $list + } + if {$has_struct_set} { + if {[struct::set equal [struct::set union {a a} {}] {a}]} { + proc lunique_unordered {list} { + struct::set union $list {} + } + } else { + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add + } + } + + + #order-preserving + proc lunique {list} { + set new {} + foreach item $list { + if {$item ni $new} { + lappend new $item + } + } + return $new + } + proc lunique2 {list} { + set doomed [list] + #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) + for {set i 0} {$i < [llength $list]} {} { + set item [lindex $list $i] + lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] + while {[incr i] in $doomed} {} + } + lremove $list {*}$doomed + } + #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env + proc lmapflat_closure {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + # -- --- --- + #capture - use uplevel 1 or namespace eval depending on context + set capture [uplevel 1 { + apply { varnames { + set capturevars [tcl::dict::create] + set capturearrs [tcl::dict::create] + foreach fullv $varnames { + set v [tcl::namespace::tail $fullv] + upvar 1 $v var + if {[info exists var]} { + if {(![array exists var])} { + tcl::dict::set capturevars $v $var + } else { + tcl::dict::set capturearrs capturedarray_$v [array get var] + } + } else { + #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set + } + } + return [tcl::dict::create vars $capturevars arrs $capturearrs] + } } [info vars] + } ] + # -- --- --- + set cvars [tcl::dict::get $capture vars] + set carrs [tcl::dict::get $capture arrs] + set apply_script "" + foreach arrayalias [tcl::dict::keys $carrs] { + set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { + array set %realname% [set %arrayalias%][unset %arrayalias%] + }] + } + + append apply_script [string map [list %script% $script] { + #foreach arrayalias [info vars capturedarray_*] { + # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + # array set $realname [set $arrayalias][unset arrayalias] + #} + #return [eval %script%] + %script% + }] + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ + $apply_script\ + ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] + } + return $result + } + #link version - can write to vars in calling context - but keeps varnames themselves isolated + #performance much better than capture version - but still a big price to pay for the isolation + proc lmapflat_link {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + #proc lmapflat {varnames list script} { + # concat {*}[uplevel 1 [list lmap $varnames $list $script]] + #} + #lmap can accept multiple var list pairs + proc lmapflat {args} { + concat {*}[uplevel 1 [list lmap {*}$args]] + } + proc lmapflat2 {args} { + concat {*}[uplevel 1 lmap {*}$args] + } + + #proc dict_getdef {dictValue args} { + # if {[llength $args] < 1} { + # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} + # } + # set keys [lrange $args -1 end-1] + # if {[tcl::dict::exists $dictValue {*}$keys]} { + # return [tcl::dict::get $dictValue {*}$keys] + # } else { + # return [lindex $args end] + # } + #} + if {[info commands ::tcl::dict::getdef] eq ""} { + proc dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef + } + + + #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" + #} + + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {([^+-]*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + + punk::args::define { + @id -id ::punk::lib::is_indexset + @cmd -name punk::lib::is_indexset\ + -summary\ + "Validate string is a comma-delimited 'indexset'."\ + -help\ + "Validate that a string is an 'indexset' + + An indexset consists of a comma delimited list of indexes or index-ranges. + 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') + ..10 + (index 'base' to 10) + 2..11 + (index 2 to 11) + .. + (all indices) + Common whitespace elements space,tab,newlines are 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. + + see indexset_resolve" + @values -min 1 -max 1 + indexset -type string + } + proc is_indexset {indexset} { + #collapse internal whitespace (for basic whitespace set we allow) + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] + if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} { + return 0 + } + set ranges [split $indexset ,] + foreach r $ranges { + set validateindices [list] + set rposn [string first .. $r] + if {$rposn >= 0} { + set sepsize 2 + set step 1 + } else { + #check for .n. 'stepped' range + set fdot [string first . $r] + set ldot [string last . $r] + set step [string range $r $fdot+1 $ldot-1] + #todo - allow basic mathops for step: 2+1 2+-1 etc same as tcl lindex, lseq + if {![string is integer -strict $step]} { + } + } + + if {$rposn >= 0} { + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } else { + #'range' is just an index + set validateindices [list $r] + } + foreach v $validateindices { + if {$v eq "" || $v eq "end"} {continue} + if {[string is integer -strict $v]} {continue} + if {[catch {lindex {} $v}]} { + return 0 + } + } + } + return 1 + } + #review - compare to IMAP4 methods of specifying ranges? + punk::args::define { + @id -id ::punk::lib::indexset_resolve + @cmd -name punk::lib::indexset_resolve\ + -summary\ + "Resolve an indexset to a list of integers based on supplied list or string length."\ + -help\ + "Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value. + 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. + 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 + + 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 + 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 3 + numitems -type integer + indexset -type indexset -help "comma delimited specification for indices to return" + 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] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + 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 based_max [expr {$numitems -1 + $base}] + + foreach ipart $iparts { + set ipart [string trim $ipart] + set rposn [string first .. $ipart] + if {$rposn>=0} { + #range + 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 $base} + set a [punk::lib::lindex_resolve $numitems $rawa $base] + if {$a == -Inf} { + #(was -3) + #undershot - leave negative + } elseif {$a == Inf} { + #overshot + 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 > $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 $base] + if {$b == -Inf} { + #undershot - leave negative + } 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 >= $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 >= $base && $a <= $based_max} { + #only a is in the range + if {$b < $base} { + set b $base + } else { + 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 >=$base && $b <= $based_max} { + #only b is in the range + if {$a < $base} { + set a $base + } else { + 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 < $base && $b > $base} { + #spans the range in forward order + 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 > $base && $b < $base} { + #spans the range in reverse order + 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 $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 -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\ + -summary\ + "Resolve an indexexpression to an integer based on supplied list or string length."\ + -help\ + "Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2 + to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating + whether the index was below or above the range of possible indices for the length supplied. + + Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. + This means the proc may be called with something like $x+2 end-$y etc + Sometimes the actual integer index is desired. + + 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) -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 + bounds indices, or in the case of lrange, return results anyway. + Like Tcl list commands - it will produce an error if the form of the index is not acceptable. + For empty lists/string (datalength 0), end and end+x indices are considered to be out of bounds on the upper side + - thus returning -2 + + Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. + We will get something like 10+1 - which can be resolved safely with expr + " + @values -min 2 -max 2 + datalength -type integer + index -type indexexpression + } + 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 + #[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. + #[para]This means the proc may be called with something like $x+2 end-$y etc + #[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) -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. + #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable + #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 + + #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which can be resolved safely with expr + + + #REVIEW - we need compat for 1_000 etc to handle things like toml even in 8.6? + #A basic string map means we aren't properly validating + #todo - be stricter about malformations such as 1000_ + if {![string is integer -strict 1_0]} { + #basic forward compatibility with integers such as 1_000 for 8.6.x + set index [tcl::string::map {_ {}} $index] + set len [tcl::string::map {_ {}} $len] + } + + if {![string is integer -strict $len] || $len < 0} { + 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 < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } else { + if {[string match end* $index]} { + if {$index ne "end"} { + set op [string index $index 3] + set offset [string range $index 4 end] + #note - offset could have leading + or - + # 'string is integer -strict +1' ==> true + #e.g end+-1 is valid (end++-1 is not) + if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} + if {$offset == 0} { + #(offset +0, -0 or 0 or 000 0_0 etc) + #op either + or - is irrelevant + #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}}] + 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 + } + } else { + #index is 'end' + if {$len == 0} { + #special case - 'end' with empty list - treat end like a positive number out of bounds + return Inf + } + #return [expr {$len - 1 + $base}] + return $based_max + } + } else { + #plain +- already handled above. + #we are trying to avoid evaluating unbraced expr of potentially insecure origin + #regexp must split a++b to a + +b (not a+ + b) ie first +/- is the op + if {[regexp {([^+-]*)([+-])(.*)} $index _match a op b]} { + if {[string is integer -strict $a] && [string is integer -strict $b]} { + if {$op eq "-"} { + set index [expr {$a - $b}] + } else { + set index [expr {$a + $b}] + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + if {$index < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf + } + return $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 -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] || $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 < $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}] + } + } + 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 $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 + } + 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 -Inf + } else { + return $idx + } + } + proc lindex_get {list index} { + set resultlist [lrange $list $index $index] + if {![llength $resultlist]} { + return -1 + } else { + #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. + #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator + return [tcl::dict::create value [lindex $resultlist 0]] + } + } + + proc string_splitbefore {str index} { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -Inf { + return [list "" $str] + } + Inf { + return [list $str ""] + } + } + } + return [list [string range $str 0 $index-1] [string range $str $index end]] + #scan %s stops at whitespace - not useful here. + #scan $s %${p}s%s + } + proc string_splitbefore_indices {str args} { + set parts [list $str] + set sizes [list [string length $str]] + set s 0 + foreach index $args { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -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} { + if {[lindex $sizes 0] != 0} { + ledit parts 0 0 {} [lindex $parts 0] + ledit sizes 0 0 0 [lindex $sizes 0] + } + continue + } + if {$index >= [string length $str]} { + if {[lindex $sizes end] != 0} { + ledit parts end end [lindex $parts end] {} + ledit sizes end end [lindex $sizes end] 0 + } + continue + } + set i -1 + set a 0 + foreach sz $sizes { + incr i + if {$a + $sz > $index} { + set p [lindex $parts $i] + #puts "a:$a index:$index" + if {$a == $index} { + break + } + ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end] + ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}] + break + } + incr a $sz + } + #puts "->parts:$parts" + #puts "->sizes:$sizes" + } + return $parts + } + + proc K {x y} {return $x} + #*** !doctools + #[call [fun K] [arg x] [arg y]] + #[para]The K-combinator function - returns the first argument, x and discards y + #[para]see [uri https://wiki.tcl-lang.org/page/K] + #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. + + + proc is_utf8_multibyteprefix {bytes} { + #*** !doctools + #[call [fun is_utf8_multibyteprefix] [arg str]] + #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character + #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint + #[para] Will return false for an already complete utf-8 codepoint + #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument + #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes + #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] + regexp {(?x) + ^ + (?: + [\xC0-\xDF] | #possible prefix for two-byte codepoint + [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for + ) + $ + } $bytes + } + + proc is_utf8_first {str} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + } $str + } + proc is_utf8_single {1234bytes} { + #*** !doctools + #[call [fun is_utf8_single] [arg 1234bytes]] + #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + $ + } $1234bytes + } + proc get_utf8_leading {rawbytes} { + #*** !doctools + #[call [fun get_utf8_leading] [arg rawbytes]] + #[para] return the leading portion of rawbytes that is a valid utf8 sequence. + #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint + #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. + #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. + #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics + #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned + #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes + if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + \A ( + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + + } $rawbytes completeChars]} { + return $completeChars + } + return "" + } + proc hex2dec {args} { + #*** !doctools + #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] + #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values + #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 + #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. + #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 + #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 + + set list_largeHex [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" + } + set opts [tcl::dict::create\ + -validate 1\ + -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $opts] + foreach {k v} $argopts { + tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v + } + # -- --- --- --- + set opt_validate [tcl::dict::get $opts -validate] + set opt_empty [tcl::dict::get $opts -empty_as_hex] + # -- --- --- --- + + set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] + if {$opt_validate} { + #Note appended F so that we accept list of empty strings as per the documentation + if {![string is xdigit -strict [join $list_largeHex ""]F ]} { + error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" + } + } + if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { + #mapping empty string to a value destroys any advantage of -scanonly + #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] + if {[lsearch $list_largeHex ""] >=0} { + error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" + } + } else { + set opt_empty [string trim [string map {_ ""} $opt_empty]] + if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] + set nonempty_head [lrange $list_largeHex 0 $first_empty-1] + set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] + } + + proc dec2hex {args} { + #*** !doctools + #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] + #[para]Convert a list of decimal integers to a list of hex values + #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. + #[para] -case upper|lower determines the case of the hex letters in the output + set list_decimals [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" + } + set defaults [tcl::dict::create\ + -width 1\ + -case upper\ + -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $defaults] + set fullopts [tcl::dict::create] + foreach {k v} $argopts { + tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v + } + set opts [tcl::dict::merge $defaults $fullopts] + # -- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_case [tcl::dict::get $opts -case] + set opt_empty [tcl::dict::get $opts -empty_as_decimal] + # -- --- --- --- + + + set resultlist [list] + switch -- [string tolower $opt_case] { + upper { + set spec X + } + lower { + set spec x + } + default { + error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" + } + } + set fmt "%${opt_width}.${opt_width}ll${spec}" + + set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] + if {![string is digit -strict [string map {_ ""} $opt_empty]]} { + if {[lsearch $list_decimals ""] >=0} { + error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" + } + } else { + set opt_empty [string map {_ ""} $opt_empty] + if {[set first_empty [lsearch $list_decimals ""]] >= 0} { + set nonempty_head [lrange $list_decimals 0 $first_empty-1] + set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] + } + + proc log2 x "expr {log(\$x)/[expr log(2)]}" + #*** !doctools + #[call [fun log2] [arg x]] + #[para]log base2 of x + #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time + #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) + + proc logbase {b x} { + #*** !doctools + #[call [fun logbase] [arg b] [arg x]] + #[para]log base b of x + #[para]This function uses expr's natural log and the change of base division. + #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 + expr {log($x)/log($b)} + } + proc factors {x} { + #*** !doctools + #[call [fun factors] [arg x]] + #[para]Return a sorted list of the positive factors of x where x > 0 + #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* + #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors + #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions + #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers + #[para]Comparisons were done with some numbers below 17 digits long + #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. + #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers + #but has the disadvantage of being slower for 'small' numbers and using more memory. + #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x + #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py + #[para] In other mathematical contexts zero may be considered not to divide anything. + set factors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {($x % $j) == 0} { + lappend factors $j [expr {$x / $j}] + } + incr j + } + lappend factors $x + return [lsort -unique -integer $factors] + } + proc oddFactors {x} { + #*** !doctools + #[call [fun oddFactors] [arg x]] + #[para]Return a list of odd integer factors of x, sorted in ascending order + set j 2 + set max [expr {sqrt($x)}] + set factors [list 1] + while {$j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2} { + if {$other ni $factors} { + lappend factors $other + } + } + if {$j % 2} { + if {$j ni $factors} { + lappend factors $j + } + } + } + incr j + } + return [lsort -integer -increasing $factors] + } + proc greatestFactorBelow {x} { + #*** !doctools + #[call [fun greatestFactorBelow] [arg x]] + #[para]Return the largest factor of x excluding itself + #[para]factor functions can be useful for console layout calculations + #[para]See Tcllib math::numtheory for more extensive implementations + if {$x % 2 == 0 || $x == 0} { + return [expr {$x / 2}] + } + set j 3 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {$x % $j == 0} { + return [expr {$x / $j}] + } + incr j 2 + } + return 1 + } + proc greatestOddFactorBelow {x} { + #*** !doctools + #[call [fun greatestOddFactorBelow] [arg x]] + #[para]Return the largest odd integer factor of x excluding x itself + if {$x %2 == 0} { + return [greatestOddFactor $x] + } + set j 3 + #dumb brute force - time taken to compute is wildly variable on big numbers + #todo - use a (memoized?) generator of primes to reduce the search space + #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. + set god 1 + set max [expr {sqrt($x)}] + while { $j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2 == 0} { + set god $j + } else { + set god [expr {$x / $j}] + #lowest j - so other side must be highest + break + } + } + incr j 2 + } + return $god + } + proc greatestOddFactor {x} { + #*** !doctools + #[call [fun greatestOddFactor] [arg x]] + #[para]Return the largest odd integer factor of x + #[para]For an odd value of x - this will always return x + if {$x % 2 != 0 || $x == 0} { + return $x + } + set r [expr {$x / 2}] + while {$r % 2 == 0} { + set r [expr {$r / 2}] + } + return $r + } + proc gcd {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the greatest common divisor of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para]Graphical use: + #[para]An a by b rectangle can be covered with square tiles of side-length c, + #[para]only if c is a common divisor of a and b + + # + # Apply Euclid's good old algorithm + # + if { $n > $m } { + set t $n + set n $m + set m $t + } + + while { $n > 0 } { + set r [expr {$m % $n}] + set m $n + set n $r + } + + return $m + } + proc lcm {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the lowest common multiple of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para] + set gcd [gcd $n $m] + return [expr {$n*$m/$gcd}] + } + proc commonDivisors {x y} { + #*** !doctools + #[call [fun commonDivisors] [arg x] [arg y]] + #[para]Return a list of all the common factors of x and y + #[para](equivalent to factors of their gcd) + return [factors [gcd $x $y]] + } + + #experimental only - there are better/faster ways + proc sieve n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + tcl::dict::for {next -} $nums break + } + return [concat $primes [tcl::dict::keys $nums]] + } + proc sieve2 n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + #dict for {next -} $nums break + set next [lindex $nums 0] + } + return [concat $primes [tcl::dict::keys $nums]] + } + + proc hasglobs {str} { + #*** !doctools + #[call [fun hasglobs] [arg str]] + #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] + #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. + regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving + } + + proc trimzero {number} { + #*** !doctools + #[call [fun trimzero] [arg number]] + #[para]Return number with left-hand-side zeros trimmed off - unless all zero + #[para]If number is all zero - a single 0 is returned + set trimmed [string trimleft $number 0] + if {[string length $trimmed] == 0} { + set trimmed 0 + } + return $trimmed + } + proc substring_count {str substring} { + #*** !doctools + #[call [fun substring_count] [arg str] [arg substring]] + #[para]Search str and return number of occurrences of substring + + #faster than lsearch on split for str of a few K + if {$substring eq ""} {return 0} + set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] + return [expr {$occurrences / [string length $substring]}] + } + + proc dict_merge_ordered {defaults main} { + #*** !doctools + #[call [fun dict_merge_ordered] [arg defaults] [arg main]] + #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. + #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. + #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. + + #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] + } + + proc askuser {question} { + #*** !doctools + #[call [fun askuser] [arg question]] + #[para]A basic utility to read an answer from stdin + #[para]The prompt is written to the terminal and then it waits for a user to type something + #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. + #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. + #[para](Generic terminal raw vs linemode detection not yet present) + #[para]The user must hit enter to submit the response + #[para]The return value is the string if any that was typed prior to hitting enter. + #[para]The question argument can be manually colourised using the various punk::ansi funcitons + #[example_begin] + # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] + # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { + # puts "Proceeding" + # } else { + # puts "Cancelled by user" + # } + #[example_end] + puts stdout $question + flush stdout + set stdin_state [chan configure stdin] + if {[catch { + package require punk::console + set console_raw [tsv::get console is_raw] + } err_console]} { + #assume normal line mode + set console_raw 0 + } + try { + chan configure stdin -blocking 1 + if {$console_raw} { + punk::console::disableRaw + set answer [gets stdin] + punk::console::enableRaw + } else { + set answer [gets stdin] + } + } finally { + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] + } + return $answer + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text {max -1}} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + if {$max != -1} { + set len [expr {min($len,$max)}] + } + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + #e.g linesort -decreasing $data + proc linesort {args} { + #*** !doctools + #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] + #[para]Sort lines in textblock + #[para]Returns another textblock with lines sorted + #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique + if {[llength $args] < 1} { + error "linesort missing lines argument" + } + set lines [lindex $args end] + set opts [lrange $args 0 end-1] + #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts + list_as_lines [lsort {*}$opts [linelist $lines]] + } + + proc list_as_lines {args} { + #*** !doctools + #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] + #[para]This simply joins the elements of the list with -joinchar + #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines + #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. + if {[set eop [lsearch $args --]] == [llength $args]-2} { + #end-of-opts not really necessary - except for consistency with lines_as_list + set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] + } + if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { + set joinchar [lindex $args 1] + set lines [lindex $args 2] + } elseif {[llength $args] == 1} { + set joinchar "\n" + set lines [lindex $args 0] + } else { + error "list_as_lines usage: list_as_lines ?-joinchar ? " + } + return [join $lines $joinchar] + } + proc list_as_lines2 {args} { + #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? + lassign [tcl::dict::values [punk::args::parse $args withdef { + -joinchar -default \n + @values -min 1 -max 1 + }]] leaders opts values + + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] + } + + proc lines_as_list {args} { + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. + #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error + #..because we don't know what to say if there are odd numbers of args + #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work + #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway + + if {[lsearch $args "--"] == [llength $args]-2} { + set opts [lrange $args 0 end-2] + } else { + set opts [lrange $args 0 end-1] + } + #set opts [tcl::dict::merge {-block {}} $opts] + set bposn [lsearch $opts -block] + if {$bposn < 0} { + lappend opts -block {} + } + set text [lindex $args end] + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] + } + #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds + proc lines_as_list2 {args} { + #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults + #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc + #we don't have to decide what is an opt vs a value + #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) + lassign [tcl::dict::values [punk::args::parse $args withdef { + @opts -any 1 + -block -default {} + }]] leaderdict opts valuedict + tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] + } + + # important for pipeline & match_assign + # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? + # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace + set linelist_body { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + ;#package require punk::ansi + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list/detectcode_in_list will check at first level. (not intended for detecting ansi in deeper structures) + + #we use detectcode_in_list instead of detect_in_list + #detectcode_in_list will detect unclosed (or unopened) paired sequences such as PM (privacy message) + # - but the main reason is it is slightly faster. + if {![punk::ansi::ta::detectcode_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach code $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + #not sure if this handles more complex hierarchies or mixins etc. + lassign $args obj method + if {![info object isa object $obj]} { + error "show_jump_tables unable to examine '$args'. $obj is not an oo object" + } + #classes are objects too and can have direct methods + if {$method in [info object methods $obj]} { + set data [tcl::unsupported::disassemble objmethod $obj $method] + } else { + if {![info object isa class $obj]} { + set obj [info object class $obj] + } + set data [tcl::unsupported::disassemble method $obj $method] + } + } else { + error "show_jump_tables expected a procname or a class/object and method" + } + set result "" + set in_jt 0 + foreach ln [split $data \n] { + set tln [::tcl::string::trim $ln] + if {!$in_jt} { + if {[::tcl::string::match *jumpTable* $ln]} { + punk::ns::call_frame + append result $ln \n + set in_jt 1 + } + } else { + if {[::tcl::string::match Command* $tln] || [::tcl::string::match "(*) *" $tln]} { + set in_jt 0 + } else { + append result $ln \n + } + } + } + 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)}] + } + proc temperature_c_to_f {deg_celsius} { + return [expr {($deg_celsius * (9/5.0)) + 32}] + } + + proc interp_sync_package_paths {interp} { + if {![interp exists $interp]} { + error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" + } + interp eval $interp [list set ::auto_path $::auto_path] + interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} + interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] + } + + proc valcopy {obj} { + append obj2 $obj {} + } + proc set_valcopy {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_valcopy varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + + + proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { + variable has_twapi + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + set localeid [twapi::get_system_default_lcid] + } + } + #when using twapi we currently only get the localeid - not the specific defaults + #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this + set default_delim "," + set default_groupsize 3 + + set results [list] + set nums [valcopy $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list + foreach inputnum $nums { + set number [valcopy $inputnum] + #also handle tcl 8.7+ underscores in numbers + set number [string map [list _ "" , ""] $number] + #normalize e.g 2e4 -> 20000.0 + set number [expr {$number}] + + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + lappend results [twapi::format_number $number $localeid -idigits -1] + continue + } else { + #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one + #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? + if {$delim eq ""} {set delim $default_delim} + if {$groupsize eq ""} {set groupsize $default_groupsize} + lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] + continue + } + } + #todo - get configured user defaults + if {$delim eq ""} { + set delim $default_delim + } + if {$groupsize eq ""} { + set groupsize $default_groupsize + } + + lappend results [delimit_number $number $delim $groupsize] + } + + if {[llength $results] == 1} { + #keep intrep as string rather than list + return [lindex $results 0] + } + return $results + } + + + #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse + # Given a number represented as a string, insert delimiters to break it up for + # readability. Normally, the delimiter will be a comma which will be inserted every + # three digits. However, the delimiter and groupsize are optional arguments, + # permitting use in other locales. + # + # The string is assumed to consist of digits, possibly preceded by spaces, + # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* + + proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { + set number [valcopy $unformattednumber] + set number [string map {_ ""} $number] + #normalize using expr - e.g 2e4 -> 20000.0 + set number [expr {$number}] + # First, extract right hand part of number, up to and including decimal point + set point [string last "." $number]; + if {$point >= 0} { + set PostDecimal [string range $number $point+1 end]; + set PostDecimalP 1; + } else { + set point [expr {[string length $number] + 1}] + set PostDecimal ""; + set PostDecimalP 0; + } + + # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? + set ind 0; + while {[string equal [string index $number $ind] \u0020]} { + incr ind; + } + set FirstNonSpace $ind; + set LastSpace [expr {$FirstNonSpace - 1}]; + set LeadingSpaces [string range $number 0 $LastSpace]; + + # Now extract the non-fractional part of the number, omitting leading spaces. + set MainNumber [string range $number $FirstNonSpace $point-1]; + + # Insert commas into the non-fractional part. + set Length [string length $MainNumber]; + set Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; + set DelimitedMain ""; + + #First we deal with the extra stuff. + if {$Phase > 0} { + append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; + } + set FirstInGroup $Phase; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; + while {$LastInGroup < $Length} { + if {$FirstInGroup > 0} { + append DelimitedMain $delim; + } + append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; + incr FirstInGroup $GroupSize + incr LastInGroup $GroupSize + } + + # Reassemble the number. + if {$PostDecimalP} { + return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; + } else { + return [format "%s%s" $LeadingSpaces $DelimitedMain]; + } + } + + #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 + #[list_end] [comment {--- end definitions namespace punk::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} + +tcl::namespace::eval punk::lib::test { + + + +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#todo - way to generate 'internal' docs separately? +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::lib::system { + #*** !doctools + #[subsection {Namespace punk::lib::system}] + #[para] Internal functions that are not part of the API + #[list_begin definitions] + + + proc mostFactorsBelow {n} { + ##*** !doctools + #[call [fun mostFactorsBelow] [arg n]] + #[para]Find the number below $n which has the greatest number of factors + #[para]This will get slow quickly as n increases (100K = 1s+ 2024) + set most 0 + set mostcount 0 + for {set i 1} {$i < $n} {incr i} { + set fc [llength [punk::lib::factors $i]] + if {$fc > $mostcount} { + set most $i + set mostcount $fc + } + } + return [list number $most numfactors $mostcount] + } + proc factorCountBelow_punk {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [punk::lib::factors $i]] + } + return $tally + } + proc factorCountBelow_numtheory {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) + package require math::numtheory + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [math::numtheory::factors $i]] + } + return $tally + } + + proc factors2 {x} { + ##*** !doctools + #[call [fun factors2] [arg x]] + #[para]Return a sorted list of factors of x + #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. + set smallfactors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j < $max} { + if {($x % $j) == 0} { + lappend smallfactors $j + lappend largefactors [expr {$x / $j}] + } + incr j + } + #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop + if {($x % $j) == 0} { + if {$j == ($x / $j)} { + lappend smallfactors $j + } + } + return [concat $smallfactors [lreverse $largefactors] $x] + } + + + + # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command + #important - used by punk::repl + proc incomplete {partial} { + #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + #puts stderr "-->$clist<--" + set waiting [list ""] + set innerpartials [list ""] + set escaped 0 + set i 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + incr i + continue + } ;# set escaped 0 at end + set p [lindex $innerpartials end] + if {$escaped == 0} { + #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) + switch -- $c { + {"} { + if {![info complete ${p}]} { + lappend waiting {"} + lappend innerpartials "" + } else { + if {[lindex $waiting end] eq {"}} { + #this quote is endquote + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + if {![info complete ${p}$c]} { + lappend waiting {"} + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } + {[} { + if {![info complete ${p}$c]} { + lappend waiting "\]" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "{" { + if {![info complete ${p}$c]} { + lappend waiting "\}" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "}" - + default { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } else { + set p ${p}${c} + lset innerpartials end $p + } + set escaped 0 + incr i + } + set incomplete [list] + foreach w $waiting { + #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. + switch -- $w { + {"} { + lappend incomplete $w + } + {]} { + lappend incomplete "\[" + } + "{" {} + "}" { + lappend incomplete "\{" + } + } + } + set debug 0 + if {$debug} { + foreach w $waiting p $innerpartials { + puts stderr "->awaiting:'$w' partial: $p" + } + } + return $incomplete + } + #This only works for very simple cases will get confused with for example: + # {set x "a["""} + proc incomplete_naive {partial} { + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + set waiting [list] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } + if {!$escaped} { + if {$c eq {"}} { + if {[lindex $waiting end] eq {"}} { + set waiting [lrange $waiting 0 end-1] + } else { + lappend waiting {"} + } + } elseif {$c eq "\["} { + lappend waiting "\]" + } elseif {$c eq "\{"} { + lappend waiting "\}" + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + } + } + } + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + return $incomplete + } + + #get info about punk nestindex key ie type: list,dict,undetermined + # pdict devel + proc nestindex_info {args} { + set argd [punk::args::parse $args withdef { + -parent -default "" + nestindex + }] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + #??? + + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] +} + +tcl::namespace::eval punk::lib::debug { + proc showdict {args} {} +} + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::lib +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::lib [tcl::namespace::eval punk::lib { + variable pkg punk::lib + variable version + set version 0.1.4 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/bootsupport/modules/punk/libunknown-0.1.tm index e0532e41..fea6b146 100644 --- a/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/bootsupport/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/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/bootsupport/modules/punk/mix/util-0.1.0.tm index 8e4699dc..677ad6e4 100644 --- a/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/util-0.1.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/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index 82756da2..4a680500 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.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/bootsupport/modules/punk/repl-0.1.2.tm b/src/bootsupport/modules/punk/repl-0.1.2.tm index f976ae57..e56da520 100644 --- a/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/bootsupport/modules/punk/repl-0.1.2.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/bootsupport/modules/punk/repl/codethread-0.1.1.tm b/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm index 9df5ae56..a074cd76 100644 --- a/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm +++ b/src/bootsupport/modules/punk/repl/codethread-0.1.1.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/bootsupport/modules/punk/trie-0.1.0.tm b/src/bootsupport/modules/punk/trie-0.1.0.tm index 0b5bd298..9adb8b36 100644 --- a/src/bootsupport/modules/punk/trie-0.1.0.tm +++ b/src/bootsupport/modules/punk/trie-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::trie 0 0.1.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 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/bootsupport/modules/punkcheck-0.1.0.tm index 451ad7a5..9c44ea72 100644 --- a/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/bootsupport/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/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm index d83c17d9..93e4a41c 100644 --- a/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/bootsupport/modules/textblock-0.1.3.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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.7.2.tm new file mode 100644 index 00000000..aa7405e2 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/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] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm index 5045579b..2b2118cf 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 0ab37079..fb5adce3 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/aliascore-0.1.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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index ccc6bb78..3d9988b1 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index c20e3b51..3071ebd3 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm index 3a74754f..3f25023e 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index e1f2a440..39eeccd2 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::console 0 0.1.1] #[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 0.1.1 + set version 0.1.1 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.1.tm new file mode 100644 index 00000000..d0e740fa --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.1.tm @@ -0,0 +1,1739 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::fileline 0.1.1 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::fileline 0 0.1.1] +#[copyright "2024"] +#[titledesc {file line-handling utilities}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] +#[require punk::fileline] +#[keywords module text parse file encoding BOM] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para]Utilities for in-memory analysis of text file data as both line data and byte/char-counted data whilst preserving the line-endings (even if mixed) +#[para]This is important for certain text files where examining the number of chars/bytes is important +#[para]For example - windows .cmd/.bat files need some byte counting to determine if labels lie on chunk boundaries and need to be moved. +#[para]This chunk-size counting will depend on the character encoding. +#[para]Despite including the word 'file', the library doesn't necessarily deal with reading/writing to the filesystem - +#[para]The raw data can be supplied as a string, or loaded from a file using punk::fileline::get_textinfo -file +#[subsection Concepts] +#[para]A chunk of textfile data (possibly representing a whole file - but usually at least a complete set of lines) is loaded into a punk::fileline::class::textinfo instance at object creation. +#[example_begin] +# package require punk::fileline +# package require fileutil +# set rawdata [lb]fileutil::cat data.txt -translation binary[rb] +# punk::fileline::class::textinfo create obj_data $rawdata +# puts stdout [lb]obj_data linecount[rb] +#[example_end] +#[subsection Notes] +#[para]Line records are referred to by a zero-based index instead of a one-based index as is commonly used when displaying files. +#[para]This is for programming consistency and convenience, and the module user should do their own conversion to one-based indexing for line display or messaging if desired. +#[para]No support for lone carriage-returns being interpreted as line-endings. +#[para]CR line-endings that are intended to be interpreted as such should be mapped to something else before the data is supplied to this module. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages needed by punk::fileline +#[list_begin itemized] + + package require Tcl 8.6- + package require punk::args + #*** !doctools + #[item] [package {Tcl 8.6-}] + #[item] [package {punk::args}] + + + # #package require frobz + # #*** !doctools + # #[item] [package {frobz}] + +#*** !doctools +#[list_end] [comment {- end dependencies list -}] + +#*** !doctools +#[subsection {optional dependencies}] +#[para] packages that add functionality but aren't strictly required +#[list_begin itemized] + + #*** !doctools + #[item] [package {punk::ansi}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + #[item] [package {punk::char}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + #[item] [package {overtype}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + + +#*** !doctools +#[list_end] [comment {- end optional dependencies list -}] + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline::class { + namespace export * + #*** !doctools + #[subsection {Namespace punk::fileline::class}] + #[para] class definitions + if {[info commands [namespace current]::textinfo] 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}] + # } + + + #uses zero based indexing. Caller can add 1 for line numbers + oo::class create [namespace current]::textinfo { + #*** !doctools + #[enum] CLASS [class textinfo] + #[list_begin definitions] + # [para] [emph METHODS] + + variable o_chunk ;#current state + variable o_chunkop_store + variable o_lineop_store + + variable o_chunk_epoch + variable o_line_epoch + variable o_payloadlist + variable o_linemap + variable o_LF_C + variable o_CRLF_C + + + variable o_bom_id + variable o_bom + variable o_bom_map + + #review - for now we expect datachunk to be data without BOM and already encoded appropriately + #fileline::get_textinfo has support for interpreting BOM - but we currently have no way to do that for data not coming from a file + #refactor to allow that code to be called from here? + constructor {datachunk args} { + #*** !doctools + #[call class::textinfo [method constructor] [arg datachunk] [opt {option value...}]] + #[para] Constructor for textinfo object which represents a chunk or all of a file + #[para] datachunk should be passed with the file data including line-endings as-is for full functionality. ie use something like: + #[example_begin] + # chan configure $fd -translation binary + # set chunkdata [lb]read $fd[rb]] + #or + # set chunkdata [lb]fileutil::cat -translation binary[rb] + #[example_end] + #[para] when loading the data + namespace eval [namespace current] { + set nspath [namespace path] + foreach p [list ::punk::fileline ::punk::fileline::ansi] { + if {$p ni $nspath} { + lappend nspath $p + } + } + namespace path $nspath + } + + set o_bom_map [list\ + utf-8 \u00ef\u00bb\u00bf\ + utf-16be \u00fe\u00ff\ + utf-16le \u00ff\u00fe\ + utf-32be \u0000\u0000\u00fe\u00ff\ + utf-32le \u00ff\u00fe\u0000\u0000\ + utf-7 \u002b\u002f\u0076\ + utf-1 \u00f7\u0064\u004c\ + utf-ebcdic \u00dd\u0073\u0066\u0073\ + utf-scsu \u0003\u00fe\u00ff\ + utf-bocu-1 \u00fb\u00ee\u0028\ + utf-gb18030 \u0084\u0031\u0095\u0033\ + ] + set o_bom_id "" + set o_bom "" ;#review + + set o_chunk $datachunk + set o_line_epoch [list] + set o_chunk_epoch [list "fromchunkchange-at-[clock micros]"] + set crlf_lf_placeholders [list \uFFFF \uFFFE] ;#defaults - if already exist in file - error out with message + set defaults [dict create\ + -substitutionmap {}\ + -crlf_lf_placeholders $crlf_lf_placeholders\ + -userid ""\ + ] + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "[self] constructor error: unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- + set opt_substitutionmap [dict get $opts -substitutionmap] ;#review - can be done by caller - or a loadable -policy + set opt_crlf_lf_placeholders [dict get $opts -crlf_lf_placeholders] + set opt_userid [dict get $opts -userid] + # -- --- --- --- --- --- --- + + if {[llength $opt_crlf_lf_placeholders] != 2 || [string length [lindex $opt_crlf_lf_placeholders 0]] !=1 || [string length [lindex $opt_crlf_lf_placeholders 1]] !=1} { + error "textinfo::constructor error: -crlf_lf_placeholders requires a list of exactly 2 chars" + } + lassign $opt_crlf_lf_placeholders o_LF_C o_CRLF_C + if {[string first $o_LF_C $o_chunk] >=0} { + set decval [scan $o_LF_C %c] + if {$decval < 32 || $decval > 127} { + set char_desc "(decimal value $decval)" + } else { + set char_desc "'$o_LF_C' (decimal value $decval)" + } + error "textinfo::constructor error: rawfiledata already contains linefeed substitution character $char_desc specified as first element of -crlf_lf_placeholders" + } + if {[string first $o_CRLF_C $o_chunk] >=0} { + set decval [scan $o_CRLF_C %c] + if {$decval < 32 || $decval > 127} { + set char_desc "(decimal value $decval)" + } else { + set char_desc "'$o_CRLF_C' (decimal value $decval)" + } + error "textinfo::constructor error: rawfiledata already contains carriagereturn-linefeed substitution character $char_desc specified as second element of -crlf_lf_placeholders" + } + if {$o_LF_C eq $o_CRLF_C} { + puts stderr "WARNING: same substitution character used for both elements of -crlf_lf_placeholders - byte counting may be off if file contains mixed line-endings" + } + + my regenerate_lines + + } + + method set_bomid {bomid} { + if {$bomid ni [dict keys $o_bom_map]} { + error "Unrecognised bom-id $bomid. Known values: [dict keys $o_bom_map]" + } + set o_bom_id $bomid + set o_bom [dict get $o_bom_map $bomid] + } + method get_bomid {} { + return $o_bom_id + } + method get_bom {} { + return $o_bom + } + + method chunk {chunkstart chunkend} { + #*** !doctools + #[call class::textinfo [method chunk] [arg chunkstart] [arg chunkend]] + #[para]Return a range of bytes from the underlying raw chunk data. + #[para] e.g The following retrieves the entire chunk + #[para] objName chunk 0 end + return [string range $o_chunk $chunkstart $chunkend] + } + method chunklen {} { + #*** !doctools + #[call class::textinfo [method chunklen]] + #[para] Number of bytes/characters in the raw data of the file + return [string length $o_chunk] + } + method chunk_boundary_display {chunkstart chunkend chunksize args} { + #*** !doctools + #[call class::textinfo [method chunk_boundary_display]] + #[para]Returns a string displaying the boundaries at chunksize bytes between chunkstart and chunkend + #[para]Defaults to using ansi colour if punk::ansi module is available. Use -ansi 0 to disable colour + set opts [dict create\ + -ansi $::punk::fileline::ansi::enabled\ + -offset 0\ + -displaybytes 200\ + -truncatedmark "..."\ + -completemark "---"\ + -moremark " + "\ + -continuemark " > "\ + -linemaxwidth 100\ + -linebase 0\ + -limit -1\ + -boundaries {}\ + -showconfig 0\ + -boundaryheader {Boundary %i% at %b%}\ + ] + foreach {k v} $args { + switch -- $k { + -ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader { + dict set opts $k $v + } + default { + error "[self]::chunk_boundary error: unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_ansi [dict get $opts -ansi] + set opt_offset [dict get $opts -offset] + set opt_displaybytes [dict get $opts -displaybytes] + set opt_tmark [dict get $opts -truncatedmark] + set opt_cmark [dict get $opts -completemark] + set opt_linemax [dict get $opts -linemaxwidth] + set opt_linebase [dict get $opts -linebase] + set opt_linebase [string map [list _ ""] $opt_linebase] + set opt_limit [dict get $opts -limit] ;#limit number of boundaries to display + set opt_boundaries [dict get $opts -boundaries] ;#use pre-calculated boundaries if supplied + set opt_showconfig [dict get $opts -showconfig] + set opt_boundaryheader [dict get $opts -boundaryheader] + # -- --- --- --- --- --- + package require overtype + # will require punk::char and punk::ansi + + if {"::punk::fileline::ansi::ansistrip" ne [info commands ::punk::fileline::ansi::ansistrip]} { + namespace eval ::punk::fileline::ansi { + namespace import ::punk::ansi::* + } + } + + #This mechanism for enabling/disabling ansi is a bit clumsy - prone to errors with regard to keeping in sync with any api changes in punk ansi + #It's done here to allow this to be used without the full set of punk modules and/or shell - REVIEW + + #risk of failing to reset on error + set pre_ansi_enabled $::punk::fileline::ansi::enabled + if {$opt_ansi} { + set ::punk::fileline::ansi::enabled 1 + } else { + set ::punk::fileline::ansi::enabled 0 + } + if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { + proc ::punk::fileline::a {args} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::a {*}$args + } else { + return "" + } + } + proc ::punk::fileline::a+ {args} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::a+ {*}$args + } else { + return "" + } + } + proc ::punk::fileline::ansistrip {str} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::ansistrip $str + } else { + return $str + } + } + } + set maxline [lindex [my chunkrange_to_linerange $chunkend $chunkend] 0] + set minline [lindex [my chunkrange_to_linerange $chunkstart $chunkstart] 0] + + #suport simple end+-int (+-)start(+-)int to set linebase to line corresponding to chunkstart or chunkend + #also simple int+int and int-int - nothing more complicated (similar to Tcl lrange etc in that regard) + #commonly this will be something like -start or -end + if {![string is integer -strict $opt_linebase]} { + set sign "" + set errunrecognised "unrecognised -linebase value '$opt_linebase'. Expected positive or negative integer or -start -start-int -start+int -end -end-int -end+int or -eof (where leading - is optional but probably desirable) " + if {[string index $opt_linebase 0] eq "-"} { + set sign - + set tail [string range $opt_linebase 1 end] + } else { + set tail [string trimleft $opt_linebase +];#ignore + + } + #todo - switch -glob -- $tail + if {[string match eof* $tail]} { + set endmath [string range $tail 3 end] + #todo endmath? + if {$tail eq "eof"} { + set lastline [lindex [my chunkrange_to_linerange end end] 0] + set linebase ${sign}$lastline + } else { + error $errunrecognised + } + } elseif {[string match end* $tail]} { + set endmath [string range $tail 3 end] + if {[string length $endmath]} { + set op [string index $endmath 0] + if {$op in {+ -}} { + set operand [string range $endmath 1 end] + if {[string is integer -strict $operand]} { + if {$op eq "+"} { + set linebase [expr {$maxline + $operand}] + } else { + set linebase [expr {$maxline - $operand}] + } + } else { + error $errunrecognised + } + } else { + error $errunrecognised + } + } else { + set linebase $maxline + } + set linebase ${sign}$linebase + } elseif {[string match start* $tail]} { + set endmath [string range $tail 5 end] + if {[string length $endmath]} { + set op [string index $endmath 0] + if {$op in {+ -}} { + set operand [string range $endmath 1 end] + if {[string is integer -strict $operand]} { + if {$op eq "+"} { + set linebase [expr {$minline + $operand}] + } else { + set linebase [expr {$minline - $operand}] + } + } else { + error $errunrecognised + } + } else { + error $errunrecognised + } + } else { + set linebase $minline + } + set linebase ${sign}$linebase + } elseif {[string match *-* $tail]} { + set extras [lassign [split $tail -] int1 int2] + if {[llength $extras]} { + error $errunrecognised + } + if {![string is integer -strict $int1] || ![string is integer -strict $int2]} { + error $errunrecognised + } + set linebase [expr {$int1 - $int2}] + set linebase ${sign}$linebase + } elseif {[string match *+* $tail]} { + set extras [lassign [split $tail +] int1 int2] + if {[llength $extras]} { + error $errunrecognised + } + if {![string is integer -strict $int1] || ![string is integer -strict $int2]} { + error $errunrecognised + } + set linebase [expr {$int1 + $int2}] + set linebase ${sign}$linebase + } else { + error $errunrecognised + } + + } else { + set linebase $opt_linebase + } + + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + + if {![llength $opt_boundaries]} { + set binfo [lib::range_spans_chunk_boundaries $chunkstart $chunkend $chunksize -offset $opt_offset] + set boundaries [dict get $binfo boundaries] + } else { + set boundaries [list] + foreach b $opt_boundaries { + if {$chunkstart <= $b && $chunkend >= $b} { + lappend boundaries [expr {$b + $opt_offset}] + } + } + } + + + if {![llength $boundaries]} { + return "No boundaries found between $chunkstart and $chunkend for chunksize $chunksize (when offset $opt_offset)" + } + if {$opt_showconfig} { + set result "chunk range $chunkstart $chunkend line range $minline $maxline linebase $linebase limit $opt_limit\n" + } else { + set result "" + } + set pre_bytes [expr {$opt_displaybytes /2}] + set post_bytes $pre_bytes + set max_bytes [expr {[my chunklen] -1}] + if {$opt_limit > 0} { + set boundaries [lrange $boundaries[unset boundaries] 0 $opt_limit-1] + } + + set i 0 + foreach b $boundaries { + if {$opt_boundaryheader ne ""} { + set j [expr {$i+1}] + append result [string map [list %b% $b %i% $i %j% $j] $opt_boundaryheader] \n + } + set low [expr {max(($b - $pre_bytes),0)}] + set high [expr {min(($b + $post_bytes),$max_bytes)}] + + set lineinfolist [my chunkrange_to_lineinfolist $low $high -show_truncated 1] + set le_map [list \r\n \r \n ] + set result_list [list] + foreach lineinfo $lineinfolist { + set lineidx [dict get $lineinfo lineindex] + + set linenum [expr {$lineidx + $linebase}] + set s [dict get $lineinfo start] + set e [dict get $lineinfo end] + + set boundarymarker "" + set displayidx "" + set linenum_display $linenum + if {$s <= $b && $e >= $b} { + set idx [expr {$b - $s}] ;#index into whole position in whole line - not so useful if we're viewing a small section of a line + set char [string index [my line $lineidx] $idx] + set char_display [string map [list \r \n ] $char] + if {[dict get $lineinfo is_truncated]} { + set tside [dict get $lineinfo truncatedside] + set truncated [dict get $lineinfo truncated] + set tlen [string length $truncated] + if {"left" in $tside} { + set tleft [dict get $lineinfo truncatedleft] + set tleftlen [string length $tleft] + set displayidx [expr {$idx - $tleftlen}] + } elseif {"right" in $tside} { + set displayidx $idx + } + } else { + set displayidx $idx + } + set boundarymarker "'[a+ green bold]$char_display[a]'@$displayidx" + set linenum_display ${linenum_display},$idx + } + + set lhs_status $opt_cmark ;#default + set rhs_status $opt_cmark ;#default + if {[dict get $lineinfo is_truncated]} { + set line [dict get $lineinfo truncated] + set tside [dict get $lineinfo truncatedside] + if {"left" in $tside && "right" in $tside } { + set lhs_status $opt_tmark + set rhs_status $opt_tmark + } elseif {"left" in $tside} { + set lhs_status $opt_tmark + } elseif {"right" in $tside} { + set rhs_status $opt_tmark + } + + + } else { + set line [my line $lineidx] + } + if {$displayidx ne ""} { + set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] + } + set displayline [string map $le_map $line] + lappend result_list [list $linenum_display $boundarymarker $lhs_status $displayline $rhs_status] + } + set title_linenum "LNUM" + set linenums [lsearch -index 0 -all -inline -subindices $result_list *] + set markers [lsearch -index 1 -all -inline -subindices $result_list *] + set lines [lsearch -index 3 -all -inline -subindices $result_list *] + set title_marker "" + set title_line "Line" + #todo - use punk::char for unicode support of wide chars etc? + set widest_linenum [tcl::mathfunc::max {*}[lmap v [concat [list $title_linenum] $linenums] {string length $v}]] + set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [ansistrip $v]}]] + set widest_status [expr {max([string length $opt_cmark], [string length $opt_tmark])}] + set widest_line [tcl::mathfunc::max {*}[lmap v [concat [list $title_line] $lines] {string length $v}]] + foreach row $result_list { + lassign $row linenum marker lhs_status line rhs_status + append result [format " %-*s " $widest_linenum $linenum] + append result [format " %-*s " $widest_marker $marker] + append result [format " %-*s " $widest_status $lhs_status] + append result [format " %-*s " $widest_line $line] + append result [format " %-*s " $widest_status $rhs_status] \n + } + incr i + } + set ::punk::fileline::ansi::enabled $pre_ansi_enabled + return $result + } + method linecount {} { + #*** !doctools + #[call class::textinfo [method linecount]] + #[para] Number of lines in the raw data of the file, counted as per the policy in effect + return [llength $o_payloadlist] + } + + + method line {lineindex} { + #*** !doctools + #[call class::textinfo [method line] [arg lineindex]] + #[para]Reconstructs and returns the raw line using the payload and per-line stored line-ending metadata + #[para]A 'line' may be returned without a line-ending if the unerlying chunk had trailing data without a line-ending (or the chunk was loaded under a non-standard -policy setting) + #[para]Whilst such data may not conform to definitions (e.g POSIX) of the terms 'textfile' and 'line' - it is useful here to represent it as a line with metadata le set to "none" + #[para]To return just the data which might more commonly be needed for dealing with lines, use the [method linepayload] method - which returns the line data minus line-ending + + lassign [my numeric_linerange $lineindex 0] lineindex + + set le [dict get $o_linemap $lineindex le] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] $le] + return [lindex $o_payloadlist $lineindex]$le_chars + } + method chunk_find_glob {globsearch args} { + #todo - use linepayload_find_glob when -ignore_lineendings is 0 - but check truncations for 1st and last line + error "unimplemented" + } + method linepayload_find_glob {globsearch args} { + #*** !doctools + #[call class::textinfo [method linepayload_find_glob] [arg globsearch] [opt {option value...}]] + #[para]Return a lineinfolist (see [method lineinfo] and [method lineinfolist]) of lines where payload matches the [arg globsearch] string + #[para]To limit the returned results use the -limit n option - where -limit 0 means return all matches. + #[para]For example: [method linepayload_find_glob] "*test*" -limit 1 + #[para]The result is always a list of lineinfo dictionaries even if one item is returned + #[para] -limitfrom can be start|end + #[para]The order of results is always the order as they occur in the data - even if -limitfrom end is specified. + #[para]-limitfrom end means that only the last -limit items are returned + #[para]Note that as glob accepts [lb]chars[rb]] to mean match any character in the set given by chars, searching for literal square brackets should be done by escaping the bracket with a backslash + #[para]This is true even if only a single square bracket is being searched for. e.g {*[lb]file*} will not find the word file followed by a left square-bracket - even though the search didn't close the square brackets. + #[para]In the above case - the literal search should be {*\[lb]file*} + + set opts [dict create\ + -limit 0\ + -strategy 1\ + -start 0\ + -end end\ + -limitfrom start\ + ] + foreach {k v} $args { + switch -- $k { + -limit - -strategy - -start - -end - -limitfrom { + dict set opts $k $v + } + default { + error "linepayload_find_glob unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_limit [dict get $opts -limit] + if {![string is integer -strict $opt_limit] || $opt_limit < 0} { + error "linepayload_find_glob -limit must be positive integer" + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_strategy [dict get $opts -strategy] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_start [dict get $opts -start] + set opt_start [expr {$opt_start}] + if {$opt_start != 0} {error "-start unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_end [dict get $opts -end] + set max_line_index [expr {[llength $o_payloadlist]-1}] + if {$opt_end eq "end"} { + set opt_end $max_line_index + } + #TODO + if {$opt_end < $max_line_index} {error "-end less than max_line_index unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_limitfrom [dict get $opts -limitfrom] + #-limitfrom start|end only + #TODO + if {$opt_limitfrom ne "start"} {error "-limitfrom unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + set lineinfolist [list] + + if {$opt_limit == 1} { + set idx [lsearch -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + if {$idx >=0} { + set i [expr {$opt_start + $idx}] + lappend lineinfolist [list lineindex $i [dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } elseif {$opt_limit == 0} { + set indices [lsearch -all -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + foreach irel $indices { + set i [expr {$opt_start + $irel}] + lappend lineinfolist [list lineindex $i [dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } else { + #todo - auto-strategy based on limit vs number of lines + if {$opt_strategy == 0} { + set posn 0 + for {set r 0} {$r < $opt_limit} {incr r} { + set n [lsearch [lrange $o_payloadlist $posn+$opt_start end] $globsearch] + if {$n >=0} { + set irel [expr {$posn + $n}] + set i [expr {$irel + $opt_start}] + lappend lineinfolist [list lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + set posn [expr {$irel+1}] + } + } + } else { + set indices [lsearch -all -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + set limited [lrange $indices 0 $opt_limit-1] + foreach irel $limited { + set i [expr {$opt_start + $irel}] + lappend lineinfolist [list lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } + } + return $lineinfolist + } + method linepayload {lineindex} { + #*** !doctools + #[call class::textinfo [method linepayload] [arg lineindex]] + #[para]Return the text of the line indicated by the zero-based lineindex + #[para]The line-ending is not returned in the data - but is still stored against this lineindex + #[para]Line Metadata such as the line-ending for a particular line and the byte/character range it occupies within the chunk can be retrieved with the [method linemeta] method + #[para]To retrieve both the line text and metadata in a single call the [method lineinfo] method can be used + #[para]To retrieve an entire line including line-ending use the [method line] method. + lassign [my numeric_linerange $lineindex 0] lineindex + return [lindex $o_payloadlist $lineindex] + } + method linepayloads {startindex endindex} { + #*** !doctools + #[call class::textinfo [method linepayloads] [arg startindex] [arg endindex]] + #[para]Return a list of just the payloads in the specified linindex range, with no metadata. + return [lrange $o_payloadlist $startindex $endindex] + } + method linemeta {lineindex} { + #*** !doctools + #[call class::textinfo [method linemeta] [arg lineindex]] + #[para]Return a dict of the metadata for the line indicated by the zero-based lineindex + #[para]Keys returned include + #[list_begin itemized] + #[item] le + #[para] A string representing the type of line-ending: crlf|lf|none + #[item] linelen + #[para] The number of characters/bytes in the whole line including line-ending if any + #[item] payloadlen + #[para] The number of character/bytes in the line excluding line-ending + #[item] start + #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line begins + #[item] end + #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line ends + #[para] This end-point corresponds to the last character of the line-ending if any - not necessarily the last character of the line's payload + #[list_end] + lassign [my numeric_linerange $lineindex 0] lineindex + dict get $o_linemap $lineindex + } + method lineinfo {lineindex} { + #*** !doctools + #[call class::textinfo [method lineinfo] [arg lineindex]] + #[para]Return a dict of the metadata and text for the line indicated by the zero-based lineindex + #[para]This returns the same info as the [method linemeta] with an added key of 'payload' which is the text of the line without line-ending. + #[para]The 'payload' value is the same as is returned from the [method linepayload] method. + lassign [my numeric_linerange $lineindex 0] lineindex ;#convert lineindex to canonical number e.g 1_000 -> 1000 end -> highest index + return [dict create lineindex $lineindex {*}[dict get $o_linemap $lineindex] payload [lindex $o_payloadlist $lineindex]] + } + method lineinfolist {startidx endidx} { + #*** !doctools + #[call class::textinfo [method lineinfolist] [arg startidx] [arg endidx]] + #[para]Returns list of lineinfo dicts for each line in line index range startidx to endidx + lassign [my numeric_linerange $startidx $endidx] startidx endidx + set chunkstart [dict get $o_linemap $startidx start] + set chunkend [dict get $o_linemap $endidx end] + set line_list [my chunkrange_to_lineinfolist $chunkstart $chunkend] ;# assertion - no need to view truncations as we've picked start and end of complete lines + #verify sanity + set l_start [lindex $line_list 0] + if {[set idx_start [dict get $l_start lineindex]] ne $startidx} { + error "lineinfolist first lineindex $idx_start doesn't match startidx $startidx" + } + set l_end [lindex $line_list end] + if {[set idx_end [dict get $l_end lineindex]] ne $endidx} { + error "lineinfolist last lineindex $idx_end doesn't match endidx $endidx" + } + return $line_list + } + + method linerange_to_chunkrange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linerange_to_chunkrange] [arg startidx] [arg endidx]] + + lassign [my numeric_linerange $startidx $endidx] startidx endidx + #inclusive range + return [list [dict get $o_linemap $startidx start] [dict get $o_linemap $endidx end]] + } + method linerange_to_chunk {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linerange_to_chunk] [arg startidx] [arg endidx]] + set chunkrange [my linerange_to_chunkrange $startidx $endidx] + return [string range $o_chunk [lindex $chunkrange 0] [lindex $chunkrange 1]] + } + method lines {startidx endidx} { + #*** !doctools + #[call class::textinfo [method lines] [arg startidx] [arg endidx]] + lassign [my numeric_linerange $startidx $endidx] startidx endidx + set linelist [list] + set le_map [dict create lf \n crlf \r\n none ""] + for {set i $startidx} {$i <= $endidx} {incr i} { + lappend linelist "[lindex $o_payloadlist $i][dict get $le_map [dict get $o_linemap $i le]]" + } + return $linelist + } + method linepayloads {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linepayloads] [arg startidx] [arg endidx]] + return [lrange $o_payloadlist $startidx $endidx] + } + method chunkrange_to_linerange {chunkstart chunkend} { + #*** !doctools + #[call class::textinfo [method chunkrange_to_linerange] [arg chunkstart] [arg chunkend]] + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + + set linestart -1 + for {set i 0} {$i < [llength $o_payloadlist]} {incr i} { + if {($chunkstart >= [dict get $o_linemap $i start]) && ($chunkstart <= [dict get $o_linemap $i end])} { + set linestart $i + break + } + } + if {$linestart == -1} { + error "Line with range in chunk spanning start index $chunkstart not found" + } + set lineend -1 + for {set i [expr {[llength $o_payloadlist] -1}]} {$i >=0} {incr i -1} { + if {($chunkend >= [dict get $o_linemap $i start]) && ($chunkend <= [dict get $o_linemap $i end])} { + set lineend $i + break + } + } + if {$lineend == -1} { + error "Line with range spanning end index $chunkend not found" + } + return [list $linestart $lineend] + } + method chunkrange_to_lineinfolist {chunkstart chunkend args} { + #*** !doctools + #[call class::textinfo [method chunkrange_to_lineinfolist] [arg chunkstart] [arg chunkend] [opt {option value...}]] + #[para]Return a list of dicts each with structure like the result of the [method lineinfo] method - but possibly with extra keys for truncation information if -show_truncated 1 is supplied + #[para]The truncation key in a lineinfo dict may be returned for first and/or last line in the resulting list. + #[para]truncation shows the shortened (missing bytes on left and/or right side) part of the entire line (potentially including line-ending or even partial line-ending) + #[para]Note that this truncation info is only in the return value of this method - and will not be reflected in [method lineinfo] queries to the main chunk. + + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + set defaults [dict create\ + -show_truncated 0\ + ] + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "chunkrange_to_lines error: unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- + set opt_show_truncated [dict get $opts -show_truncated] + # -- --- --- --- --- --- --- --- + + set infolist [list] + set linerange [my chunkrange_to_linerange $chunkstart $chunkend] + lassign $linerange start_lineindex end_lineindex + + #if -show_truncated + #return extra keys for first and last items (which may be the same item if chunkrange is entirely within a line) + #add is_truncated 0|1 to all lines + #Even if the start/end line is not fully within the chunkrange ie truncated - the 'payload' key will contain the original untruncated data + ########################### + # first line may have payload tail truncated - or just linefeed, or even a split linefeed + ########################### + set first [dict create lineindex $start_lineindex {*}[dict get $o_linemap $start_lineindex] payload [lindex $o_payloadlist $start_lineindex]] + set start_info [dict get $o_linemap $start_lineindex] + + + if {$chunkstart > [dict get $start_info start]} { + dict set first is_truncated 1 + dict set first truncatedside [list left] ;#truncatedside is a list which may have 'right' added if last line is same as first line + } else { + dict set first is_truncated 0 + } + + if {$opt_show_truncated} { + #line1 + if {$chunkstart > [dict get $start_info start]} { + #there is lhs truncation + set payload [lindex $o_payloadlist $start_lineindex] + set line_start [dict get $start_info start] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] [dict get $start_info le]] + set payload_and_le "${payload}${le_chars}" + set split [expr {$chunkstart - $line_start}] + set truncated [string range $payload_and_le $split end] + set lhs [string range $payload_and_le 0 $split-1] + + dict set first truncated $truncated + dict set first truncatedleft $lhs + } + } + ########################### + + ########################### + # middle lines if any - no truncation + ########################### + #difference in indexes of 1 would only mean 2 items to return + set middle_list [list] + if {($end_lineindex - $start_lineindex) > 1} { + for {set i [expr {$start_lineindex +1}]} {$i <= [expr {$end_lineindex -1}] } {incr i} { + #lineindex is key into main list + lappend middle_list [dict create lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i] is_truncated 0] + } + } + ########################### + + ########################### + # tail line may have beginning or all of payload truncated - linefeed may be split if crlf + # may be same line as first line - in which case truncation at beginning as well + if {$end_lineindex == $start_lineindex} { + #same record + set end_info $start_info + + + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation + if {[dict get $first is_truncated]} { + dict set first truncatedside [list left right] + } else { + dict set first is_truncated 1 + dict set first truncatedside [list right] + } + } + + if {$opt_show_truncated} { + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation and we need to return the splits + #do rhs truncation - possibly in addition to existing lhs truncation + # ... + set payload [lindex $o_payloadlist $end_lineindex] + set line_start [dict get $end_info start] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] [dict get $end_info le]] + set payload_and_le "${payload}${le_chars}" + set split [expr {$chunkend - $line_start}] + set truncated [string range $payload_and_le 0 $split] + set rhs [string range $payload_and_le $split+1 end] + dict set first truncatedright $rhs + if {"left" ni [dict get $first truncatedside]} { + #rhs truncation only + puts "payload_and_le: $payload_and_le" + puts "LENGTH: [string length $payload_and_le]" + #--- + #--- + dict set first truncated $truncated + dict set first truncatedside [list right] + } else { + #truncated on both sides + set lhslen [string length [dict get $first truncatedleft]] + #re-truncate the truncation to reapply the original lhs truncation + set truncated [string range $truncated $lhslen end] + dict set first truncated $truncated + } + } + } + #no middle or last to append + lappend infolist $first + } else { + set last [dict create lineindex $end_lineindex {*}[dict get $o_linemap $end_lineindex] payload [lindex $o_payloadlist $end_lineindex]] + set end_info [dict get $o_linemap $end_lineindex] + + + if {$chunkend < [dict get $end_info end]} { + dict set last is_truncated 1 + dict set last truncatedside [list right] + } else { + dict set last is_truncated 0 + } + + if {$opt_show_truncated} { + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation - and last line in range is a different line to first one + set payload [lindex $o_payloadlist $end_lineindex] + set line_start [dict get $end_info start] + set line_end [dict get $end_info end] + set le [dict get $end_info le] + set le_size [dict get {lf 1 crlf 2 none 0} $le] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] $le] + set payload_and_le "${payload}${le_chars}" + + set split [expr {$chunkend - $line_start}] + set truncated [string range $payload_and_le 0 $split] + set rhs [string range $payload_and_le $split+1 end] + + dict set last truncated $truncated + dict set last truncatedright $rhs + #this has the effect that truncating the rhs by 1 can result in truncated being larger than original payload for crlf lines - as payload now sees the cr + #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' + } + } + + + lappend infolist $first + if {[llength $middle_list]} { + lappend infolist {*}$middle_list + } + lappend infolist $last + } + ########################### + #assertion all records have is_truncated key. + #assertion if is_truncated == 1 truncatedside should contain a list of either left, right or both left and right + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. + return $infolist + } + + #need to check truncations so that any split \r\n is counted precisely todo + method chunk_le_counts {chunkstart chunkend} { + set infolines [my chunkrange_to_lineinfolist $chunkstart $chunkend -show_truncated 1] + set lf_count 0 + set crlf_count 0 + set none_count 0 + foreach d $infolines { + set le [dict get $d le] + if {$le eq "lf"} { + incr lf_count + } elseif {$le eq "crlf"} { + incr crlf_count + } else { + incr none_count + } + } + #even without split crlf - this can overcount by counting the lf or crlf in a line which had an ending not in the chunk range specified + + #check first and last infoline for truncations + #Also check if the truncation is directly between an crlf + #both an lhs split and an rhs split could land between cr and lf + #to be precise - we should presumably count the part within our chunk as either a none for cr or an lf + #This means a caller counting chunk by chunk using this method will sometimes get the wrong answer depending on where crlfs lie relative to their chosen chunk size + #This is presumably ok - as it should be a well known thing to watch out for. + #If we're only receiving chunk by chunk we can't reliably detect splits vs lone s in the data + #There are surely more efficient ways for a caller to count line-endings in the way that makes sense for them + #but we should makes things as easy as possible for users of this line/chunk structure anyway. + + set first [lindex $infolines 0] + if {[dict get $first is_truncated]} { + #could be the only line - and truncated at one or both ends. + #both a left and a right truncation could split a crlf + + } + set last [lindex $infolines end] + if {[dict get $first lineindex] != [dict get $last lineindex]} { + #only need to process last if it is a different line + #if so - then split can only be left side + + } + + + return [dict create lf $lf_count crlf $crlf_count unterminated $none_count warning line_ending_splits_unimplemented] + } + + #todo - test last line and merge as necessary with first line from new chunk - generate line data only for appended chunk + method append_chunk {rawchunk} { + error "sorry - unimplemented" + } + + method numeric_linerange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method numeric_linerange] [arg startidx] [arg endidx]] + #[para]A helper to return any Tcl-style end end-x values given to startidx or endidx; converted to their specific values based on the current state of the underlying line data + #[para]This is used internally by API functions such as [method line] to enable it to accept more expressive indices + return [my normalize_indices $startidx $endidx [expr {[dict size $o_linemap]-1}]] + } + method numeric_chunkrange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method numeric_chunkrange] [arg startidx] [arg endidx]] + #[para]A helper to return any Tcl-style end end-x entries supplied to startidx or endidx; converted to their specific values based on the current state of the underlying chunk data + return [my normalize_indices $startidx $endidx [expr {[string length $o_chunk]-1}]] + } + method normalize_indices {startidx endidx max} { + #*** !doctools + #[call class::textinfo [method normalize_indices] [arg startidx] [arg endidx] [arg max]] + #[para]A utility to convert some of the of Tcl-style list-index expressions such as end, end-1 etc to valid indices in the range 0 to the supplied max + #[para]Basic addition and subtraction expressions such as 4-1 5+2 are accepted + #[para]startidx higher than endidx is allowed + #[para]Unlike Tcl's index expressions - we raise an error if the calculated index is out of bounds 0 to max + set original_startidx $startidx + set original_endidx $endidx + set startidx [string map [list _ ""] $startidx] ;#don't barf on Tcl 8.7+ underscores in numbers - we can't just use expr because it will not handle end-x + set endidx [string map [list _ ""] $endidx] + if {![string is digit -strict "$startidx$endidx"]} { + foreach whichvar [list start end] { + upvar 0 ${whichvar}idx index + if {![string is digit -strict $index]} { + switch -glob -- $index { + end { + set index $max + } + "*-*" { + #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions + lassign [split $index -] A B + if {$A eq "end"} { + set index [expr {$max - $B}] + } else { + set index [expr {$A - $B}] + } + } + "*+*" { + lassign [split $index +] A B + if {$A eq "end"} { + #review - this will just result in out of bounds error in final test - as desired + #By calculating here - we will see the result in the error message - but it's probably not particularly useful - as we don't really need end+ support at all. + set index [expr {$max + $B}] + } else { + set index [expr {$A + $B}] + } + } + default { + #May be something like +2 or -0 which braced expr can hanle + #we would like to avoid unbraced expr here - as we're potentially dealing with ranges that may come from external sources. + if {[catch {expr {$index}} index]} { + #could be end+x - but we don't want out of bounds to be valid + #set it to something that the final bounds expr test can deal with + set index Inf + } + } + } + } + } + } + #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. + #show the supplied index and what it was mapped to in the error message. + if {$startidx < 0 || $startidx > $max} { + error "Bad start index '$original_startidx'. $startidx out of bounds 0 - $max" + } + if {$endidx < 0 || $endidx > $max} { + error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" + } + return [list $startidx $endidx] + } + + method regenerate_lines {args} { + #*** !doctools + #[call class::textinfo [method regenerate_lines]] + #[para]generate a list of lines from the current state of the stored raw data chunk and keep a map of line-endings indexed by lineindex + #[para]This is called automatically by the Constructor during object creation + #[para]It is exposed in the API experimentally - as chunk and line manipulation functions are considered. + #[para]TODO - review whether such manual control will be necessary/desirable + + #we don't store the actual line-endings as characters (for better layout of debug/display of data) - instead we store names lf|crlf|none + + # first split on lf - then crlf. As we've replaced with single substution chars - the order doesn't matter. + set o_payloadlist [list] + set o_linemap [dict create] + set crlf_replace [list \r\n $o_CRLF_C \n $o_LF_C] + set normalised_data [string map $crlf_replace $o_chunk] + + set lf_lines [split $normalised_data $o_LF_C] + + set idx 0 + set lf_count 0 + set crlf_count 0 + set filedata_offset 0 + set i 0 + set imax [expr {[llength $lf_lines]-1}] + foreach lfln $lf_lines { + set crlf_parts [split $lfln $o_CRLF_C] + if {[llength $crlf_parts] <= 1} { + #no crlf + set payloadlen [string length $lfln] + set le_size 1 + set le lf + if {$i == $imax} { + #no more lf segments - and no crlfs + if {$payloadlen > 0} { + #last line in split has chars - therefore there was no trailing line-ending + set le_size 0 + set le none + } else { + #empty space after last line-ending + #not really a line - we get here from splitting on our lf-replacement char + #An editor might display this pseudo-line with a line number - but we won't treat it as one here + break + } + } + lappend o_payloadlist $lfln + set linelen [expr {$payloadlen + $le_size}] + #we include line-ending in byte count for a line. + dict set o_linemap $idx [list le $le linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr lf_count + incr idx + } else { + foreach crlfpart [lrange $crlf_parts 0 end-1] { + lappend o_payloadlist $crlfpart + set payloadlen [string length $crlfpart] + set linelen [expr {$payloadlen + 2}] + dict set o_linemap $idx [list le crlf linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr crlf_count + incr idx + } + set lfpart [lindex $crlf_parts end] + set payloadlen [string length $lfpart] + if {$i == $imax} { + #no more lf segments - but we did find crlf in last (or perhaps only) lf line + #last element in our split has no le + if {$payloadlen > 0} { + set le_size 0 + set le none + } else { + #set le_size 2 + #set le crlf + break + } + } else { + #more lf segments to come + set le_size 1 + set le lf + } + + lappend o_payloadlist $lfpart + set linelen [expr {$payloadlen + $le_size}] + dict set o_linemap $idx [list le $le linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr lf_count + incr idx + } + incr i + #incr filedata_offset ;#move up 1 so start entry for next line is greater than end entry for previous line + } + set le_count [expr {$lf_count + $crlf_count}] + if {$le_count != [llength $o_payloadlist]} { + puts stderr "fileline::class::textinfo warning. regenerate_lines lf_count: $lf_count + crlf_count: $crlf_count does not equal length of lines stored: [llength $o_payloadlist]" + } + + } + method regenerate_chunk {} { + #o_payloadlist + #o_linemap + set oldsize [string length $o_chunk] + set newchunk "" + #review - what was the intention here? + puts stderr "regenerate_chunk -warning code incomplete" + dict for {idx lineinfo} $o_linemap { + #??? + #set + + } + + return [list newsize [string length $newchunk] oldsize $oldsize] + } + + + #*** !doctools + #[list_end] + } + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline { + namespace export * + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::fileline}] + #[para] Core API functions for punk::fileline + #[list_begin definitions] + + punk::args::define { + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ + "return: textinfo object instance" + -file -default {} -type existingfile + -translation -default iso8859-1 + -encoding -default "\uFFFF" + -includebom -default 0 + @values -min 0 -max 1 + } + proc get_textinfo {args} { + #*** !doctools + #[call get_textinfo [opt {option value...}] [opt datachunk]] + #[para]Returns textinfo object instance representing data in string datachunk or if -file filename supplied - data loaded from a file + #[para]The encoding used is as specified in the -encoding option - or from the Byte Order Mark (bom) at the beginning of the data + #[para]For Tcl 8.6 - encodings such as utf-16le may not be available - so the bytes are swapped appropriately depending on the platform byteOrder and encoding 'unicode' is used. + #[para]encoding defaults to utf-8 if no -encoding specified and no BOM was found + #[para]Whether -encoding was specified or not - by default the BOM characters are not retained in the line-data + #[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data + #[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered. + #[para] e.g utf-8,utf-16be, utf-16le, utf-32be, utf32-le, SCSU, BOCU-1,GB18030, UTF-EBCDIC, utf-1, utf-7 + #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is. + #[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::parse $args withid ::punk::fileline::get_textinfo]] leaders opts values + # -- --- --- --- + set opt_file [dict get $opts -file] + set opt_translation [dict get $opts -translation] + set opt_encoding [dict get $opts -encoding] + set opt_includebom [dict get $opts -includebom] + # -- --- --- --- + + 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]} { + puts stderr "Ignoring trailing argument [string length [lindex $values 0]] bytes. Not used when -file is specified" + } + } else { + set rawchunk [lindex $values 0] + } + set rawlen [string length $rawchunk] + #examine first 4 bytes for possible BOM + #big-endian BOMs + # ----------------------------------- + #EFBBBF - utf-8 reliabletxt + #FEFF - utf-16be reliabletxt + #FFFE - utf-16le reliabletxt + #0000FEFF - utf-32be reliabletxt + #FFFE0000 - utf-32le + #0000FFFE - utf-32be(2143) non-standard! (not supported) + #FEFF0000 - utf-32le(3412) non-standard! (not supported - will detect as utf-16be) + #2B2F76 - utf-7 (not supported) + #F7644C - utf-1 (not supported) + #DD736673 - UTF-EBCDIC (not supported) + #0EFEFF - SCSU (not supported) + #FBEE28 - BOCU-1 Binary Ordered Compression for Unicode (mime-compatible) - (not supported - fall back to utf-8) + #84319533 - GB18030 - Chinese gov standard (fall back to cp936 with warning if no encoding name) + # ----------------------------------- + + set first32 [string range $rawchunk 0 3] + #scan using capital H for big-endian order + set first32_be [binary scan $first32 H* maybe_bom] ;#we use H* instead of H8 for 8 nibbles (4 bytes) - because our first32 may contain less than 4 bytes - in which case we won't match + set bomid "" + set bomenc "" + set is_reliabletxt 0 ;#see http://reliabletxt.com - only utf-8 with bom, utf-16be, utf-16le, utf-32be supported as at 2024 + set startdata 0 + #todo switch -glob + if {[string match "efbbbf*" $maybe_bom]} { + set bomid utf-8 + set bomenc utf-8 + set is_reliabletxt 1 + set startdata 3 + } elseif {$maybe_bom eq "0000feff"} { + set bomid utf-32be + set bomenc utf-32be + set is_reliabletxt 1 + set startdata 4 + } elseif {$maybe_bom eq "fffe0000"} { + #Technically ambiguous - could be utf-16le bom followed by utf-16 null character (2 byte null) + puts stderr "WARNING - ambiguous BOM fffe0000 found. Treating as utf-32le - but could be utf-16le - consider manually setting -encoding or converting data to another encoding." + set bomid utf-32le + set bomenc utf-32le + set startdata 4 + } elseif {[string match "feff*" $maybe_bom]} { + set bomid utf-16be + set bomenc utf-16be + set is_reliabletxt 1 + set startdata 2 + } elseif {[string match "fffe*" $maybe_bom]} { + set bomid utf-16le + set bomenc utf-16le + set is_reliabletxt 1 + set startdata 2 + } elseif {$maybe_bom eq "0efeff"} { + set bomid scsu + set bomenc "binary" + set startdata 3 + } elseif {$maybe_bom eq "fbee28"} { + set bomid bocu-1 + 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" + 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? + } + set bomid gb18030 + set startdata 4 + } elseif {$maybe_bom eq "f7644c"} { + puts stderr "WARNING utf-1 BOM F7644C found - not supported. Falling back to binary" + set bomid utf-1 + set bomenc binary + set startdata 3 + } elseif {[string match "2b2f76*" $maybe_bom]} { + puts stderr "WARNING utf-7 BOM 2b2f76 found - not supported. Falling back to binary and leaving BOM in data!" + #review - work out how to strip bom - last 2 bits of 4th byte belong to following character + set bomid utf-7 + set bomenc binary + set startdata 0 + } + + #todo - check xml encoding attribute / html content-type + #todo - a separate chardet (https://chardet.readthedocs.io/ ) or mozilla like mechanism that can be manually called to autodetect character encoding + #This should be an explicit operation - not automatially done here unless we provide a flag for it. + + + if {$opt_includebom} { + set startdata 0 + } + + if {$opt_encoding eq "\uFFFF"} { + if {$bomenc ne "" && $bomenc ne "binary"} { + if {[package vcompare [package provide Tcl] 8.7] < 0} { + #tcl 8.6 has unicode encoding but not utf-16le etc + if {$bomenc ni [encoding names]} { + if {$bomenc eq "utf-16le"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } else { + set datachunk [encoding convertfrom unicode [system::wordswap16 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 16)" + } + } elseif {$bomenc eq "utf-16be"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [system::wordswap16 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 16)" + } else { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } + } elseif {$bomenc eq "utf-32le"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } else { + set datachunk [encoding convertfrom unicode [system::wordswap32 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 32)" + } + } elseif {$bomenc eq "utf-32be"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [system::wordswap32 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 32)" + } else { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } + } else { + error "Encoding $bomenc unavailable in this version of Tcl" + } + } else { + set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] + set encoding_selected $bomenc + } + } else { + #tcl 8.7 plus has utf-16le etc + set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] + set encoding_selected $bomenc + } + } else { + #!? + if {$bomenc eq "binary"} { + set datachunk [string range $rawchunk $startdata end] + set encoding_selected binary + } else { + set datachunk [encoding convertfrom utf-8 [string range $rawchunk $startdata end]] + set encoding_selected utf-8 + } + } + } else { + #manually specified encoding overrides bom - but still remove bom-chars REVIEW + #e.g we still want bom info - but specify binary encoding + + if {$opt_encoding eq "binary"} { + set datachunk [string range $rawchunk $startdata end] + } else { + set datachunk [encoding convertfrom $opt_encoding [string range $rawchunk $startdata end]] + } + set encoding_selected $opt_encoding + } + + set textobj [class::textinfo new $datachunk] + if {$bomid ne ""} { + $textobj set_bomid $bomid + } + + + + + set summary "" + append summary "Bytes loaded : $rawlen" \n + append summary "BOM ID : $bomid" \n + append summary "Encoding selected : $encoding_selected" \n + append summary "Characters : [$textobj chunklen]" \n + append summary "Lines recognised : [$textobj linecount]" \n + set leinfo [$textobj chunk_le_counts 0 end] + append summary "crlf endings (windows) : [dict get $leinfo crlf]" \n + append summary "lf endings (unix) : [dict get $leinfo lf]" \n + append summary "unterminated lines : [dict get $leinfo unterminated]" \n + puts stdout $summary + return $textobj + } + + proc file_boundary_display {filename startbyte endbyte chunksize args} { + set fd [open $filename r] ;#use default error if file not readable + chan configure $fd -translation binary + set rawfiledata [read $fd] + close $fd + set textobj [class::textinfo new $rawfiledata] + set result [$textobj chunk_boundary_display $startbyte $endbyte $chunksize {*}$args] + $textobj destroy + return $result + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline::lib { + namespace export * + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::fileline::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + + proc range_spans_chunk_boundaries {start end chunksize args} { + #*** !doctools + #[call [fun lib::range_spans_chunk_boundaries] [arg start] [arg end] [arg chunksize]] + #[para]Takes start and end offset, generally representing bytes or character indices, and computes a list of boundaries at multiples of the chunksize that are spanned by the start and end range. + #[list_begin arguments] + # [arg_def integer start] + # [para] zero-based start index of range + # [arg_def integer end] + # [para] zero-based end index of range + # [arg_def integer chunksize] + # [para] Number of bytes/characters in chunk - must be positive and > 0 + #[list_end] + #[para]returns a dict with the keys is_span and boundaries + #[para]is_span 0|1 indicates if the range specified spans a boundary of chunksize + #[para]boundaries contains a list of the spanned boundaries - which are always multiples of the chunksize + #[para]e.g + #[example_begin] + # range_spans_chunk_boundaries 10 1750 512 + # is_span 1 boundaries {512 1024 1536} + #[example_end] + #[para]The -offset option + #[example_begin] + # range_spans_chunk_boundaries 10 1750 512 -offset 2 + # is_span 1 boundaries {514 1026 1538} + #[example_end] + #[para] This function automatically uses lseq (if Tcl >= 8.7) when number of boundaries spanned is approximately greater than 75 + if {[catch {package require Tcl 8.7-}]} { + #only one implementation available for older Tcl + tailcall punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize {*}$args + } + if {$chunksize < 1} { + error "range_spans_chunk_boundaries chunksize must be >= 1" + } + + if {(abs($end - $start) / $chunksize) < 75} { + tailcall punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize {*}$args + } else { + tailcall punk::fileline::system::_range_spans_chunk_boundaries_lseq $start $end $chunksize {*}$args + } + } + + proc range_boundaries {start end chunksizes args} { + set argd [punk::args::parse $args withdef { + -offset -default 0 + }] + lassign [dict values $argd] leaders opts remainingargs + + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::fileline::system { + #*** !doctools + #[subsection {Namespace punk::fileline::system}] + #[para] Internal functions that are not part of the API + + proc wordswap16 {data} { + #scan in one endianness - format in the other. Whether we scan le/be first doesn't matter as long as we format using the opposite endianness + binary scan $data s* elements ;#scan little endian + return [binary format S* $elements] ;#format big endian + } + proc wordswap32 {data} { + binary scan $data i* elements + return [binary format I* $elements] + } + + proc scan32bit_be {i32} { + if {[binary scan $i32 I x]} { + return $x + } else { + error "couldn't scan $i32" + } + } + + #for 8.7+ using lseq + #much faster when resultant boundary size is large (at least when offset 0) + proc _range_spans_chunk_boundaries_lseq {start end chunksize args} { + if {$chunksize < 1} {error "chunksize must be > 0"} ;#sanitycheck in case called directly + set opts [dict create\ + -offset 0\ + ] + foreach {k v} $args { + switch -- $k { + -offset { + dict set opts $k $v + } + default { + error "unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- + set opt_offset [dict get $opts -offset] + # -- --- --- --- + + set smod [expr {$start % $chunksize}] + if {$smod != 0} { + set start [expr {$start + ($chunksize - $smod)}] + if {$start > $end} { + return [list is_span 0 boundaries {}] + } + } + set boundaries [lseq $start to $end $chunksize] + #offset can be negative + if {$opt_offset} { + if {$opt_offset + [lindex $boundaries end] > $end || $opt_offset + [lindex $boundaries 0] < $start} { + set overflow 1 + } else { + set overflow 0 + } + set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] + if {$overflow} { + #we don't know how many overflowed.. + set inrange [list] + foreach b $boundaries { + if {$b >= $start && $b <= $end} { + lappend inrange $b + } + } + set boundaries $inrange + } + } + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries] + } + + #faster than lseq for small number of resultant boundaries (~< 75) (which is a common use case) + #gets very slow (comparitively) with large resultsets + proc _range_spans_chunk_boundaries_tcl {start end chunksize args} { + if {$chunksize < 1} {error "chunksize must be > 0"} ;#sanitycheck in case called directly + set opts [dict create\ + -offset 0\ + ] + foreach {k v} $args { + switch -- $k { + -offset { + dict set opts $k $v + } + default { + error "unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- + set opt_offset [dict get $opts -offset] + # -- --- --- --- + + set is_span 0 + set smod [expr {$start % $chunksize}] + if {$smod != 0} { + set start [expr {$start + ($chunksize - $smod)}] + } + set boundaries [list] + + #we only need to pre-check the result-range for negative offsets - as our main loop stops before end? + if {$opt_offset < 0} { + #set btrack [expr {$start + $opt_offset}] ;#start back one to make sure we catch the first boundary + set btrack $bstart + set boff [expr {$btrack + $opt_offset}] ;#must be growing even if start and offset are negative - as chunksize is at least 1 + while {$boff < $start} { + incr btrack $chunksize + set boff [expr {$btrack + $opt_offset}] + } + set bstart $btrack + } else { + set bstart $start + } + for {set b $bstart} {[set boff [expr {$b + $opt_offset}]] <= $end} {incr b $chunksize} { + lappend boundaries $boff + } + + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries offset $opt_offset] + } + + proc _range_spans_chunk_boundaries_TIMEIT {start end chunksize {repeat 1}} { + puts "main : [time {punk::fileline::lib::range_spans_chunk_boundaries $start $end $chunksize} $repeat]" + puts "tcl : [time {punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize} $repeat]" + if {![catch {package require Tcl 8.7-}]} { + puts "lseq : [time {punk::fileline::system::_range_spans_chunk_boundaries_lseq $start $end $chunksize} $repeat]" + } + } +} +namespace eval punk::fileline::ansi { + #*** !doctools + #[subsection {Namespace punk::fileline::ansi}] + #[para]These are ansi functions imported from punk::ansi - or no-ops if that package is unavailable + #[para]See [package punk::ansi] for documentation + #[list_begin definitions] + variable enabled 1 + #*** !doctools + #[call [fun ansi::a]] + #[call [fun ansi::a+]] + #[call [fun ansi::ansistrip]] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline::ansi ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::fileline [namespace eval punk::fileline { + variable pkg punk::fileline + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm index 5ec354a7..f6242f76 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm @@ -4201,6 +4201,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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.4.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.4.tm new file mode 100644 index 00000000..a7273752 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.4.tm @@ -0,0 +1,4935 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::lib 0.1.4 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::lib 0 0.1.4] +#[copyright "2024"] +#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk library}] [comment {-- Description at end of page heading --}] +#[require punk::lib] +#[keywords module utility lib] +#[description] +#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. +#[para]The base set includes string and math functions but has no specific theme + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::lib +#[subsection Concepts] +#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. +#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::lib +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +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]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![string match ::* $extension]} { + set extension [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$extension + } + + if {![tcl::namespace::exists $extension]} { + error [list {no such namespace} $extension] + } + + set extension [tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] current]] + + tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] export *] + + while 1 { + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] + if {[tcl::namespace::which $renamed] eq {}} break + } + + rename $routine $renamed + + tcl::namespace::eval $extension [ + list namespace ensemble create -command $routine -unknown [ + list apply {{renamed ensemble routine args} { + list $renamed $routine + }} $renamed + ] + ] + + return $routine + } +} + +# 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} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + set bug true + } else { + 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 + set bug 0 + } else { + set bug [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}" + 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} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr 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] + } +} + +tcl::namespace::eval punk::lib::compat { + #*** !doctools + #[subsection {Namespace punk::lib::compat}] + #[para] compatibility functions for features that may not be available in earlier Tcl versions + #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. + #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. + + #*** !doctools + #[list_begin definitions] + + + + + if {"::lremove" ne [info commands ::lremove]} { + #puts stderr "Warning - no built-in lremove" + interp alias {} lremove {} ::punk::lib::compat::lremove + } + proc lremove {list args} { + #*** !doctools + #[call [fun lremove] [arg list] [opt {index ...}]] + #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove + + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lsearch -all -inline -index 1 -subindices $keep *] + } + #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers + proc lremove2 {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lmap v $keep {lindex $v 1}] + } + #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 + + if {![info exists ::auto_index(readFile)]} { + if {[info commands ::readFile] eq ""} { + proc ::readFile {filename {mode text}} { + #readFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + + # Read the file + set f [open $filename [dict get {text r binary rb} $mode]] + try { + return [read $f] + } finally { + close $f + } + } + } + } + if {![info exists ::auto_index(writeFile)]} { + if {[info commands ::writeFile] eq ""} { + proc ::writeFile {args} { + #writeFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + switch [llength $args] { + 2 { + lassign $args filename data + set mode text + } + 3 { + lassign $args filename mode data + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + } + default { + set COMMAND [lindex [info level 0] 0] + return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" + } + } + + # Write the File + set f [open $filename [dict get {text w binary wb} $mode]] + try { + puts -nonewline $f $data + } finally { + close $f + } + } + } + } + + if {"::lpop" ne [info commands ::lpop]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lib::compat::lpop + 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 + #[call [fun lpop] [arg listvar] [opt {index}]] + #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop + upvar $lvar l + if {![llength $args]} { + set args [list end] + } + set v [lindex $l {*}$args] + set newlist $l + + set path [list] + set subl $l + for {set i 0} {$i < [llength $args]} {incr i} { + set idx [lindex $args $i] + if {![llength [lrange $subl $idx $idx]]} { + error "tcl_lpop index \"$idx\" out of range" + } + lappend path [lindex $args $i] + set subl [lindex $l {*}$path] + } + + set sublist_path [lrange $args 0 end-1] + set tailidx [lindex $args end] + if {![llength $sublist_path]} { + #set newlist [lremove $newlist $tailidx] + set newlist [lreplace $newlist $tailidx $tailidx] + } else { + set sublist [lindex $newlist {*}$sublist_path] + #set sublist [lremove $sublist $tailidx] + set sublist [lreplace $sublist $tailidx $tailidx] + lset newlist {*}$sublist_path $sublist + } + #puts "[set l] -> $newlist" + set l $newlist + return $v + } + if {"::ledit" ni [info commands ::ledit]} { + interp alias {} ledit {} ::punk::lib::compat::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 { + -Inf { + #index below lower bound + set pre [list] + set fidx -1 + } + Inf { + #first index position is greater than index of last element in the list + set pre [lrange $l 0 end] + set fidx [llength $l] + } + default { + #set pre [lrange $l 0 $first-1] + set pre [lrange $l 0 $fidx-1] + } + } + set lidx [punk::lib::lindex_resolve [llength $l] $last] + switch -exact -- $lidx { + -Inf { + #index below lower bound + set post [lrange $l 0 end] + } + Inf { + #index above upper bound + set post [list] + } + default { + if {$lidx < $fidx} { + #from ledit man page: + #If last is less than first, then any specified elements will be inserted into the list before the element specified by first with no elements being deleted. + set post [lrange $l $fidx end] + } else { + #set post [lrange $l $last+1 end] + set post [lrange $l $lidx+1 end] + } + } + } + set l [list {*}$pre {*}$args {*}$post] + } + + + #slight isolation - varnames don't leak - but calling context vars can be affected + proc lmaptcl2 {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list ::tcl::info::vars]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result [apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + if {"::lmap" ne [info commands ::lmap]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lmap {} ::punk::lib::compat::lmaptcl + } + #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway + proc lmaptcl {varnames list script} { + set result [list] + set varlist [list] + foreach varname $varnames { + upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc + lappend varlist var_$varname + } + foreach $varlist $list { + lappend result [uplevel 1 $script] + } + return $result + } + + #tcl8.7/9 compatibility for 8.6 + if {[info commands ::tcl::string::insert] eq ""} { + #https://wiki.tcl-lang.org/page/string+insert + # Pure Tcl implementation of [string insert] command. + proc ::tcl::string::insert {string index insertString} { + # Convert end-relative and TIP 176 indexes to simple integers. + if {[regexp -expanded { + ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace + |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace + (?:([+-]) # op, omitted when index is "end" + ([+-]?\d+))? # n, omitted when index is "end" + [\t\n\v\f\r ]*$ # optional whitespace (unless "end") + } $index _ m op n]} { + # Convert first index to an integer. + switch $m { + end {set index [string length $string]} + default {scan $m %d index} + } + + # Add or subtract second index, if provided. + switch $op { + + {set index [expr {$index + $n}]} + - {set index [expr {$index - $n}]} + } + } elseif {![string is integer -strict $index]} { + # Reject invalid indexes. + return -code error "bad index \"$index\": must be\ + integer?\[+-\]integer? or end?\[+-\]integer?" + } + + # Concatenate the pre-insert, insertion, and post-insert strings. + string cat [string range $string 0 [expr {$index - 1}]] $insertString\ + [string range $string $index end] + } + + # Bind [string insert] to [::tcl::string::insert]. + tcl::namespace::ensemble configure string -map [tcl::dict::replace\ + [tcl::namespace::ensemble configure string -map]\ + insert ::tcl::string::insert] + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::lib { + variable PUNKARGS + tcl::namespace::export * + variable has_struct_list + set has_struct_list [expr {![catch {package require struct::list}]}] + variable has_struct_set + set has_struct_set [expr {![catch {package require struct::set}]}] + variable has_punk_ansi + set has_punk_ansi [expr {![catch {package require punk::ansi}]}] + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + 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] + } + + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + + # -- --- + #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists + #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 + #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows + # Review and retest as new versions come out. + # -- --- + proc list_multi_append1 {lvar1 lvar2} { + #clear winner in 2024 + upvar $lvar1 l1 $lvar2 l2 + lappend l1 {*}$l2 + return $l1 + } + proc list_multi_append2 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [list {*}$l1 {*}$l2] + } + proc list_multi_append3 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] + } + #testing e.g + #set l1_reset {a b c} + #set l2 {a b c d e f g} + #set l1 $l1_reset + #time {list_multi_append1 l1 l2} 1000 + #set l1 $l1_reset + #time {list_multi_append2 l1 l2} 1000 + # -- --- + + + proc lswap {lvar a z} { + 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 -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 -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 { + -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 { + -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 ""} { + append errmsg \n $a_msg + } + if {$z_msg ne ""} { + append errmsg \n $z_msg + } + error $errmsg + } + set item2 [lindex $l $z] + lset l $z [lindex $l $a] + lset l $a $item2 + return $l + } + #proc lswap2 {lvar a z} { + # upvar $lvar l + # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] + #} + + proc lswap2 {lvar a z} { + upvar $lvar l + #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] + } + + #an experimental test of swapping vars without intermediate variables + #It's an interesting idea - but probably of little to no practical use + # - the swap_intvars3 version using intermediate var is faster in Tcl + # - This is probably unsurprising - as it's simpler code. + # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. + #proc swap_intvars {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] + #} + #proc swap_intvars2 {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {$_x ^ $_y}] + # set _y [expr {$_x ^ $_y}] + # set _x [expr {$_x ^ $_y}] + #} + #proc swap_intvars3 {swapv1 swapv2} { + # #using intermediate variable + # upvar $swapv1 _x $swapv2 _y + # set z $_x + # set _x $_y + # set _y $z + #} + + #*** !doctools + #[subsection {Namespace punk::lib}] + #[para] Core API functions for punk::lib + #[list_begin definitions] + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + #support minimal set from to + proc range {from to} { + lseq $from $to + } + } else { + #lseq accepts basic expressions e.g 4-2 for both arguments + #e.g we can do lseq 0 [llength $list]-1 + #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. + proc range {from to} { + set to [offset_expr $to] + set from [offset_expr $from] + if {$to > $from} { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + #slower methods. + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from] + #} + #return $L + } elseif {$from > $to} { + set count [expr {$from - $to} + 1] + #1) + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from -1];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from -1] + #} + #return $L + } else { + return [list $from] + } + } + } + + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + 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-] || [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 { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + + + 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 { + #*** !doctools + #[call [fun invoke] [arg command]] + #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode + #[example { + # set script { + # puts stdout {hello on stdout} + # puts stderr {hello on stderr} + # exit 42 + # } + # invoke [list tclsh <<$script] + #}] + + #see https://wiki.tcl-lang.org/page/open + lassign [chan pipe] chanout chanin + lappend command 2>@$chanin + set fh [open |$command] + set stdout [read $fh] + close $chanin + set stderr [read $chanout] + close $chanout + if {[catch {close $fh} cres e]} { + dict with e {} + lassign [set -errorcode] sysmsg pid exit + if {$sysmsg eq {NONE}} { + #output to stderr caused [close] to fail. Do nothing + } elseif {$sysmsg eq {CHILDSTATUS}} { + return [list $stdout $stderr $exit] + } else { + return -options $e $stderr + } + } + return [list $stdout $stderr 0] + } + + proc pdict {args} { + package require punk::args + variable has_punk_ansi + if {!$has_punk_ansi} { + set sep " = " + } else { + #set sep " [a+ Web-seagreen]=[a] " + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " + } + set argspec [string map [list %sep% $sep] { + @id -id ::punk::lib::pdict + @cmd -name pdict -help\ + "Print dict keys,values to channel + The pdict function operates on variable names - passing the value to the showdict function which operates on values + (see also showdict)" + + @opts -any 1 + + #default separator to provide similarity to tcl's parray function + -separator -default "%sep%" + -roottype -default "dict" + -substructure -default {} + -channel -default stdout -help\ + "existing channel - or 'none' to return as string" + + @values -min 1 -max -1 + + dictvar -type string -help "name of variable. Can be a dict, list or array" + + patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + 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 */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segment in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + } + }] + #puts stderr "$argspec" + set argd [punk::args::parse $args withdef $argspec] + + 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 ::tcl::array::exists $dvar]] + if {$isarray} { + 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] + } + dict set opts -keysorttype dictionary + } else { + set dvalue [uplevel 1 [list set $dvar]] + } + showdict {*}$opts $dvalue {*}$patterns + } + + #TODO - much. + #showdict needs to be able to show different branches which share a root path + #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) + # - specify ansi colour per pattern so different branches can be highlighted? + # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc + # - The current version is incomplete but passably usable. + # - Copy proc and attempt rework so we can get back to this as a baseline for functionality + proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) + #set sep " [a+ Web-seagreen]=[a] " + variable has_punk_ansi + if {!$has_punk_ansi} { + set RST "" + set sep " = " + #set sep_mismatch " mismatch " + set sep \u2260 ;# equivalent [punk::ansi::convert_g0 [punk::ansi::g0 |]] (not equal symbol) + } else { + set RST [punk::ansi::a] + set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support + #set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]\u2260$RST " + } + package require punk::pipe + #package require punk ;#we need pipeline pattern matching features + package require textblock + + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + @id -id ::punk::lib::showdict + @cmd -name punk::lib::showdict -help "display dictionary keys and values" + #todo - table tableobject + -return -default "tailtohead" -choices {tailtohead sidebyside} + -channel -default none + -trimright -default 1 -type boolean -help\ + "Trim whitespace off rhs of each line. + This can help prevent a single long line that wraps in terminal from making + every line wrap due to long rhs padding." + -separator -default {%sep%} -help\ + "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help\ + "Separator to use when patterns mismatch" + -roottype -default "dict" -help\ + "list,dict,string" + -ansibase_keys -default "" -help\ + "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -substructure -default {} + -ansibase_values -default "" + -keytemplates -default {\$\{$key\}} -type list -help\ + "list of templates for keys at each level" + -keysorttype -default "none" -choices {none dictionary ascii integer real} + -keysortdirection -default increasing -choices {increasing decreasing} + -debug -default 0 -type boolean -help\ + "When enabled, produces some rudimentary debug output on stderr" + -- -type none -optional 1 + @values -min 1 -max -1 + dictvalue -type list -help\ + "dict or list value" + patterns -default "*" -type string -multiple 1 -help\ + "key or key glob pattern" + }]] + + #for punk::lib - we want to reduce pkg dependencies. + # - so we won't even use the tcllib debug pkg here + set opt_debug [dict get $argd opts -debug] + if {$opt_debug} { + if {[info body debug::showdict] eq ""} { + proc ::punk::lib::debug::showdict {args} { + catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} + } + } + } else { + if {[info body debug::showdict] ne ""} { + proc ::punk::lib::debug::showdict {args} {} + } + } + + set opt_sep [dict get $argd opts -separator] + set opt_mismatch_sep [dict get $argd opts -separator_mismatch] + set opt_keysorttype [dict get $argd opts -keysorttype] + set opt_keysortdirection [dict get $argd opts -keysortdirection] + set opt_trimright [dict get $argd opts -trimright] + set opt_keytemplates [dict get $argd opts -keytemplates] + debug::showdict "keytemplates ---> $opt_keytemplates <---" + set opt_ansibase_keys [dict get $argd opts -ansibase_keys] + set opt_ansibase_values [dict get $argd opts -ansibase_values] + set opt_return [dict get $argd opts -return] + set opt_roottype [dict get $argd opts -roottype] + set opt_structure [dict get $argd opts -substructure] + + set dval [dict get $argd values dictvalue] + set patterns [dict get $argd values patterns] + + set result "" + + #pattern hierarchy + # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest + # * @1 @0,%#,%str - segments + # a b 1 0 %# %str - keys + + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated + set pattern_next_substructure [dict create] + set pattern_this_structure [dict create] + + # -- --- --- --- + #REVIEW + #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. + #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #e.g pdict something * + #we want the keys from the result as individual lines on lhs + #e.g pdict something @@ + #we want on lhs result on rhs + # = v0 + #e.g pdict something @0-2,@4 + #we currently return: + #0 = v0 + #1 = v1 + #2 = v2 + #4 = v4 + #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) + #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. + #this is a tradeoff that could create surprises and make things messy and/or inconsistent. + #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. + #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys + #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment + #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) + # -- --- --- --- + + set filtered_keys [list] + 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 { + set keyset [list] + set keyset_structure [list] + + set segments [split $pattern_nest /] + set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns + #we need to use _split_patterns to separate (e.g to protect commas that appear within quotes) + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + #puts stderr "showdict-->_split_patterns: $patterninfo" + foreach v_idx $patterninfo { + lassign $v_idx v idx + #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) + set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern + if {[string index $p 0] eq "!"} { + set get_not 1 + set p [string range $p 1 end] + } else { + set get_not 0 + } + switch -exact -- $p { + * - "" { + if {$opt_roottype eq "list"} { + set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + dict set pattern_this_structure $p list + } elseif {$opt_roottype eq "dict"} { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } else { + lappend keyset %string + lappend keyset_structure string + dict set pattern_this_structure $p string + } + } + %# { + dict set pattern_this_structure $p string + lappend keyset %# + lappend keyset_structure string + } + # { + #todo get_not !# is test for listiness (see punk) + dict set pattern_this_structure $p list + lappend keyset # + lappend keyset_structure list + } + ## { + dict set pattern_this_structure $p dict + lappend keyset [list ## query] + lappend keyset_structure dict + } + @* { + #puts "showdict ---->@*<----" + dict set pattern_this_structure $p list + set keys [punk::lib::range 0 [llength $dval]-1] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } + @@ { + #get first k v from dict + dict set pattern_this_structure $p dict + lappend keyset [list @@ query] + lappend keyset_structure dict + } + @*k@* - @*K@* { + #returns keys only + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @*.@* { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + default { + #puts stderr "===p:$p" + #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key + switch -glob -- $p { + {@k\*@*} - {@K\*@*} { + #value glob return keys + #set search [string range $p 4 end] + #dict for {k v} $dval { + # if {[string match $search $v]} { + # lappend keyset $k + # } + #} + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @@* { + #exact match key - review - should raise error to match punk pipe behaviour? + set k [string range $p 2 end] + if {$get_not} { + if {[dict exists $dval $k]} { + set keys [dict keys [dict remove $dval $k]] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + lappend keyset {*}[dict keys $dval] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + } + } else { + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + } + dict set pattern_this_structure $p dict + } + @k@* - @K@* { + #TODO get_not + set k [string range $p 3 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict + } + {@\*@*} { + #return list of values + #set k [string range $p 3 end] + #lappend keyset {*}[dict keys $dval $k] + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*.@*} { + #TODO get_not + set k [string range $p 4 end] + set keys [dict keys $dval $k] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + {@v\*@*} - {@V\*@*} { + #value-glob return value + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*v@*} - {@\*V@*} { + #key-glob return value + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*@*} - {@\*v@*} - {@\*V@} { + #key glob return val + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @??@* { + #exact key match - no error + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + default { + set this_type $opt_roottype + if {[string match @* $p]} { + #list mode - trim optional list specifier @ + set p [string range $p 1 end] + dict set pattern_this_structure $p list + set this_type list + } elseif {[string match %* $p]} { + dict set pattern_this_structure $p string + lappend keyset $p + lappend keyset_structure string + set this_type string + } + if {$this_type eq "list"} { + dict set pattern_this_structure $p list + if {[string is integer -strict $p]} { + if {$get_not} { + set keys [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $keys $p] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + lappend keyset $p + lappend keyset_structure list + } + } elseif {[string match "?*-?*" $p]} { + #could be either - don't change type + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + #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} == 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 == -Inf} { + ##x + set lower 0 + } else { + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve [llength $dval] $b] + if {$upper == -Inf} { + ##x + #upper bound is below list range - + if {$lower_resolve > -Inf} { + ##x + set upper 0 + } else { + continue + } + } elseif {$upper == Inf} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists + } + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + set keys [punk::lib::range $lower $upper] + if {$get_not} { + set fullrange [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $fullrange {*}$keys] + if {$lower > $upper} { + set keys [lreverse $keys] + } + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + if {$get_not} { + lappend keyset [list !@$p query] + } else { + lappend keyset [list @$p query] + } + lappend keyset_structure list + } + } elseif {$this_type eq "string"} { + dict set pattern_this_structure $p string + } elseif {$this_type eq "dict"} { + #default equivalent to @\*@* + dict set pattern_this_structure $p dict + #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" + set keys [dict keys $dval $p] + if {$get_not} { + set keys [dict keys [dict remove $dval {*}$keys]] + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + puts stderr "list: unrecognised pattern $p" + } + } + } + } + } + } + + # -- --- --- --- + #check next pattern-segment for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $segments 1] + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + if {[llength $patterninfo] == 0} { + # // ? -review - what does this mean? for xpath this would mean at any level + set substructure [lindex $pattern_this_structure end] + } elseif {[llength $patterninfo] == 1} { + #ignore the NOT operator for purposes of query-type detection + if {[string index $pnext 0] eq "!"} { + set pnext [string range $pnext 1 end] + } + # single type in segment e.g /@@something/ + switch -exact -- $pnext { + "" { + set substructure string + } + @*k@* - @*K@* - @*.@* - ## { + set substructure dict + } + # { + set substructure list + } + ## { + set substructure dict + } + %# { + set substructure string + } + * { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + default { + switch -glob -- $pnext { + @??@* - @?@* - @@* { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } + default { + if {[string match @* $pnext]} { + set substructure list + } elseif {[string match %* $pnext]} { + set substructure string + } else { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + } + } + } + } + } else { + #e.g /@0,%str,.../ + #doesn't matter what the individual types are - we have a list result + set substructure list + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + if {$opt_keysorttype ne "none"} { + set int_keyset 1 + foreach k $keyset { + if {![string is integer -strict $k]} { + set int_keyset 0 + break + } + } + if {$int_keyset} { + set sortindices [lsort -indices -integer $keyset] + #set keyset [lsort -integer $keyset] + } else { + #set keyset [lsort -$opt_keysorttype $keyset] + set sortindices [lsort -indices -$opt_keysorttype $keyset] + } + set keyset [lmap i $sortindices {lindex $keyset $i}] + set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] + } + + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + + lappend filtered_keys {*}$keyset + lappend all_keyset_structure {*}$keyset_structure + + #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" + } + } + #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" + } else { + puts stdout "unrecognised roottype: $opt_roottype" + return $dval + } + + if {[llength $filtered_keys]} { + #both keys and values could have newline characters. + #simple use of 'format' won't cut it for more complex dict keys/values + #use block::width or our columns won't align in some cases + switch -- $opt_return { + "tailtohead" { + #last line of key is side by side (possibly with separator) with first line of value + #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values + #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries + + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt {${$key}} + } + #set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] + set display_keys [lmap key $filtered_keys {tstr -ret string -allowcommands $kt}] + set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] + + set kidx 0 + set last_hidekey 0 + foreach keydisplay $display_keys key $filtered_keys { + set thisval "?" + set hidekey 0 + set pattern_nest [lindex $pattern_key_index $kidx] + set pattern_nest_list [split $pattern_nest /] + #set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $key] + set this_type [lindex $all_keyset_structure $kidx] + #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" + + set is_match 1 ;#whether to display the normal separator or bad-match separator + switch -- $this_type { + dict { + #todo? - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict + # - default highlight dupes (ansi underline?) + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + % thisval.= $qry= $dval + } else { + set thisval [tcl::dict::get $dval $key] + } + + #set substructure [lrange $opt_structure 1 end] + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + + set subansibasekeys [lrange $opt_ansibase_keys 1 end] + set nextkeytemplates [lrange $opt_keytemplates 1 end] + #dict set nextopts -substructure $nextsub + dict set nextopts -keytemplates $nextkeytemplates + dict set nextopts -ansibase_keys $subansibasekeys + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" + + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + #puts stderr ">>> nextpatterns:'$nextpatterns' nextopts:'$nextopts'" + set is_match 0 + } + } + } + list { + if {[string is integer -strict $key]} { + set thisval [lindex $dval $key] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + % thisval.= $qry= $dval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + #if {![llength $nextpatterns]} { + # set nextpatterns * + #} + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + set is_match 0 + } + } + } + string { + set hidekey 1 + if {$key eq "%string"} { + set hidekey 1 + set thisval $dval + } elseif {$key eq "%ansiview"} { + set thisval [ansistring VIEW -lf 1 $dval] + } elseif {$key eq "%ansiviewstyle"} { + set thisval [ansistring VIEWSTYLE -lf 1 $dval] + } elseif {[string match *lpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which left -width $width] + } elseif {[string match *lpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which left -width $width -padchar $extra] + } elseif {[string match *rpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which right -width $width] + } elseif {[string match *rpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which right -width $width -padchar $extra] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + set thisval $dval + if {[string index $key 0] ne "%"} { + set key %$key + } + % thisval.= $key= $thisval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + #set nextopts [dict get $argd opts] + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + if {[llength $nextpatterns]} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + + } + } + if {$this_type eq "string" && $hidekey} { + lassign [textblock::size $thisval] _vw vwidth _vh vheight + #set blanks_above [string repeat \n [expr {$kheight -1}]] + set vblock $opt_ansibase_values$thisval$RST + #append result [textblock::join_basic -- $vblock] + #review - we wouldn't need this space if we had a literal %sp %sp-x ?? + append result " $vblock" + } else { + set ansibase_key [lindex $opt_ansibase_keys 0] + + lassign [textblock::size $keydisplay] _kw kwidth _kh kheight + lassign [textblock::size $thisval] _vw vwidth _vh vheight + + set totalheight [expr {$kheight + $vheight -1}] + set blanks_above [string repeat \n [expr {$kheight -1}]] + set blanks_below [string repeat \n [expr {$vheight -1}]] + + if {$is_match} { + set use_sep $opt_sep + } else { + set use_sep $opt_mismatch_sep + } + + + set sepwidth [textblock::width $use_sep] + set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] + set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] + set vblock $blanks_above$opt_ansibase_values$thisval$RST + #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace + if {$last_hidekey} { + append result \n + } + #append result [textblock::join_basic -- $kblock $sblock $vblock] \n + append result [textblock::join_basic_raw $kblock $sblock $vblock] \n + } + set last_hidekey $hidekey + incr kidx + } + } + "sidebyside" { + # TODO - fix + #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. + #use ansibase_key etc to make the output more comprehensible in that situation. + #This is why it is not the default. (review - terminal width detection and wrapping?) + set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] + foreach key $filtered_keys { + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST + #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n + #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic + append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n + } + } + } + } + if {$opt_trimright} { + set result [::join [lines_as_list -line trimright $result] \n] + } + if {[string last \n $result] == [string length $result]-1} { + set result [string range $result 0 end-1] + } + #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) + set chan [dict get $argd opts -channel] + switch -- $chan { + stderr - stdout { + puts $chan $result + } + none { + return $result + } + default { + #review - check member of chan names? + #just try outputting to the supplied channel for now + puts $chan $result + } + } + } + + proc is_list_all_in_list {small large} { + if {[llength $small] > [llength $large]} {return 0} + foreach x $large { + ::set ($x) {} + } + foreach x $small { + if {![info exists ($x)]} { + return 0 + } + } + return 1 + } + #v2 generally seems slower + proc is_list_all_in_list2 {small large} { + set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] + return [struct::list equal [lsort $small] $small_in_large] + } + if {!$has_struct_list || !$has_struct_set} { + set body { + package require struct::list + package require struct::set + } + append body [info body is_list_all_in_list2] + proc is_list_all_in_list2 {small large} $body + } + + proc is_list_all_ni_list {A B} { + foreach x $B { + ::set ($x) {} + } + foreach x $A { + if {[info exists ($x)]} { + return 0 + } + } + return 1 + } + proc is_list_all_ni_list2 {a b} { + set i [struct::set intersect $a $b] + return [expr {[llength $i] == 0}] + } + if {!$has_struct_set} { + set body { + package require struct::list + } + append body [info body is_list_all_ni_list2] + proc is_list_all_ni_list2 {a b} $body + } + + #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist + #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, + # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) + proc ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + #with ledit (also avail in 8.6 using punk::lib::compat::ledit + proc ldiff2 {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + foreach item $removeitems { + set posns [lsearch -all -exact $fromlist $item] + foreach p $posns {ledit fromlist $p $p} + } + return $fromlist + } + proc ldiff3 {fromlist removeitems} { + set doomed [list] + foreach item $removeitems { + lappend doomed {*}[lsearch -all -exact $fromlist $item] + } + lremove $fromlist {*}$doomed + } + + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) + #also struct::set difference with critcl is faster + proc setdiff {A B} { + if {[llength $A] == 0} {return {}} + set d [dict create] + foreach x $A {dict set d $x {}} + foreach x $B {dict unset d $x} + return [dict keys $d] + } + #bulk dict remove is slower than a foreach with dict unset + #proc setdiff2 {fromlist removeitems} { + # #if {[llength $fromlist] == 0} {return {}} + # set d [dict create] + # foreach x $fromlist { + # dict set d $x {} + # } + # return [dict keys [dict remove $d {*}$removeitems]] + #} + #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) + proc setdiff_unordered {A B} { + if {[llength $A] == 0} {return {}} + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] + } + + #default/fallback implementation + proc lunique_unordered {list} { + lunique $list + } + if {$has_struct_set} { + if {[struct::set equal [struct::set union {a a} {}] {a}]} { + proc lunique_unordered {list} { + struct::set union $list {} + } + } else { + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add + } + } + + + #order-preserving + proc lunique {list} { + set new {} + foreach item $list { + if {$item ni $new} { + lappend new $item + } + } + return $new + } + proc lunique2 {list} { + set doomed [list] + #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) + for {set i 0} {$i < [llength $list]} {} { + set item [lindex $list $i] + lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] + while {[incr i] in $doomed} {} + } + lremove $list {*}$doomed + } + #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env + proc lmapflat_closure {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + # -- --- --- + #capture - use uplevel 1 or namespace eval depending on context + set capture [uplevel 1 { + apply { varnames { + set capturevars [tcl::dict::create] + set capturearrs [tcl::dict::create] + foreach fullv $varnames { + set v [tcl::namespace::tail $fullv] + upvar 1 $v var + if {[info exists var]} { + if {(![array exists var])} { + tcl::dict::set capturevars $v $var + } else { + tcl::dict::set capturearrs capturedarray_$v [array get var] + } + } else { + #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set + } + } + return [tcl::dict::create vars $capturevars arrs $capturearrs] + } } [info vars] + } ] + # -- --- --- + set cvars [tcl::dict::get $capture vars] + set carrs [tcl::dict::get $capture arrs] + set apply_script "" + foreach arrayalias [tcl::dict::keys $carrs] { + set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { + array set %realname% [set %arrayalias%][unset %arrayalias%] + }] + } + + append apply_script [string map [list %script% $script] { + #foreach arrayalias [info vars capturedarray_*] { + # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + # array set $realname [set $arrayalias][unset arrayalias] + #} + #return [eval %script%] + %script% + }] + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ + $apply_script\ + ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] + } + return $result + } + #link version - can write to vars in calling context - but keeps varnames themselves isolated + #performance much better than capture version - but still a big price to pay for the isolation + proc lmapflat_link {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + #proc lmapflat {varnames list script} { + # concat {*}[uplevel 1 [list lmap $varnames $list $script]] + #} + #lmap can accept multiple var list pairs + proc lmapflat {args} { + concat {*}[uplevel 1 [list lmap {*}$args]] + } + proc lmapflat2 {args} { + concat {*}[uplevel 1 lmap {*}$args] + } + + #proc dict_getdef {dictValue args} { + # if {[llength $args] < 1} { + # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} + # } + # set keys [lrange $args -1 end-1] + # if {[tcl::dict::exists $dictValue {*}$keys]} { + # return [tcl::dict::get $dictValue {*}$keys] + # } else { + # return [lindex $args end] + # } + #} + if {[info commands ::tcl::dict::getdef] eq ""} { + proc dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef + } + + + #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" + #} + + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {([^+-]*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + + punk::args::define { + @id -id ::punk::lib::is_indexset + @cmd -name punk::lib::is_indexset\ + -summary\ + "Validate string is a comma-delimited 'indexset'."\ + -help\ + "Validate that a string is an 'indexset' + + An indexset consists of a comma delimited list of indexes or index-ranges. + 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') + ..10 + (index 'base' to 10) + 2..11 + (index 2 to 11) + .. + (all indices) + Common whitespace elements space,tab,newlines are 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. + + see indexset_resolve" + @values -min 1 -max 1 + indexset -type string + } + proc is_indexset {indexset} { + #collapse internal whitespace (for basic whitespace set we allow) + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] + if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} { + return 0 + } + set ranges [split $indexset ,] + foreach r $ranges { + set validateindices [list] + set rposn [string first .. $r] + if {$rposn >= 0} { + set sepsize 2 + set step 1 + } else { + #check for .n. 'stepped' range + set fdot [string first . $r] + set ldot [string last . $r] + set step [string range $r $fdot+1 $ldot-1] + #todo - allow basic mathops for step: 2+1 2+-1 etc same as tcl lindex, lseq + if {![string is integer -strict $step]} { + } + } + + if {$rposn >= 0} { + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } else { + #'range' is just an index + set validateindices [list $r] + } + foreach v $validateindices { + if {$v eq "" || $v eq "end"} {continue} + if {[string is integer -strict $v]} {continue} + if {[catch {lindex {} $v}]} { + return 0 + } + } + } + return 1 + } + #review - compare to IMAP4 methods of specifying ranges? + punk::args::define { + @id -id ::punk::lib::indexset_resolve + @cmd -name punk::lib::indexset_resolve\ + -summary\ + "Resolve an indexset to a list of integers based on supplied list or string length."\ + -help\ + "Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value. + 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. + 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 + + 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 + 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 3 + numitems -type integer + indexset -type indexset -help "comma delimited specification for indices to return" + 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] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + 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 based_max [expr {$numitems -1 + $base}] + + foreach ipart $iparts { + set ipart [string trim $ipart] + set rposn [string first .. $ipart] + if {$rposn>=0} { + #range + 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 $base} + set a [punk::lib::lindex_resolve $numitems $rawa $base] + if {$a == -Inf} { + #(was -3) + #undershot - leave negative + } elseif {$a == Inf} { + #overshot + 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 > $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 $base] + if {$b == -Inf} { + #undershot - leave negative + } 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 >= $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 >= $base && $a <= $based_max} { + #only a is in the range + if {$b < $base} { + set b $base + } else { + 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 >=$base && $b <= $based_max} { + #only b is in the range + if {$a < $base} { + set a $base + } else { + 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 < $base && $b > $base} { + #spans the range in forward order + 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 > $base && $b < $base} { + #spans the range in reverse order + 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 $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 -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\ + -summary\ + "Resolve an indexexpression to an integer based on supplied list or string length."\ + -help\ + "Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2 + to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating + whether the index was below or above the range of possible indices for the length supplied. + + Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. + This means the proc may be called with something like $x+2 end-$y etc + Sometimes the actual integer index is desired. + + 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) -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 + bounds indices, or in the case of lrange, return results anyway. + Like Tcl list commands - it will produce an error if the form of the index is not acceptable. + For empty lists/string (datalength 0), end and end+x indices are considered to be out of bounds on the upper side + - thus returning -2 + + Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. + We will get something like 10+1 - which can be resolved safely with expr + " + @values -min 2 -max 2 + datalength -type integer + index -type indexexpression + } + 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 + #[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. + #[para]This means the proc may be called with something like $x+2 end-$y etc + #[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) -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. + #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable + #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 + + #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which can be resolved safely with expr + + + #REVIEW - we need compat for 1_000 etc to handle things like toml even in 8.6? + #A basic string map means we aren't properly validating + #todo - be stricter about malformations such as 1000_ + if {![string is integer -strict 1_0]} { + #basic forward compatibility with integers such as 1_000 for 8.6.x + set index [tcl::string::map {_ {}} $index] + set len [tcl::string::map {_ {}} $len] + } + + if {![string is integer -strict $len] || $len < 0} { + 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 < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } else { + if {[string match end* $index]} { + if {$index ne "end"} { + set op [string index $index 3] + set offset [string range $index 4 end] + #note - offset could have leading + or - + # 'string is integer -strict +1' ==> true + #e.g end+-1 is valid (end++-1 is not) + if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} + if {$offset == 0} { + #(offset +0, -0 or 0 or 000 0_0 etc) + #op either + or - is irrelevant + #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}}] + 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 + } + } else { + #index is 'end' + if {$len == 0} { + #special case - 'end' with empty list - treat end like a positive number out of bounds + return Inf + } + #return [expr {$len - 1 + $base}] + return $based_max + } + } else { + #plain +- already handled above. + #we are trying to avoid evaluating unbraced expr of potentially insecure origin + #regexp must split a++b to a + +b (not a+ + b) ie first +/- is the op + if {[regexp {([^+-]*)([+-])(.*)} $index _match a op b]} { + if {[string is integer -strict $a] && [string is integer -strict $b]} { + if {$op eq "-"} { + set index [expr {$a - $b}] + } else { + set index [expr {$a + $b}] + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + if {$index < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf + } + return $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 -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] || $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 < $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}] + } + } + 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 $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 + } + 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 -Inf + } else { + return $idx + } + } + proc lindex_get {list index} { + set resultlist [lrange $list $index $index] + if {![llength $resultlist]} { + return -1 + } else { + #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. + #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator + return [tcl::dict::create value [lindex $resultlist 0]] + } + } + + proc string_splitbefore {str index} { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -Inf { + return [list "" $str] + } + Inf { + return [list $str ""] + } + } + } + return [list [string range $str 0 $index-1] [string range $str $index end]] + #scan %s stops at whitespace - not useful here. + #scan $s %${p}s%s + } + proc string_splitbefore_indices {str args} { + set parts [list $str] + set sizes [list [string length $str]] + set s 0 + foreach index $args { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -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} { + if {[lindex $sizes 0] != 0} { + ledit parts 0 0 {} [lindex $parts 0] + ledit sizes 0 0 0 [lindex $sizes 0] + } + continue + } + if {$index >= [string length $str]} { + if {[lindex $sizes end] != 0} { + ledit parts end end [lindex $parts end] {} + ledit sizes end end [lindex $sizes end] 0 + } + continue + } + set i -1 + set a 0 + foreach sz $sizes { + incr i + if {$a + $sz > $index} { + set p [lindex $parts $i] + #puts "a:$a index:$index" + if {$a == $index} { + break + } + ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end] + ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}] + break + } + incr a $sz + } + #puts "->parts:$parts" + #puts "->sizes:$sizes" + } + return $parts + } + + proc K {x y} {return $x} + #*** !doctools + #[call [fun K] [arg x] [arg y]] + #[para]The K-combinator function - returns the first argument, x and discards y + #[para]see [uri https://wiki.tcl-lang.org/page/K] + #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. + + + proc is_utf8_multibyteprefix {bytes} { + #*** !doctools + #[call [fun is_utf8_multibyteprefix] [arg str]] + #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character + #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint + #[para] Will return false for an already complete utf-8 codepoint + #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument + #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes + #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] + regexp {(?x) + ^ + (?: + [\xC0-\xDF] | #possible prefix for two-byte codepoint + [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for + ) + $ + } $bytes + } + + proc is_utf8_first {str} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + } $str + } + proc is_utf8_single {1234bytes} { + #*** !doctools + #[call [fun is_utf8_single] [arg 1234bytes]] + #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + $ + } $1234bytes + } + proc get_utf8_leading {rawbytes} { + #*** !doctools + #[call [fun get_utf8_leading] [arg rawbytes]] + #[para] return the leading portion of rawbytes that is a valid utf8 sequence. + #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint + #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. + #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. + #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics + #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned + #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes + if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + \A ( + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + + } $rawbytes completeChars]} { + return $completeChars + } + return "" + } + proc hex2dec {args} { + #*** !doctools + #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] + #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values + #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 + #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. + #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 + #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 + + set list_largeHex [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" + } + set opts [tcl::dict::create\ + -validate 1\ + -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $opts] + foreach {k v} $argopts { + tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v + } + # -- --- --- --- + set opt_validate [tcl::dict::get $opts -validate] + set opt_empty [tcl::dict::get $opts -empty_as_hex] + # -- --- --- --- + + set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] + if {$opt_validate} { + #Note appended F so that we accept list of empty strings as per the documentation + if {![string is xdigit -strict [join $list_largeHex ""]F ]} { + error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" + } + } + if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { + #mapping empty string to a value destroys any advantage of -scanonly + #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] + if {[lsearch $list_largeHex ""] >=0} { + error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" + } + } else { + set opt_empty [string trim [string map {_ ""} $opt_empty]] + if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] + set nonempty_head [lrange $list_largeHex 0 $first_empty-1] + set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] + } + + proc dec2hex {args} { + #*** !doctools + #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] + #[para]Convert a list of decimal integers to a list of hex values + #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. + #[para] -case upper|lower determines the case of the hex letters in the output + set list_decimals [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" + } + set defaults [tcl::dict::create\ + -width 1\ + -case upper\ + -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $defaults] + set fullopts [tcl::dict::create] + foreach {k v} $argopts { + tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v + } + set opts [tcl::dict::merge $defaults $fullopts] + # -- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_case [tcl::dict::get $opts -case] + set opt_empty [tcl::dict::get $opts -empty_as_decimal] + # -- --- --- --- + + + set resultlist [list] + switch -- [string tolower $opt_case] { + upper { + set spec X + } + lower { + set spec x + } + default { + error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" + } + } + set fmt "%${opt_width}.${opt_width}ll${spec}" + + set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] + if {![string is digit -strict [string map {_ ""} $opt_empty]]} { + if {[lsearch $list_decimals ""] >=0} { + error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" + } + } else { + set opt_empty [string map {_ ""} $opt_empty] + if {[set first_empty [lsearch $list_decimals ""]] >= 0} { + set nonempty_head [lrange $list_decimals 0 $first_empty-1] + set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] + } + + proc log2 x "expr {log(\$x)/[expr log(2)]}" + #*** !doctools + #[call [fun log2] [arg x]] + #[para]log base2 of x + #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time + #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) + + proc logbase {b x} { + #*** !doctools + #[call [fun logbase] [arg b] [arg x]] + #[para]log base b of x + #[para]This function uses expr's natural log and the change of base division. + #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 + expr {log($x)/log($b)} + } + proc factors {x} { + #*** !doctools + #[call [fun factors] [arg x]] + #[para]Return a sorted list of the positive factors of x where x > 0 + #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* + #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors + #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions + #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers + #[para]Comparisons were done with some numbers below 17 digits long + #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. + #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers + #but has the disadvantage of being slower for 'small' numbers and using more memory. + #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x + #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py + #[para] In other mathematical contexts zero may be considered not to divide anything. + set factors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {($x % $j) == 0} { + lappend factors $j [expr {$x / $j}] + } + incr j + } + lappend factors $x + return [lsort -unique -integer $factors] + } + proc oddFactors {x} { + #*** !doctools + #[call [fun oddFactors] [arg x]] + #[para]Return a list of odd integer factors of x, sorted in ascending order + set j 2 + set max [expr {sqrt($x)}] + set factors [list 1] + while {$j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2} { + if {$other ni $factors} { + lappend factors $other + } + } + if {$j % 2} { + if {$j ni $factors} { + lappend factors $j + } + } + } + incr j + } + return [lsort -integer -increasing $factors] + } + proc greatestFactorBelow {x} { + #*** !doctools + #[call [fun greatestFactorBelow] [arg x]] + #[para]Return the largest factor of x excluding itself + #[para]factor functions can be useful for console layout calculations + #[para]See Tcllib math::numtheory for more extensive implementations + if {$x % 2 == 0 || $x == 0} { + return [expr {$x / 2}] + } + set j 3 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {$x % $j == 0} { + return [expr {$x / $j}] + } + incr j 2 + } + return 1 + } + proc greatestOddFactorBelow {x} { + #*** !doctools + #[call [fun greatestOddFactorBelow] [arg x]] + #[para]Return the largest odd integer factor of x excluding x itself + if {$x %2 == 0} { + return [greatestOddFactor $x] + } + set j 3 + #dumb brute force - time taken to compute is wildly variable on big numbers + #todo - use a (memoized?) generator of primes to reduce the search space + #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. + set god 1 + set max [expr {sqrt($x)}] + while { $j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2 == 0} { + set god $j + } else { + set god [expr {$x / $j}] + #lowest j - so other side must be highest + break + } + } + incr j 2 + } + return $god + } + proc greatestOddFactor {x} { + #*** !doctools + #[call [fun greatestOddFactor] [arg x]] + #[para]Return the largest odd integer factor of x + #[para]For an odd value of x - this will always return x + if {$x % 2 != 0 || $x == 0} { + return $x + } + set r [expr {$x / 2}] + while {$r % 2 == 0} { + set r [expr {$r / 2}] + } + return $r + } + proc gcd {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the greatest common divisor of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para]Graphical use: + #[para]An a by b rectangle can be covered with square tiles of side-length c, + #[para]only if c is a common divisor of a and b + + # + # Apply Euclid's good old algorithm + # + if { $n > $m } { + set t $n + set n $m + set m $t + } + + while { $n > 0 } { + set r [expr {$m % $n}] + set m $n + set n $r + } + + return $m + } + proc lcm {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the lowest common multiple of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para] + set gcd [gcd $n $m] + return [expr {$n*$m/$gcd}] + } + proc commonDivisors {x y} { + #*** !doctools + #[call [fun commonDivisors] [arg x] [arg y]] + #[para]Return a list of all the common factors of x and y + #[para](equivalent to factors of their gcd) + return [factors [gcd $x $y]] + } + + #experimental only - there are better/faster ways + proc sieve n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + tcl::dict::for {next -} $nums break + } + return [concat $primes [tcl::dict::keys $nums]] + } + proc sieve2 n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + #dict for {next -} $nums break + set next [lindex $nums 0] + } + return [concat $primes [tcl::dict::keys $nums]] + } + + proc hasglobs {str} { + #*** !doctools + #[call [fun hasglobs] [arg str]] + #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] + #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. + regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving + } + + proc trimzero {number} { + #*** !doctools + #[call [fun trimzero] [arg number]] + #[para]Return number with left-hand-side zeros trimmed off - unless all zero + #[para]If number is all zero - a single 0 is returned + set trimmed [string trimleft $number 0] + if {[string length $trimmed] == 0} { + set trimmed 0 + } + return $trimmed + } + proc substring_count {str substring} { + #*** !doctools + #[call [fun substring_count] [arg str] [arg substring]] + #[para]Search str and return number of occurrences of substring + + #faster than lsearch on split for str of a few K + if {$substring eq ""} {return 0} + set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] + return [expr {$occurrences / [string length $substring]}] + } + + proc dict_merge_ordered {defaults main} { + #*** !doctools + #[call [fun dict_merge_ordered] [arg defaults] [arg main]] + #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. + #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. + #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. + + #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] + } + + proc askuser {question} { + #*** !doctools + #[call [fun askuser] [arg question]] + #[para]A basic utility to read an answer from stdin + #[para]The prompt is written to the terminal and then it waits for a user to type something + #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. + #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. + #[para](Generic terminal raw vs linemode detection not yet present) + #[para]The user must hit enter to submit the response + #[para]The return value is the string if any that was typed prior to hitting enter. + #[para]The question argument can be manually colourised using the various punk::ansi funcitons + #[example_begin] + # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] + # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { + # puts "Proceeding" + # } else { + # puts "Cancelled by user" + # } + #[example_end] + puts stdout $question + flush stdout + set stdin_state [chan configure stdin] + if {[catch { + package require punk::console + set console_raw [tsv::get console is_raw] + } err_console]} { + #assume normal line mode + set console_raw 0 + } + try { + chan configure stdin -blocking 1 + if {$console_raw} { + punk::console::disableRaw + set answer [gets stdin] + punk::console::enableRaw + } else { + set answer [gets stdin] + } + } finally { + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] + } + return $answer + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text {max -1}} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + if {$max != -1} { + set len [expr {min($len,$max)}] + } + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + #e.g linesort -decreasing $data + proc linesort {args} { + #*** !doctools + #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] + #[para]Sort lines in textblock + #[para]Returns another textblock with lines sorted + #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique + if {[llength $args] < 1} { + error "linesort missing lines argument" + } + set lines [lindex $args end] + set opts [lrange $args 0 end-1] + #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts + list_as_lines [lsort {*}$opts [linelist $lines]] + } + + proc list_as_lines {args} { + #*** !doctools + #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] + #[para]This simply joins the elements of the list with -joinchar + #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines + #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. + if {[set eop [lsearch $args --]] == [llength $args]-2} { + #end-of-opts not really necessary - except for consistency with lines_as_list + set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] + } + if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { + set joinchar [lindex $args 1] + set lines [lindex $args 2] + } elseif {[llength $args] == 1} { + set joinchar "\n" + set lines [lindex $args 0] + } else { + error "list_as_lines usage: list_as_lines ?-joinchar ? " + } + return [join $lines $joinchar] + } + proc list_as_lines2 {args} { + #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? + lassign [tcl::dict::values [punk::args::parse $args withdef { + -joinchar -default \n + @values -min 1 -max 1 + }]] leaders opts values + + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] + } + + proc lines_as_list {args} { + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. + #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error + #..because we don't know what to say if there are odd numbers of args + #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work + #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway + + if {[lsearch $args "--"] == [llength $args]-2} { + set opts [lrange $args 0 end-2] + } else { + set opts [lrange $args 0 end-1] + } + #set opts [tcl::dict::merge {-block {}} $opts] + set bposn [lsearch $opts -block] + if {$bposn < 0} { + lappend opts -block {} + } + set text [lindex $args end] + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] + } + #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds + proc lines_as_list2 {args} { + #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults + #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc + #we don't have to decide what is an opt vs a value + #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) + lassign [tcl::dict::values [punk::args::parse $args withdef { + @opts -any 1 + -block -default {} + }]] leaderdict opts valuedict + tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] + } + + # important for pipeline & match_assign + # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? + # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace + set linelist_body { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + ;#package require punk::ansi + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list/detectcode_in_list will check at first level. (not intended for detecting ansi in deeper structures) + + #we use detectcode_in_list instead of detect_in_list + #detectcode_in_list will detect unclosed (or unopened) paired sequences such as PM (privacy message) + # - but the main reason is it is slightly faster. + if {![punk::ansi::ta::detectcode_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach code $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + #not sure if this handles more complex hierarchies or mixins etc. + lassign $args obj method + if {![info object isa object $obj]} { + error "show_jump_tables unable to examine '$args'. $obj is not an oo object" + } + #classes are objects too and can have direct methods + if {$method in [info object methods $obj]} { + set data [tcl::unsupported::disassemble objmethod $obj $method] + } else { + if {![info object isa class $obj]} { + set obj [info object class $obj] + } + set data [tcl::unsupported::disassemble method $obj $method] + } + } else { + error "show_jump_tables expected a procname or a class/object and method" + } + set result "" + set in_jt 0 + foreach ln [split $data \n] { + set tln [::tcl::string::trim $ln] + if {!$in_jt} { + if {[::tcl::string::match *jumpTable* $ln]} { + punk::ns::call_frame + append result $ln \n + set in_jt 1 + } + } else { + if {[::tcl::string::match Command* $tln] || [::tcl::string::match "(*) *" $tln]} { + set in_jt 0 + } else { + append result $ln \n + } + } + } + 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)}] + } + proc temperature_c_to_f {deg_celsius} { + return [expr {($deg_celsius * (9/5.0)) + 32}] + } + + proc interp_sync_package_paths {interp} { + if {![interp exists $interp]} { + error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" + } + interp eval $interp [list set ::auto_path $::auto_path] + interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} + interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] + } + + proc valcopy {obj} { + append obj2 $obj {} + } + proc set_valcopy {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_valcopy varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + + + proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { + variable has_twapi + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + set localeid [twapi::get_system_default_lcid] + } + } + #when using twapi we currently only get the localeid - not the specific defaults + #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this + set default_delim "," + set default_groupsize 3 + + set results [list] + set nums [valcopy $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list + foreach inputnum $nums { + set number [valcopy $inputnum] + #also handle tcl 8.7+ underscores in numbers + set number [string map [list _ "" , ""] $number] + #normalize e.g 2e4 -> 20000.0 + set number [expr {$number}] + + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + lappend results [twapi::format_number $number $localeid -idigits -1] + continue + } else { + #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one + #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? + if {$delim eq ""} {set delim $default_delim} + if {$groupsize eq ""} {set groupsize $default_groupsize} + lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] + continue + } + } + #todo - get configured user defaults + if {$delim eq ""} { + set delim $default_delim + } + if {$groupsize eq ""} { + set groupsize $default_groupsize + } + + lappend results [delimit_number $number $delim $groupsize] + } + + if {[llength $results] == 1} { + #keep intrep as string rather than list + return [lindex $results 0] + } + return $results + } + + + #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse + # Given a number represented as a string, insert delimiters to break it up for + # readability. Normally, the delimiter will be a comma which will be inserted every + # three digits. However, the delimiter and groupsize are optional arguments, + # permitting use in other locales. + # + # The string is assumed to consist of digits, possibly preceded by spaces, + # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* + + proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { + set number [valcopy $unformattednumber] + set number [string map {_ ""} $number] + #normalize using expr - e.g 2e4 -> 20000.0 + set number [expr {$number}] + # First, extract right hand part of number, up to and including decimal point + set point [string last "." $number]; + if {$point >= 0} { + set PostDecimal [string range $number $point+1 end]; + set PostDecimalP 1; + } else { + set point [expr {[string length $number] + 1}] + set PostDecimal ""; + set PostDecimalP 0; + } + + # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? + set ind 0; + while {[string equal [string index $number $ind] \u0020]} { + incr ind; + } + set FirstNonSpace $ind; + set LastSpace [expr {$FirstNonSpace - 1}]; + set LeadingSpaces [string range $number 0 $LastSpace]; + + # Now extract the non-fractional part of the number, omitting leading spaces. + set MainNumber [string range $number $FirstNonSpace $point-1]; + + # Insert commas into the non-fractional part. + set Length [string length $MainNumber]; + set Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; + set DelimitedMain ""; + + #First we deal with the extra stuff. + if {$Phase > 0} { + append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; + } + set FirstInGroup $Phase; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; + while {$LastInGroup < $Length} { + if {$FirstInGroup > 0} { + append DelimitedMain $delim; + } + append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; + incr FirstInGroup $GroupSize + incr LastInGroup $GroupSize + } + + # Reassemble the number. + if {$PostDecimalP} { + return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; + } else { + return [format "%s%s" $LeadingSpaces $DelimitedMain]; + } + } + + #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 + #[list_end] [comment {--- end definitions namespace punk::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} + +tcl::namespace::eval punk::lib::test { + + + +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#todo - way to generate 'internal' docs separately? +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::lib::system { + #*** !doctools + #[subsection {Namespace punk::lib::system}] + #[para] Internal functions that are not part of the API + #[list_begin definitions] + + + proc mostFactorsBelow {n} { + ##*** !doctools + #[call [fun mostFactorsBelow] [arg n]] + #[para]Find the number below $n which has the greatest number of factors + #[para]This will get slow quickly as n increases (100K = 1s+ 2024) + set most 0 + set mostcount 0 + for {set i 1} {$i < $n} {incr i} { + set fc [llength [punk::lib::factors $i]] + if {$fc > $mostcount} { + set most $i + set mostcount $fc + } + } + return [list number $most numfactors $mostcount] + } + proc factorCountBelow_punk {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [punk::lib::factors $i]] + } + return $tally + } + proc factorCountBelow_numtheory {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) + package require math::numtheory + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [math::numtheory::factors $i]] + } + return $tally + } + + proc factors2 {x} { + ##*** !doctools + #[call [fun factors2] [arg x]] + #[para]Return a sorted list of factors of x + #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. + set smallfactors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j < $max} { + if {($x % $j) == 0} { + lappend smallfactors $j + lappend largefactors [expr {$x / $j}] + } + incr j + } + #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop + if {($x % $j) == 0} { + if {$j == ($x / $j)} { + lappend smallfactors $j + } + } + return [concat $smallfactors [lreverse $largefactors] $x] + } + + + + # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command + #important - used by punk::repl + proc incomplete {partial} { + #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + #puts stderr "-->$clist<--" + set waiting [list ""] + set innerpartials [list ""] + set escaped 0 + set i 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + incr i + continue + } ;# set escaped 0 at end + set p [lindex $innerpartials end] + if {$escaped == 0} { + #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) + switch -- $c { + {"} { + if {![info complete ${p}]} { + lappend waiting {"} + lappend innerpartials "" + } else { + if {[lindex $waiting end] eq {"}} { + #this quote is endquote + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + if {![info complete ${p}$c]} { + lappend waiting {"} + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } + {[} { + if {![info complete ${p}$c]} { + lappend waiting "\]" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "{" { + if {![info complete ${p}$c]} { + lappend waiting "\}" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "}" - + default { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } else { + set p ${p}${c} + lset innerpartials end $p + } + set escaped 0 + incr i + } + set incomplete [list] + foreach w $waiting { + #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. + switch -- $w { + {"} { + lappend incomplete $w + } + {]} { + lappend incomplete "\[" + } + "{" {} + "}" { + lappend incomplete "\{" + } + } + } + set debug 0 + if {$debug} { + foreach w $waiting p $innerpartials { + puts stderr "->awaiting:'$w' partial: $p" + } + } + return $incomplete + } + #This only works for very simple cases will get confused with for example: + # {set x "a["""} + proc incomplete_naive {partial} { + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + set waiting [list] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } + if {!$escaped} { + if {$c eq {"}} { + if {[lindex $waiting end] eq {"}} { + set waiting [lrange $waiting 0 end-1] + } else { + lappend waiting {"} + } + } elseif {$c eq "\["} { + lappend waiting "\]" + } elseif {$c eq "\{"} { + lappend waiting "\}" + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + } + } + } + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + return $incomplete + } + + #get info about punk nestindex key ie type: list,dict,undetermined + # pdict devel + proc nestindex_info {args} { + set argd [punk::args::parse $args withdef { + -parent -default "" + nestindex + }] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + #??? + + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] +} + +tcl::namespace::eval punk::lib::debug { + proc showdict {args} {} +} + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::lib +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::lib [tcl::namespace::eval punk::lib { + variable pkg punk::lib + variable version + set version 0.1.4 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm index e0532e41..fea6b146 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm index 8e4699dc..677ad6e4 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 82756da2..4a680500 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index f976ae57..e56da520 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl-0.1.2.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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm index 9df5ae56..a074cd76 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm index 0b5bd298..9adb8b36 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::trie 0 0.1.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 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm index 451ad7a5..9c44ea72 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/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/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm index d83c17d9..93e4a41c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.7.2.tm new file mode 100644 index 00000000..aa7405e2 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/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] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm index 5045579b..2b2118cf 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm @@ -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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 0ab37079..fb5adce3 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/aliascore-0.1.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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm index ccc6bb78..3d9988b1 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm index c20e3b51..3071ebd3 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.2.1.tm @@ -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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm index 3a74754f..3f25023e 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args/moduledoc/tclcore-0.1.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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index e1f2a440..39eeccd2 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::console 0 0.1.1] #[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 0.1.1 + set version 0.1.1 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.1.tm new file mode 100644 index 00000000..d0e740fa --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.1.tm @@ -0,0 +1,1739 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::fileline 0.1.1 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::fileline 0 0.1.1] +#[copyright "2024"] +#[titledesc {file line-handling utilities}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] +#[require punk::fileline] +#[keywords module text parse file encoding BOM] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para]Utilities for in-memory analysis of text file data as both line data and byte/char-counted data whilst preserving the line-endings (even if mixed) +#[para]This is important for certain text files where examining the number of chars/bytes is important +#[para]For example - windows .cmd/.bat files need some byte counting to determine if labels lie on chunk boundaries and need to be moved. +#[para]This chunk-size counting will depend on the character encoding. +#[para]Despite including the word 'file', the library doesn't necessarily deal with reading/writing to the filesystem - +#[para]The raw data can be supplied as a string, or loaded from a file using punk::fileline::get_textinfo -file +#[subsection Concepts] +#[para]A chunk of textfile data (possibly representing a whole file - but usually at least a complete set of lines) is loaded into a punk::fileline::class::textinfo instance at object creation. +#[example_begin] +# package require punk::fileline +# package require fileutil +# set rawdata [lb]fileutil::cat data.txt -translation binary[rb] +# punk::fileline::class::textinfo create obj_data $rawdata +# puts stdout [lb]obj_data linecount[rb] +#[example_end] +#[subsection Notes] +#[para]Line records are referred to by a zero-based index instead of a one-based index as is commonly used when displaying files. +#[para]This is for programming consistency and convenience, and the module user should do their own conversion to one-based indexing for line display or messaging if desired. +#[para]No support for lone carriage-returns being interpreted as line-endings. +#[para]CR line-endings that are intended to be interpreted as such should be mapped to something else before the data is supplied to this module. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages needed by punk::fileline +#[list_begin itemized] + + package require Tcl 8.6- + package require punk::args + #*** !doctools + #[item] [package {Tcl 8.6-}] + #[item] [package {punk::args}] + + + # #package require frobz + # #*** !doctools + # #[item] [package {frobz}] + +#*** !doctools +#[list_end] [comment {- end dependencies list -}] + +#*** !doctools +#[subsection {optional dependencies}] +#[para] packages that add functionality but aren't strictly required +#[list_begin itemized] + + #*** !doctools + #[item] [package {punk::ansi}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + #[item] [package {punk::char}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + #[item] [package {overtype}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + + +#*** !doctools +#[list_end] [comment {- end optional dependencies list -}] + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline::class { + namespace export * + #*** !doctools + #[subsection {Namespace punk::fileline::class}] + #[para] class definitions + if {[info commands [namespace current]::textinfo] 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}] + # } + + + #uses zero based indexing. Caller can add 1 for line numbers + oo::class create [namespace current]::textinfo { + #*** !doctools + #[enum] CLASS [class textinfo] + #[list_begin definitions] + # [para] [emph METHODS] + + variable o_chunk ;#current state + variable o_chunkop_store + variable o_lineop_store + + variable o_chunk_epoch + variable o_line_epoch + variable o_payloadlist + variable o_linemap + variable o_LF_C + variable o_CRLF_C + + + variable o_bom_id + variable o_bom + variable o_bom_map + + #review - for now we expect datachunk to be data without BOM and already encoded appropriately + #fileline::get_textinfo has support for interpreting BOM - but we currently have no way to do that for data not coming from a file + #refactor to allow that code to be called from here? + constructor {datachunk args} { + #*** !doctools + #[call class::textinfo [method constructor] [arg datachunk] [opt {option value...}]] + #[para] Constructor for textinfo object which represents a chunk or all of a file + #[para] datachunk should be passed with the file data including line-endings as-is for full functionality. ie use something like: + #[example_begin] + # chan configure $fd -translation binary + # set chunkdata [lb]read $fd[rb]] + #or + # set chunkdata [lb]fileutil::cat -translation binary[rb] + #[example_end] + #[para] when loading the data + namespace eval [namespace current] { + set nspath [namespace path] + foreach p [list ::punk::fileline ::punk::fileline::ansi] { + if {$p ni $nspath} { + lappend nspath $p + } + } + namespace path $nspath + } + + set o_bom_map [list\ + utf-8 \u00ef\u00bb\u00bf\ + utf-16be \u00fe\u00ff\ + utf-16le \u00ff\u00fe\ + utf-32be \u0000\u0000\u00fe\u00ff\ + utf-32le \u00ff\u00fe\u0000\u0000\ + utf-7 \u002b\u002f\u0076\ + utf-1 \u00f7\u0064\u004c\ + utf-ebcdic \u00dd\u0073\u0066\u0073\ + utf-scsu \u0003\u00fe\u00ff\ + utf-bocu-1 \u00fb\u00ee\u0028\ + utf-gb18030 \u0084\u0031\u0095\u0033\ + ] + set o_bom_id "" + set o_bom "" ;#review + + set o_chunk $datachunk + set o_line_epoch [list] + set o_chunk_epoch [list "fromchunkchange-at-[clock micros]"] + set crlf_lf_placeholders [list \uFFFF \uFFFE] ;#defaults - if already exist in file - error out with message + set defaults [dict create\ + -substitutionmap {}\ + -crlf_lf_placeholders $crlf_lf_placeholders\ + -userid ""\ + ] + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "[self] constructor error: unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- + set opt_substitutionmap [dict get $opts -substitutionmap] ;#review - can be done by caller - or a loadable -policy + set opt_crlf_lf_placeholders [dict get $opts -crlf_lf_placeholders] + set opt_userid [dict get $opts -userid] + # -- --- --- --- --- --- --- + + if {[llength $opt_crlf_lf_placeholders] != 2 || [string length [lindex $opt_crlf_lf_placeholders 0]] !=1 || [string length [lindex $opt_crlf_lf_placeholders 1]] !=1} { + error "textinfo::constructor error: -crlf_lf_placeholders requires a list of exactly 2 chars" + } + lassign $opt_crlf_lf_placeholders o_LF_C o_CRLF_C + if {[string first $o_LF_C $o_chunk] >=0} { + set decval [scan $o_LF_C %c] + if {$decval < 32 || $decval > 127} { + set char_desc "(decimal value $decval)" + } else { + set char_desc "'$o_LF_C' (decimal value $decval)" + } + error "textinfo::constructor error: rawfiledata already contains linefeed substitution character $char_desc specified as first element of -crlf_lf_placeholders" + } + if {[string first $o_CRLF_C $o_chunk] >=0} { + set decval [scan $o_CRLF_C %c] + if {$decval < 32 || $decval > 127} { + set char_desc "(decimal value $decval)" + } else { + set char_desc "'$o_CRLF_C' (decimal value $decval)" + } + error "textinfo::constructor error: rawfiledata already contains carriagereturn-linefeed substitution character $char_desc specified as second element of -crlf_lf_placeholders" + } + if {$o_LF_C eq $o_CRLF_C} { + puts stderr "WARNING: same substitution character used for both elements of -crlf_lf_placeholders - byte counting may be off if file contains mixed line-endings" + } + + my regenerate_lines + + } + + method set_bomid {bomid} { + if {$bomid ni [dict keys $o_bom_map]} { + error "Unrecognised bom-id $bomid. Known values: [dict keys $o_bom_map]" + } + set o_bom_id $bomid + set o_bom [dict get $o_bom_map $bomid] + } + method get_bomid {} { + return $o_bom_id + } + method get_bom {} { + return $o_bom + } + + method chunk {chunkstart chunkend} { + #*** !doctools + #[call class::textinfo [method chunk] [arg chunkstart] [arg chunkend]] + #[para]Return a range of bytes from the underlying raw chunk data. + #[para] e.g The following retrieves the entire chunk + #[para] objName chunk 0 end + return [string range $o_chunk $chunkstart $chunkend] + } + method chunklen {} { + #*** !doctools + #[call class::textinfo [method chunklen]] + #[para] Number of bytes/characters in the raw data of the file + return [string length $o_chunk] + } + method chunk_boundary_display {chunkstart chunkend chunksize args} { + #*** !doctools + #[call class::textinfo [method chunk_boundary_display]] + #[para]Returns a string displaying the boundaries at chunksize bytes between chunkstart and chunkend + #[para]Defaults to using ansi colour if punk::ansi module is available. Use -ansi 0 to disable colour + set opts [dict create\ + -ansi $::punk::fileline::ansi::enabled\ + -offset 0\ + -displaybytes 200\ + -truncatedmark "..."\ + -completemark "---"\ + -moremark " + "\ + -continuemark " > "\ + -linemaxwidth 100\ + -linebase 0\ + -limit -1\ + -boundaries {}\ + -showconfig 0\ + -boundaryheader {Boundary %i% at %b%}\ + ] + foreach {k v} $args { + switch -- $k { + -ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader { + dict set opts $k $v + } + default { + error "[self]::chunk_boundary error: unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_ansi [dict get $opts -ansi] + set opt_offset [dict get $opts -offset] + set opt_displaybytes [dict get $opts -displaybytes] + set opt_tmark [dict get $opts -truncatedmark] + set opt_cmark [dict get $opts -completemark] + set opt_linemax [dict get $opts -linemaxwidth] + set opt_linebase [dict get $opts -linebase] + set opt_linebase [string map [list _ ""] $opt_linebase] + set opt_limit [dict get $opts -limit] ;#limit number of boundaries to display + set opt_boundaries [dict get $opts -boundaries] ;#use pre-calculated boundaries if supplied + set opt_showconfig [dict get $opts -showconfig] + set opt_boundaryheader [dict get $opts -boundaryheader] + # -- --- --- --- --- --- + package require overtype + # will require punk::char and punk::ansi + + if {"::punk::fileline::ansi::ansistrip" ne [info commands ::punk::fileline::ansi::ansistrip]} { + namespace eval ::punk::fileline::ansi { + namespace import ::punk::ansi::* + } + } + + #This mechanism for enabling/disabling ansi is a bit clumsy - prone to errors with regard to keeping in sync with any api changes in punk ansi + #It's done here to allow this to be used without the full set of punk modules and/or shell - REVIEW + + #risk of failing to reset on error + set pre_ansi_enabled $::punk::fileline::ansi::enabled + if {$opt_ansi} { + set ::punk::fileline::ansi::enabled 1 + } else { + set ::punk::fileline::ansi::enabled 0 + } + if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { + proc ::punk::fileline::a {args} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::a {*}$args + } else { + return "" + } + } + proc ::punk::fileline::a+ {args} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::a+ {*}$args + } else { + return "" + } + } + proc ::punk::fileline::ansistrip {str} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::ansistrip $str + } else { + return $str + } + } + } + set maxline [lindex [my chunkrange_to_linerange $chunkend $chunkend] 0] + set minline [lindex [my chunkrange_to_linerange $chunkstart $chunkstart] 0] + + #suport simple end+-int (+-)start(+-)int to set linebase to line corresponding to chunkstart or chunkend + #also simple int+int and int-int - nothing more complicated (similar to Tcl lrange etc in that regard) + #commonly this will be something like -start or -end + if {![string is integer -strict $opt_linebase]} { + set sign "" + set errunrecognised "unrecognised -linebase value '$opt_linebase'. Expected positive or negative integer or -start -start-int -start+int -end -end-int -end+int or -eof (where leading - is optional but probably desirable) " + if {[string index $opt_linebase 0] eq "-"} { + set sign - + set tail [string range $opt_linebase 1 end] + } else { + set tail [string trimleft $opt_linebase +];#ignore + + } + #todo - switch -glob -- $tail + if {[string match eof* $tail]} { + set endmath [string range $tail 3 end] + #todo endmath? + if {$tail eq "eof"} { + set lastline [lindex [my chunkrange_to_linerange end end] 0] + set linebase ${sign}$lastline + } else { + error $errunrecognised + } + } elseif {[string match end* $tail]} { + set endmath [string range $tail 3 end] + if {[string length $endmath]} { + set op [string index $endmath 0] + if {$op in {+ -}} { + set operand [string range $endmath 1 end] + if {[string is integer -strict $operand]} { + if {$op eq "+"} { + set linebase [expr {$maxline + $operand}] + } else { + set linebase [expr {$maxline - $operand}] + } + } else { + error $errunrecognised + } + } else { + error $errunrecognised + } + } else { + set linebase $maxline + } + set linebase ${sign}$linebase + } elseif {[string match start* $tail]} { + set endmath [string range $tail 5 end] + if {[string length $endmath]} { + set op [string index $endmath 0] + if {$op in {+ -}} { + set operand [string range $endmath 1 end] + if {[string is integer -strict $operand]} { + if {$op eq "+"} { + set linebase [expr {$minline + $operand}] + } else { + set linebase [expr {$minline - $operand}] + } + } else { + error $errunrecognised + } + } else { + error $errunrecognised + } + } else { + set linebase $minline + } + set linebase ${sign}$linebase + } elseif {[string match *-* $tail]} { + set extras [lassign [split $tail -] int1 int2] + if {[llength $extras]} { + error $errunrecognised + } + if {![string is integer -strict $int1] || ![string is integer -strict $int2]} { + error $errunrecognised + } + set linebase [expr {$int1 - $int2}] + set linebase ${sign}$linebase + } elseif {[string match *+* $tail]} { + set extras [lassign [split $tail +] int1 int2] + if {[llength $extras]} { + error $errunrecognised + } + if {![string is integer -strict $int1] || ![string is integer -strict $int2]} { + error $errunrecognised + } + set linebase [expr {$int1 + $int2}] + set linebase ${sign}$linebase + } else { + error $errunrecognised + } + + } else { + set linebase $opt_linebase + } + + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + + if {![llength $opt_boundaries]} { + set binfo [lib::range_spans_chunk_boundaries $chunkstart $chunkend $chunksize -offset $opt_offset] + set boundaries [dict get $binfo boundaries] + } else { + set boundaries [list] + foreach b $opt_boundaries { + if {$chunkstart <= $b && $chunkend >= $b} { + lappend boundaries [expr {$b + $opt_offset}] + } + } + } + + + if {![llength $boundaries]} { + return "No boundaries found between $chunkstart and $chunkend for chunksize $chunksize (when offset $opt_offset)" + } + if {$opt_showconfig} { + set result "chunk range $chunkstart $chunkend line range $minline $maxline linebase $linebase limit $opt_limit\n" + } else { + set result "" + } + set pre_bytes [expr {$opt_displaybytes /2}] + set post_bytes $pre_bytes + set max_bytes [expr {[my chunklen] -1}] + if {$opt_limit > 0} { + set boundaries [lrange $boundaries[unset boundaries] 0 $opt_limit-1] + } + + set i 0 + foreach b $boundaries { + if {$opt_boundaryheader ne ""} { + set j [expr {$i+1}] + append result [string map [list %b% $b %i% $i %j% $j] $opt_boundaryheader] \n + } + set low [expr {max(($b - $pre_bytes),0)}] + set high [expr {min(($b + $post_bytes),$max_bytes)}] + + set lineinfolist [my chunkrange_to_lineinfolist $low $high -show_truncated 1] + set le_map [list \r\n \r \n ] + set result_list [list] + foreach lineinfo $lineinfolist { + set lineidx [dict get $lineinfo lineindex] + + set linenum [expr {$lineidx + $linebase}] + set s [dict get $lineinfo start] + set e [dict get $lineinfo end] + + set boundarymarker "" + set displayidx "" + set linenum_display $linenum + if {$s <= $b && $e >= $b} { + set idx [expr {$b - $s}] ;#index into whole position in whole line - not so useful if we're viewing a small section of a line + set char [string index [my line $lineidx] $idx] + set char_display [string map [list \r \n ] $char] + if {[dict get $lineinfo is_truncated]} { + set tside [dict get $lineinfo truncatedside] + set truncated [dict get $lineinfo truncated] + set tlen [string length $truncated] + if {"left" in $tside} { + set tleft [dict get $lineinfo truncatedleft] + set tleftlen [string length $tleft] + set displayidx [expr {$idx - $tleftlen}] + } elseif {"right" in $tside} { + set displayidx $idx + } + } else { + set displayidx $idx + } + set boundarymarker "'[a+ green bold]$char_display[a]'@$displayidx" + set linenum_display ${linenum_display},$idx + } + + set lhs_status $opt_cmark ;#default + set rhs_status $opt_cmark ;#default + if {[dict get $lineinfo is_truncated]} { + set line [dict get $lineinfo truncated] + set tside [dict get $lineinfo truncatedside] + if {"left" in $tside && "right" in $tside } { + set lhs_status $opt_tmark + set rhs_status $opt_tmark + } elseif {"left" in $tside} { + set lhs_status $opt_tmark + } elseif {"right" in $tside} { + set rhs_status $opt_tmark + } + + + } else { + set line [my line $lineidx] + } + if {$displayidx ne ""} { + set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] + } + set displayline [string map $le_map $line] + lappend result_list [list $linenum_display $boundarymarker $lhs_status $displayline $rhs_status] + } + set title_linenum "LNUM" + set linenums [lsearch -index 0 -all -inline -subindices $result_list *] + set markers [lsearch -index 1 -all -inline -subindices $result_list *] + set lines [lsearch -index 3 -all -inline -subindices $result_list *] + set title_marker "" + set title_line "Line" + #todo - use punk::char for unicode support of wide chars etc? + set widest_linenum [tcl::mathfunc::max {*}[lmap v [concat [list $title_linenum] $linenums] {string length $v}]] + set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [ansistrip $v]}]] + set widest_status [expr {max([string length $opt_cmark], [string length $opt_tmark])}] + set widest_line [tcl::mathfunc::max {*}[lmap v [concat [list $title_line] $lines] {string length $v}]] + foreach row $result_list { + lassign $row linenum marker lhs_status line rhs_status + append result [format " %-*s " $widest_linenum $linenum] + append result [format " %-*s " $widest_marker $marker] + append result [format " %-*s " $widest_status $lhs_status] + append result [format " %-*s " $widest_line $line] + append result [format " %-*s " $widest_status $rhs_status] \n + } + incr i + } + set ::punk::fileline::ansi::enabled $pre_ansi_enabled + return $result + } + method linecount {} { + #*** !doctools + #[call class::textinfo [method linecount]] + #[para] Number of lines in the raw data of the file, counted as per the policy in effect + return [llength $o_payloadlist] + } + + + method line {lineindex} { + #*** !doctools + #[call class::textinfo [method line] [arg lineindex]] + #[para]Reconstructs and returns the raw line using the payload and per-line stored line-ending metadata + #[para]A 'line' may be returned without a line-ending if the unerlying chunk had trailing data without a line-ending (or the chunk was loaded under a non-standard -policy setting) + #[para]Whilst such data may not conform to definitions (e.g POSIX) of the terms 'textfile' and 'line' - it is useful here to represent it as a line with metadata le set to "none" + #[para]To return just the data which might more commonly be needed for dealing with lines, use the [method linepayload] method - which returns the line data minus line-ending + + lassign [my numeric_linerange $lineindex 0] lineindex + + set le [dict get $o_linemap $lineindex le] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] $le] + return [lindex $o_payloadlist $lineindex]$le_chars + } + method chunk_find_glob {globsearch args} { + #todo - use linepayload_find_glob when -ignore_lineendings is 0 - but check truncations for 1st and last line + error "unimplemented" + } + method linepayload_find_glob {globsearch args} { + #*** !doctools + #[call class::textinfo [method linepayload_find_glob] [arg globsearch] [opt {option value...}]] + #[para]Return a lineinfolist (see [method lineinfo] and [method lineinfolist]) of lines where payload matches the [arg globsearch] string + #[para]To limit the returned results use the -limit n option - where -limit 0 means return all matches. + #[para]For example: [method linepayload_find_glob] "*test*" -limit 1 + #[para]The result is always a list of lineinfo dictionaries even if one item is returned + #[para] -limitfrom can be start|end + #[para]The order of results is always the order as they occur in the data - even if -limitfrom end is specified. + #[para]-limitfrom end means that only the last -limit items are returned + #[para]Note that as glob accepts [lb]chars[rb]] to mean match any character in the set given by chars, searching for literal square brackets should be done by escaping the bracket with a backslash + #[para]This is true even if only a single square bracket is being searched for. e.g {*[lb]file*} will not find the word file followed by a left square-bracket - even though the search didn't close the square brackets. + #[para]In the above case - the literal search should be {*\[lb]file*} + + set opts [dict create\ + -limit 0\ + -strategy 1\ + -start 0\ + -end end\ + -limitfrom start\ + ] + foreach {k v} $args { + switch -- $k { + -limit - -strategy - -start - -end - -limitfrom { + dict set opts $k $v + } + default { + error "linepayload_find_glob unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_limit [dict get $opts -limit] + if {![string is integer -strict $opt_limit] || $opt_limit < 0} { + error "linepayload_find_glob -limit must be positive integer" + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_strategy [dict get $opts -strategy] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_start [dict get $opts -start] + set opt_start [expr {$opt_start}] + if {$opt_start != 0} {error "-start unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_end [dict get $opts -end] + set max_line_index [expr {[llength $o_payloadlist]-1}] + if {$opt_end eq "end"} { + set opt_end $max_line_index + } + #TODO + if {$opt_end < $max_line_index} {error "-end less than max_line_index unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_limitfrom [dict get $opts -limitfrom] + #-limitfrom start|end only + #TODO + if {$opt_limitfrom ne "start"} {error "-limitfrom unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + set lineinfolist [list] + + if {$opt_limit == 1} { + set idx [lsearch -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + if {$idx >=0} { + set i [expr {$opt_start + $idx}] + lappend lineinfolist [list lineindex $i [dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } elseif {$opt_limit == 0} { + set indices [lsearch -all -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + foreach irel $indices { + set i [expr {$opt_start + $irel}] + lappend lineinfolist [list lineindex $i [dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } else { + #todo - auto-strategy based on limit vs number of lines + if {$opt_strategy == 0} { + set posn 0 + for {set r 0} {$r < $opt_limit} {incr r} { + set n [lsearch [lrange $o_payloadlist $posn+$opt_start end] $globsearch] + if {$n >=0} { + set irel [expr {$posn + $n}] + set i [expr {$irel + $opt_start}] + lappend lineinfolist [list lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + set posn [expr {$irel+1}] + } + } + } else { + set indices [lsearch -all -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + set limited [lrange $indices 0 $opt_limit-1] + foreach irel $limited { + set i [expr {$opt_start + $irel}] + lappend lineinfolist [list lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } + } + return $lineinfolist + } + method linepayload {lineindex} { + #*** !doctools + #[call class::textinfo [method linepayload] [arg lineindex]] + #[para]Return the text of the line indicated by the zero-based lineindex + #[para]The line-ending is not returned in the data - but is still stored against this lineindex + #[para]Line Metadata such as the line-ending for a particular line and the byte/character range it occupies within the chunk can be retrieved with the [method linemeta] method + #[para]To retrieve both the line text and metadata in a single call the [method lineinfo] method can be used + #[para]To retrieve an entire line including line-ending use the [method line] method. + lassign [my numeric_linerange $lineindex 0] lineindex + return [lindex $o_payloadlist $lineindex] + } + method linepayloads {startindex endindex} { + #*** !doctools + #[call class::textinfo [method linepayloads] [arg startindex] [arg endindex]] + #[para]Return a list of just the payloads in the specified linindex range, with no metadata. + return [lrange $o_payloadlist $startindex $endindex] + } + method linemeta {lineindex} { + #*** !doctools + #[call class::textinfo [method linemeta] [arg lineindex]] + #[para]Return a dict of the metadata for the line indicated by the zero-based lineindex + #[para]Keys returned include + #[list_begin itemized] + #[item] le + #[para] A string representing the type of line-ending: crlf|lf|none + #[item] linelen + #[para] The number of characters/bytes in the whole line including line-ending if any + #[item] payloadlen + #[para] The number of character/bytes in the line excluding line-ending + #[item] start + #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line begins + #[item] end + #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line ends + #[para] This end-point corresponds to the last character of the line-ending if any - not necessarily the last character of the line's payload + #[list_end] + lassign [my numeric_linerange $lineindex 0] lineindex + dict get $o_linemap $lineindex + } + method lineinfo {lineindex} { + #*** !doctools + #[call class::textinfo [method lineinfo] [arg lineindex]] + #[para]Return a dict of the metadata and text for the line indicated by the zero-based lineindex + #[para]This returns the same info as the [method linemeta] with an added key of 'payload' which is the text of the line without line-ending. + #[para]The 'payload' value is the same as is returned from the [method linepayload] method. + lassign [my numeric_linerange $lineindex 0] lineindex ;#convert lineindex to canonical number e.g 1_000 -> 1000 end -> highest index + return [dict create lineindex $lineindex {*}[dict get $o_linemap $lineindex] payload [lindex $o_payloadlist $lineindex]] + } + method lineinfolist {startidx endidx} { + #*** !doctools + #[call class::textinfo [method lineinfolist] [arg startidx] [arg endidx]] + #[para]Returns list of lineinfo dicts for each line in line index range startidx to endidx + lassign [my numeric_linerange $startidx $endidx] startidx endidx + set chunkstart [dict get $o_linemap $startidx start] + set chunkend [dict get $o_linemap $endidx end] + set line_list [my chunkrange_to_lineinfolist $chunkstart $chunkend] ;# assertion - no need to view truncations as we've picked start and end of complete lines + #verify sanity + set l_start [lindex $line_list 0] + if {[set idx_start [dict get $l_start lineindex]] ne $startidx} { + error "lineinfolist first lineindex $idx_start doesn't match startidx $startidx" + } + set l_end [lindex $line_list end] + if {[set idx_end [dict get $l_end lineindex]] ne $endidx} { + error "lineinfolist last lineindex $idx_end doesn't match endidx $endidx" + } + return $line_list + } + + method linerange_to_chunkrange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linerange_to_chunkrange] [arg startidx] [arg endidx]] + + lassign [my numeric_linerange $startidx $endidx] startidx endidx + #inclusive range + return [list [dict get $o_linemap $startidx start] [dict get $o_linemap $endidx end]] + } + method linerange_to_chunk {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linerange_to_chunk] [arg startidx] [arg endidx]] + set chunkrange [my linerange_to_chunkrange $startidx $endidx] + return [string range $o_chunk [lindex $chunkrange 0] [lindex $chunkrange 1]] + } + method lines {startidx endidx} { + #*** !doctools + #[call class::textinfo [method lines] [arg startidx] [arg endidx]] + lassign [my numeric_linerange $startidx $endidx] startidx endidx + set linelist [list] + set le_map [dict create lf \n crlf \r\n none ""] + for {set i $startidx} {$i <= $endidx} {incr i} { + lappend linelist "[lindex $o_payloadlist $i][dict get $le_map [dict get $o_linemap $i le]]" + } + return $linelist + } + method linepayloads {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linepayloads] [arg startidx] [arg endidx]] + return [lrange $o_payloadlist $startidx $endidx] + } + method chunkrange_to_linerange {chunkstart chunkend} { + #*** !doctools + #[call class::textinfo [method chunkrange_to_linerange] [arg chunkstart] [arg chunkend]] + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + + set linestart -1 + for {set i 0} {$i < [llength $o_payloadlist]} {incr i} { + if {($chunkstart >= [dict get $o_linemap $i start]) && ($chunkstart <= [dict get $o_linemap $i end])} { + set linestart $i + break + } + } + if {$linestart == -1} { + error "Line with range in chunk spanning start index $chunkstart not found" + } + set lineend -1 + for {set i [expr {[llength $o_payloadlist] -1}]} {$i >=0} {incr i -1} { + if {($chunkend >= [dict get $o_linemap $i start]) && ($chunkend <= [dict get $o_linemap $i end])} { + set lineend $i + break + } + } + if {$lineend == -1} { + error "Line with range spanning end index $chunkend not found" + } + return [list $linestart $lineend] + } + method chunkrange_to_lineinfolist {chunkstart chunkend args} { + #*** !doctools + #[call class::textinfo [method chunkrange_to_lineinfolist] [arg chunkstart] [arg chunkend] [opt {option value...}]] + #[para]Return a list of dicts each with structure like the result of the [method lineinfo] method - but possibly with extra keys for truncation information if -show_truncated 1 is supplied + #[para]The truncation key in a lineinfo dict may be returned for first and/or last line in the resulting list. + #[para]truncation shows the shortened (missing bytes on left and/or right side) part of the entire line (potentially including line-ending or even partial line-ending) + #[para]Note that this truncation info is only in the return value of this method - and will not be reflected in [method lineinfo] queries to the main chunk. + + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + set defaults [dict create\ + -show_truncated 0\ + ] + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "chunkrange_to_lines error: unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- + set opt_show_truncated [dict get $opts -show_truncated] + # -- --- --- --- --- --- --- --- + + set infolist [list] + set linerange [my chunkrange_to_linerange $chunkstart $chunkend] + lassign $linerange start_lineindex end_lineindex + + #if -show_truncated + #return extra keys for first and last items (which may be the same item if chunkrange is entirely within a line) + #add is_truncated 0|1 to all lines + #Even if the start/end line is not fully within the chunkrange ie truncated - the 'payload' key will contain the original untruncated data + ########################### + # first line may have payload tail truncated - or just linefeed, or even a split linefeed + ########################### + set first [dict create lineindex $start_lineindex {*}[dict get $o_linemap $start_lineindex] payload [lindex $o_payloadlist $start_lineindex]] + set start_info [dict get $o_linemap $start_lineindex] + + + if {$chunkstart > [dict get $start_info start]} { + dict set first is_truncated 1 + dict set first truncatedside [list left] ;#truncatedside is a list which may have 'right' added if last line is same as first line + } else { + dict set first is_truncated 0 + } + + if {$opt_show_truncated} { + #line1 + if {$chunkstart > [dict get $start_info start]} { + #there is lhs truncation + set payload [lindex $o_payloadlist $start_lineindex] + set line_start [dict get $start_info start] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] [dict get $start_info le]] + set payload_and_le "${payload}${le_chars}" + set split [expr {$chunkstart - $line_start}] + set truncated [string range $payload_and_le $split end] + set lhs [string range $payload_and_le 0 $split-1] + + dict set first truncated $truncated + dict set first truncatedleft $lhs + } + } + ########################### + + ########################### + # middle lines if any - no truncation + ########################### + #difference in indexes of 1 would only mean 2 items to return + set middle_list [list] + if {($end_lineindex - $start_lineindex) > 1} { + for {set i [expr {$start_lineindex +1}]} {$i <= [expr {$end_lineindex -1}] } {incr i} { + #lineindex is key into main list + lappend middle_list [dict create lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i] is_truncated 0] + } + } + ########################### + + ########################### + # tail line may have beginning or all of payload truncated - linefeed may be split if crlf + # may be same line as first line - in which case truncation at beginning as well + if {$end_lineindex == $start_lineindex} { + #same record + set end_info $start_info + + + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation + if {[dict get $first is_truncated]} { + dict set first truncatedside [list left right] + } else { + dict set first is_truncated 1 + dict set first truncatedside [list right] + } + } + + if {$opt_show_truncated} { + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation and we need to return the splits + #do rhs truncation - possibly in addition to existing lhs truncation + # ... + set payload [lindex $o_payloadlist $end_lineindex] + set line_start [dict get $end_info start] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] [dict get $end_info le]] + set payload_and_le "${payload}${le_chars}" + set split [expr {$chunkend - $line_start}] + set truncated [string range $payload_and_le 0 $split] + set rhs [string range $payload_and_le $split+1 end] + dict set first truncatedright $rhs + if {"left" ni [dict get $first truncatedside]} { + #rhs truncation only + puts "payload_and_le: $payload_and_le" + puts "LENGTH: [string length $payload_and_le]" + #--- + #--- + dict set first truncated $truncated + dict set first truncatedside [list right] + } else { + #truncated on both sides + set lhslen [string length [dict get $first truncatedleft]] + #re-truncate the truncation to reapply the original lhs truncation + set truncated [string range $truncated $lhslen end] + dict set first truncated $truncated + } + } + } + #no middle or last to append + lappend infolist $first + } else { + set last [dict create lineindex $end_lineindex {*}[dict get $o_linemap $end_lineindex] payload [lindex $o_payloadlist $end_lineindex]] + set end_info [dict get $o_linemap $end_lineindex] + + + if {$chunkend < [dict get $end_info end]} { + dict set last is_truncated 1 + dict set last truncatedside [list right] + } else { + dict set last is_truncated 0 + } + + if {$opt_show_truncated} { + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation - and last line in range is a different line to first one + set payload [lindex $o_payloadlist $end_lineindex] + set line_start [dict get $end_info start] + set line_end [dict get $end_info end] + set le [dict get $end_info le] + set le_size [dict get {lf 1 crlf 2 none 0} $le] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] $le] + set payload_and_le "${payload}${le_chars}" + + set split [expr {$chunkend - $line_start}] + set truncated [string range $payload_and_le 0 $split] + set rhs [string range $payload_and_le $split+1 end] + + dict set last truncated $truncated + dict set last truncatedright $rhs + #this has the effect that truncating the rhs by 1 can result in truncated being larger than original payload for crlf lines - as payload now sees the cr + #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' + } + } + + + lappend infolist $first + if {[llength $middle_list]} { + lappend infolist {*}$middle_list + } + lappend infolist $last + } + ########################### + #assertion all records have is_truncated key. + #assertion if is_truncated == 1 truncatedside should contain a list of either left, right or both left and right + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. + return $infolist + } + + #need to check truncations so that any split \r\n is counted precisely todo + method chunk_le_counts {chunkstart chunkend} { + set infolines [my chunkrange_to_lineinfolist $chunkstart $chunkend -show_truncated 1] + set lf_count 0 + set crlf_count 0 + set none_count 0 + foreach d $infolines { + set le [dict get $d le] + if {$le eq "lf"} { + incr lf_count + } elseif {$le eq "crlf"} { + incr crlf_count + } else { + incr none_count + } + } + #even without split crlf - this can overcount by counting the lf or crlf in a line which had an ending not in the chunk range specified + + #check first and last infoline for truncations + #Also check if the truncation is directly between an crlf + #both an lhs split and an rhs split could land between cr and lf + #to be precise - we should presumably count the part within our chunk as either a none for cr or an lf + #This means a caller counting chunk by chunk using this method will sometimes get the wrong answer depending on where crlfs lie relative to their chosen chunk size + #This is presumably ok - as it should be a well known thing to watch out for. + #If we're only receiving chunk by chunk we can't reliably detect splits vs lone s in the data + #There are surely more efficient ways for a caller to count line-endings in the way that makes sense for them + #but we should makes things as easy as possible for users of this line/chunk structure anyway. + + set first [lindex $infolines 0] + if {[dict get $first is_truncated]} { + #could be the only line - and truncated at one or both ends. + #both a left and a right truncation could split a crlf + + } + set last [lindex $infolines end] + if {[dict get $first lineindex] != [dict get $last lineindex]} { + #only need to process last if it is a different line + #if so - then split can only be left side + + } + + + return [dict create lf $lf_count crlf $crlf_count unterminated $none_count warning line_ending_splits_unimplemented] + } + + #todo - test last line and merge as necessary with first line from new chunk - generate line data only for appended chunk + method append_chunk {rawchunk} { + error "sorry - unimplemented" + } + + method numeric_linerange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method numeric_linerange] [arg startidx] [arg endidx]] + #[para]A helper to return any Tcl-style end end-x values given to startidx or endidx; converted to their specific values based on the current state of the underlying line data + #[para]This is used internally by API functions such as [method line] to enable it to accept more expressive indices + return [my normalize_indices $startidx $endidx [expr {[dict size $o_linemap]-1}]] + } + method numeric_chunkrange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method numeric_chunkrange] [arg startidx] [arg endidx]] + #[para]A helper to return any Tcl-style end end-x entries supplied to startidx or endidx; converted to their specific values based on the current state of the underlying chunk data + return [my normalize_indices $startidx $endidx [expr {[string length $o_chunk]-1}]] + } + method normalize_indices {startidx endidx max} { + #*** !doctools + #[call class::textinfo [method normalize_indices] [arg startidx] [arg endidx] [arg max]] + #[para]A utility to convert some of the of Tcl-style list-index expressions such as end, end-1 etc to valid indices in the range 0 to the supplied max + #[para]Basic addition and subtraction expressions such as 4-1 5+2 are accepted + #[para]startidx higher than endidx is allowed + #[para]Unlike Tcl's index expressions - we raise an error if the calculated index is out of bounds 0 to max + set original_startidx $startidx + set original_endidx $endidx + set startidx [string map [list _ ""] $startidx] ;#don't barf on Tcl 8.7+ underscores in numbers - we can't just use expr because it will not handle end-x + set endidx [string map [list _ ""] $endidx] + if {![string is digit -strict "$startidx$endidx"]} { + foreach whichvar [list start end] { + upvar 0 ${whichvar}idx index + if {![string is digit -strict $index]} { + switch -glob -- $index { + end { + set index $max + } + "*-*" { + #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions + lassign [split $index -] A B + if {$A eq "end"} { + set index [expr {$max - $B}] + } else { + set index [expr {$A - $B}] + } + } + "*+*" { + lassign [split $index +] A B + if {$A eq "end"} { + #review - this will just result in out of bounds error in final test - as desired + #By calculating here - we will see the result in the error message - but it's probably not particularly useful - as we don't really need end+ support at all. + set index [expr {$max + $B}] + } else { + set index [expr {$A + $B}] + } + } + default { + #May be something like +2 or -0 which braced expr can hanle + #we would like to avoid unbraced expr here - as we're potentially dealing with ranges that may come from external sources. + if {[catch {expr {$index}} index]} { + #could be end+x - but we don't want out of bounds to be valid + #set it to something that the final bounds expr test can deal with + set index Inf + } + } + } + } + } + } + #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. + #show the supplied index and what it was mapped to in the error message. + if {$startidx < 0 || $startidx > $max} { + error "Bad start index '$original_startidx'. $startidx out of bounds 0 - $max" + } + if {$endidx < 0 || $endidx > $max} { + error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" + } + return [list $startidx $endidx] + } + + method regenerate_lines {args} { + #*** !doctools + #[call class::textinfo [method regenerate_lines]] + #[para]generate a list of lines from the current state of the stored raw data chunk and keep a map of line-endings indexed by lineindex + #[para]This is called automatically by the Constructor during object creation + #[para]It is exposed in the API experimentally - as chunk and line manipulation functions are considered. + #[para]TODO - review whether such manual control will be necessary/desirable + + #we don't store the actual line-endings as characters (for better layout of debug/display of data) - instead we store names lf|crlf|none + + # first split on lf - then crlf. As we've replaced with single substution chars - the order doesn't matter. + set o_payloadlist [list] + set o_linemap [dict create] + set crlf_replace [list \r\n $o_CRLF_C \n $o_LF_C] + set normalised_data [string map $crlf_replace $o_chunk] + + set lf_lines [split $normalised_data $o_LF_C] + + set idx 0 + set lf_count 0 + set crlf_count 0 + set filedata_offset 0 + set i 0 + set imax [expr {[llength $lf_lines]-1}] + foreach lfln $lf_lines { + set crlf_parts [split $lfln $o_CRLF_C] + if {[llength $crlf_parts] <= 1} { + #no crlf + set payloadlen [string length $lfln] + set le_size 1 + set le lf + if {$i == $imax} { + #no more lf segments - and no crlfs + if {$payloadlen > 0} { + #last line in split has chars - therefore there was no trailing line-ending + set le_size 0 + set le none + } else { + #empty space after last line-ending + #not really a line - we get here from splitting on our lf-replacement char + #An editor might display this pseudo-line with a line number - but we won't treat it as one here + break + } + } + lappend o_payloadlist $lfln + set linelen [expr {$payloadlen + $le_size}] + #we include line-ending in byte count for a line. + dict set o_linemap $idx [list le $le linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr lf_count + incr idx + } else { + foreach crlfpart [lrange $crlf_parts 0 end-1] { + lappend o_payloadlist $crlfpart + set payloadlen [string length $crlfpart] + set linelen [expr {$payloadlen + 2}] + dict set o_linemap $idx [list le crlf linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr crlf_count + incr idx + } + set lfpart [lindex $crlf_parts end] + set payloadlen [string length $lfpart] + if {$i == $imax} { + #no more lf segments - but we did find crlf in last (or perhaps only) lf line + #last element in our split has no le + if {$payloadlen > 0} { + set le_size 0 + set le none + } else { + #set le_size 2 + #set le crlf + break + } + } else { + #more lf segments to come + set le_size 1 + set le lf + } + + lappend o_payloadlist $lfpart + set linelen [expr {$payloadlen + $le_size}] + dict set o_linemap $idx [list le $le linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr lf_count + incr idx + } + incr i + #incr filedata_offset ;#move up 1 so start entry for next line is greater than end entry for previous line + } + set le_count [expr {$lf_count + $crlf_count}] + if {$le_count != [llength $o_payloadlist]} { + puts stderr "fileline::class::textinfo warning. regenerate_lines lf_count: $lf_count + crlf_count: $crlf_count does not equal length of lines stored: [llength $o_payloadlist]" + } + + } + method regenerate_chunk {} { + #o_payloadlist + #o_linemap + set oldsize [string length $o_chunk] + set newchunk "" + #review - what was the intention here? + puts stderr "regenerate_chunk -warning code incomplete" + dict for {idx lineinfo} $o_linemap { + #??? + #set + + } + + return [list newsize [string length $newchunk] oldsize $oldsize] + } + + + #*** !doctools + #[list_end] + } + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline { + namespace export * + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::fileline}] + #[para] Core API functions for punk::fileline + #[list_begin definitions] + + punk::args::define { + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ + "return: textinfo object instance" + -file -default {} -type existingfile + -translation -default iso8859-1 + -encoding -default "\uFFFF" + -includebom -default 0 + @values -min 0 -max 1 + } + proc get_textinfo {args} { + #*** !doctools + #[call get_textinfo [opt {option value...}] [opt datachunk]] + #[para]Returns textinfo object instance representing data in string datachunk or if -file filename supplied - data loaded from a file + #[para]The encoding used is as specified in the -encoding option - or from the Byte Order Mark (bom) at the beginning of the data + #[para]For Tcl 8.6 - encodings such as utf-16le may not be available - so the bytes are swapped appropriately depending on the platform byteOrder and encoding 'unicode' is used. + #[para]encoding defaults to utf-8 if no -encoding specified and no BOM was found + #[para]Whether -encoding was specified or not - by default the BOM characters are not retained in the line-data + #[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data + #[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered. + #[para] e.g utf-8,utf-16be, utf-16le, utf-32be, utf32-le, SCSU, BOCU-1,GB18030, UTF-EBCDIC, utf-1, utf-7 + #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is. + #[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::parse $args withid ::punk::fileline::get_textinfo]] leaders opts values + # -- --- --- --- + set opt_file [dict get $opts -file] + set opt_translation [dict get $opts -translation] + set opt_encoding [dict get $opts -encoding] + set opt_includebom [dict get $opts -includebom] + # -- --- --- --- + + 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]} { + puts stderr "Ignoring trailing argument [string length [lindex $values 0]] bytes. Not used when -file is specified" + } + } else { + set rawchunk [lindex $values 0] + } + set rawlen [string length $rawchunk] + #examine first 4 bytes for possible BOM + #big-endian BOMs + # ----------------------------------- + #EFBBBF - utf-8 reliabletxt + #FEFF - utf-16be reliabletxt + #FFFE - utf-16le reliabletxt + #0000FEFF - utf-32be reliabletxt + #FFFE0000 - utf-32le + #0000FFFE - utf-32be(2143) non-standard! (not supported) + #FEFF0000 - utf-32le(3412) non-standard! (not supported - will detect as utf-16be) + #2B2F76 - utf-7 (not supported) + #F7644C - utf-1 (not supported) + #DD736673 - UTF-EBCDIC (not supported) + #0EFEFF - SCSU (not supported) + #FBEE28 - BOCU-1 Binary Ordered Compression for Unicode (mime-compatible) - (not supported - fall back to utf-8) + #84319533 - GB18030 - Chinese gov standard (fall back to cp936 with warning if no encoding name) + # ----------------------------------- + + set first32 [string range $rawchunk 0 3] + #scan using capital H for big-endian order + set first32_be [binary scan $first32 H* maybe_bom] ;#we use H* instead of H8 for 8 nibbles (4 bytes) - because our first32 may contain less than 4 bytes - in which case we won't match + set bomid "" + set bomenc "" + set is_reliabletxt 0 ;#see http://reliabletxt.com - only utf-8 with bom, utf-16be, utf-16le, utf-32be supported as at 2024 + set startdata 0 + #todo switch -glob + if {[string match "efbbbf*" $maybe_bom]} { + set bomid utf-8 + set bomenc utf-8 + set is_reliabletxt 1 + set startdata 3 + } elseif {$maybe_bom eq "0000feff"} { + set bomid utf-32be + set bomenc utf-32be + set is_reliabletxt 1 + set startdata 4 + } elseif {$maybe_bom eq "fffe0000"} { + #Technically ambiguous - could be utf-16le bom followed by utf-16 null character (2 byte null) + puts stderr "WARNING - ambiguous BOM fffe0000 found. Treating as utf-32le - but could be utf-16le - consider manually setting -encoding or converting data to another encoding." + set bomid utf-32le + set bomenc utf-32le + set startdata 4 + } elseif {[string match "feff*" $maybe_bom]} { + set bomid utf-16be + set bomenc utf-16be + set is_reliabletxt 1 + set startdata 2 + } elseif {[string match "fffe*" $maybe_bom]} { + set bomid utf-16le + set bomenc utf-16le + set is_reliabletxt 1 + set startdata 2 + } elseif {$maybe_bom eq "0efeff"} { + set bomid scsu + set bomenc "binary" + set startdata 3 + } elseif {$maybe_bom eq "fbee28"} { + set bomid bocu-1 + 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" + 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? + } + set bomid gb18030 + set startdata 4 + } elseif {$maybe_bom eq "f7644c"} { + puts stderr "WARNING utf-1 BOM F7644C found - not supported. Falling back to binary" + set bomid utf-1 + set bomenc binary + set startdata 3 + } elseif {[string match "2b2f76*" $maybe_bom]} { + puts stderr "WARNING utf-7 BOM 2b2f76 found - not supported. Falling back to binary and leaving BOM in data!" + #review - work out how to strip bom - last 2 bits of 4th byte belong to following character + set bomid utf-7 + set bomenc binary + set startdata 0 + } + + #todo - check xml encoding attribute / html content-type + #todo - a separate chardet (https://chardet.readthedocs.io/ ) or mozilla like mechanism that can be manually called to autodetect character encoding + #This should be an explicit operation - not automatially done here unless we provide a flag for it. + + + if {$opt_includebom} { + set startdata 0 + } + + if {$opt_encoding eq "\uFFFF"} { + if {$bomenc ne "" && $bomenc ne "binary"} { + if {[package vcompare [package provide Tcl] 8.7] < 0} { + #tcl 8.6 has unicode encoding but not utf-16le etc + if {$bomenc ni [encoding names]} { + if {$bomenc eq "utf-16le"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } else { + set datachunk [encoding convertfrom unicode [system::wordswap16 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 16)" + } + } elseif {$bomenc eq "utf-16be"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [system::wordswap16 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 16)" + } else { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } + } elseif {$bomenc eq "utf-32le"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } else { + set datachunk [encoding convertfrom unicode [system::wordswap32 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 32)" + } + } elseif {$bomenc eq "utf-32be"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [system::wordswap32 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 32)" + } else { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } + } else { + error "Encoding $bomenc unavailable in this version of Tcl" + } + } else { + set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] + set encoding_selected $bomenc + } + } else { + #tcl 8.7 plus has utf-16le etc + set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] + set encoding_selected $bomenc + } + } else { + #!? + if {$bomenc eq "binary"} { + set datachunk [string range $rawchunk $startdata end] + set encoding_selected binary + } else { + set datachunk [encoding convertfrom utf-8 [string range $rawchunk $startdata end]] + set encoding_selected utf-8 + } + } + } else { + #manually specified encoding overrides bom - but still remove bom-chars REVIEW + #e.g we still want bom info - but specify binary encoding + + if {$opt_encoding eq "binary"} { + set datachunk [string range $rawchunk $startdata end] + } else { + set datachunk [encoding convertfrom $opt_encoding [string range $rawchunk $startdata end]] + } + set encoding_selected $opt_encoding + } + + set textobj [class::textinfo new $datachunk] + if {$bomid ne ""} { + $textobj set_bomid $bomid + } + + + + + set summary "" + append summary "Bytes loaded : $rawlen" \n + append summary "BOM ID : $bomid" \n + append summary "Encoding selected : $encoding_selected" \n + append summary "Characters : [$textobj chunklen]" \n + append summary "Lines recognised : [$textobj linecount]" \n + set leinfo [$textobj chunk_le_counts 0 end] + append summary "crlf endings (windows) : [dict get $leinfo crlf]" \n + append summary "lf endings (unix) : [dict get $leinfo lf]" \n + append summary "unterminated lines : [dict get $leinfo unterminated]" \n + puts stdout $summary + return $textobj + } + + proc file_boundary_display {filename startbyte endbyte chunksize args} { + set fd [open $filename r] ;#use default error if file not readable + chan configure $fd -translation binary + set rawfiledata [read $fd] + close $fd + set textobj [class::textinfo new $rawfiledata] + set result [$textobj chunk_boundary_display $startbyte $endbyte $chunksize {*}$args] + $textobj destroy + return $result + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline::lib { + namespace export * + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::fileline::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + + proc range_spans_chunk_boundaries {start end chunksize args} { + #*** !doctools + #[call [fun lib::range_spans_chunk_boundaries] [arg start] [arg end] [arg chunksize]] + #[para]Takes start and end offset, generally representing bytes or character indices, and computes a list of boundaries at multiples of the chunksize that are spanned by the start and end range. + #[list_begin arguments] + # [arg_def integer start] + # [para] zero-based start index of range + # [arg_def integer end] + # [para] zero-based end index of range + # [arg_def integer chunksize] + # [para] Number of bytes/characters in chunk - must be positive and > 0 + #[list_end] + #[para]returns a dict with the keys is_span and boundaries + #[para]is_span 0|1 indicates if the range specified spans a boundary of chunksize + #[para]boundaries contains a list of the spanned boundaries - which are always multiples of the chunksize + #[para]e.g + #[example_begin] + # range_spans_chunk_boundaries 10 1750 512 + # is_span 1 boundaries {512 1024 1536} + #[example_end] + #[para]The -offset option + #[example_begin] + # range_spans_chunk_boundaries 10 1750 512 -offset 2 + # is_span 1 boundaries {514 1026 1538} + #[example_end] + #[para] This function automatically uses lseq (if Tcl >= 8.7) when number of boundaries spanned is approximately greater than 75 + if {[catch {package require Tcl 8.7-}]} { + #only one implementation available for older Tcl + tailcall punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize {*}$args + } + if {$chunksize < 1} { + error "range_spans_chunk_boundaries chunksize must be >= 1" + } + + if {(abs($end - $start) / $chunksize) < 75} { + tailcall punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize {*}$args + } else { + tailcall punk::fileline::system::_range_spans_chunk_boundaries_lseq $start $end $chunksize {*}$args + } + } + + proc range_boundaries {start end chunksizes args} { + set argd [punk::args::parse $args withdef { + -offset -default 0 + }] + lassign [dict values $argd] leaders opts remainingargs + + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::fileline::system { + #*** !doctools + #[subsection {Namespace punk::fileline::system}] + #[para] Internal functions that are not part of the API + + proc wordswap16 {data} { + #scan in one endianness - format in the other. Whether we scan le/be first doesn't matter as long as we format using the opposite endianness + binary scan $data s* elements ;#scan little endian + return [binary format S* $elements] ;#format big endian + } + proc wordswap32 {data} { + binary scan $data i* elements + return [binary format I* $elements] + } + + proc scan32bit_be {i32} { + if {[binary scan $i32 I x]} { + return $x + } else { + error "couldn't scan $i32" + } + } + + #for 8.7+ using lseq + #much faster when resultant boundary size is large (at least when offset 0) + proc _range_spans_chunk_boundaries_lseq {start end chunksize args} { + if {$chunksize < 1} {error "chunksize must be > 0"} ;#sanitycheck in case called directly + set opts [dict create\ + -offset 0\ + ] + foreach {k v} $args { + switch -- $k { + -offset { + dict set opts $k $v + } + default { + error "unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- + set opt_offset [dict get $opts -offset] + # -- --- --- --- + + set smod [expr {$start % $chunksize}] + if {$smod != 0} { + set start [expr {$start + ($chunksize - $smod)}] + if {$start > $end} { + return [list is_span 0 boundaries {}] + } + } + set boundaries [lseq $start to $end $chunksize] + #offset can be negative + if {$opt_offset} { + if {$opt_offset + [lindex $boundaries end] > $end || $opt_offset + [lindex $boundaries 0] < $start} { + set overflow 1 + } else { + set overflow 0 + } + set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] + if {$overflow} { + #we don't know how many overflowed.. + set inrange [list] + foreach b $boundaries { + if {$b >= $start && $b <= $end} { + lappend inrange $b + } + } + set boundaries $inrange + } + } + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries] + } + + #faster than lseq for small number of resultant boundaries (~< 75) (which is a common use case) + #gets very slow (comparitively) with large resultsets + proc _range_spans_chunk_boundaries_tcl {start end chunksize args} { + if {$chunksize < 1} {error "chunksize must be > 0"} ;#sanitycheck in case called directly + set opts [dict create\ + -offset 0\ + ] + foreach {k v} $args { + switch -- $k { + -offset { + dict set opts $k $v + } + default { + error "unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- + set opt_offset [dict get $opts -offset] + # -- --- --- --- + + set is_span 0 + set smod [expr {$start % $chunksize}] + if {$smod != 0} { + set start [expr {$start + ($chunksize - $smod)}] + } + set boundaries [list] + + #we only need to pre-check the result-range for negative offsets - as our main loop stops before end? + if {$opt_offset < 0} { + #set btrack [expr {$start + $opt_offset}] ;#start back one to make sure we catch the first boundary + set btrack $bstart + set boff [expr {$btrack + $opt_offset}] ;#must be growing even if start and offset are negative - as chunksize is at least 1 + while {$boff < $start} { + incr btrack $chunksize + set boff [expr {$btrack + $opt_offset}] + } + set bstart $btrack + } else { + set bstart $start + } + for {set b $bstart} {[set boff [expr {$b + $opt_offset}]] <= $end} {incr b $chunksize} { + lappend boundaries $boff + } + + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries offset $opt_offset] + } + + proc _range_spans_chunk_boundaries_TIMEIT {start end chunksize {repeat 1}} { + puts "main : [time {punk::fileline::lib::range_spans_chunk_boundaries $start $end $chunksize} $repeat]" + puts "tcl : [time {punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize} $repeat]" + if {![catch {package require Tcl 8.7-}]} { + puts "lseq : [time {punk::fileline::system::_range_spans_chunk_boundaries_lseq $start $end $chunksize} $repeat]" + } + } +} +namespace eval punk::fileline::ansi { + #*** !doctools + #[subsection {Namespace punk::fileline::ansi}] + #[para]These are ansi functions imported from punk::ansi - or no-ops if that package is unavailable + #[para]See [package punk::ansi] for documentation + #[list_begin definitions] + variable enabled 1 + #*** !doctools + #[call [fun ansi::a]] + #[call [fun ansi::a+]] + #[call [fun ansi::ansistrip]] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline::ansi ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::fileline [namespace eval punk::fileline { + variable pkg punk::fileline + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm index 5ec354a7..f6242f76 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.3.tm @@ -4201,6 +4201,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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.4.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.4.tm new file mode 100644 index 00000000..a7273752 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.4.tm @@ -0,0 +1,4935 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::lib 0.1.4 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::lib 0 0.1.4] +#[copyright "2024"] +#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk library}] [comment {-- Description at end of page heading --}] +#[require punk::lib] +#[keywords module utility lib] +#[description] +#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. +#[para]The base set includes string and math functions but has no specific theme + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::lib +#[subsection Concepts] +#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. +#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::lib +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +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]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![string match ::* $extension]} { + set extension [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$extension + } + + if {![tcl::namespace::exists $extension]} { + error [list {no such namespace} $extension] + } + + set extension [tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] current]] + + tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] export *] + + while 1 { + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] + if {[tcl::namespace::which $renamed] eq {}} break + } + + rename $routine $renamed + + tcl::namespace::eval $extension [ + list namespace ensemble create -command $routine -unknown [ + list apply {{renamed ensemble routine args} { + list $renamed $routine + }} $renamed + ] + ] + + return $routine + } +} + +# 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} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + set bug true + } else { + 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 + set bug 0 + } else { + set bug [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}" + 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} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr 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] + } +} + +tcl::namespace::eval punk::lib::compat { + #*** !doctools + #[subsection {Namespace punk::lib::compat}] + #[para] compatibility functions for features that may not be available in earlier Tcl versions + #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. + #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. + + #*** !doctools + #[list_begin definitions] + + + + + if {"::lremove" ne [info commands ::lremove]} { + #puts stderr "Warning - no built-in lremove" + interp alias {} lremove {} ::punk::lib::compat::lremove + } + proc lremove {list args} { + #*** !doctools + #[call [fun lremove] [arg list] [opt {index ...}]] + #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove + + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lsearch -all -inline -index 1 -subindices $keep *] + } + #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers + proc lremove2 {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lmap v $keep {lindex $v 1}] + } + #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 + + if {![info exists ::auto_index(readFile)]} { + if {[info commands ::readFile] eq ""} { + proc ::readFile {filename {mode text}} { + #readFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + + # Read the file + set f [open $filename [dict get {text r binary rb} $mode]] + try { + return [read $f] + } finally { + close $f + } + } + } + } + if {![info exists ::auto_index(writeFile)]} { + if {[info commands ::writeFile] eq ""} { + proc ::writeFile {args} { + #writeFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + switch [llength $args] { + 2 { + lassign $args filename data + set mode text + } + 3 { + lassign $args filename mode data + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + } + default { + set COMMAND [lindex [info level 0] 0] + return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" + } + } + + # Write the File + set f [open $filename [dict get {text w binary wb} $mode]] + try { + puts -nonewline $f $data + } finally { + close $f + } + } + } + } + + if {"::lpop" ne [info commands ::lpop]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lib::compat::lpop + 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 + #[call [fun lpop] [arg listvar] [opt {index}]] + #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop + upvar $lvar l + if {![llength $args]} { + set args [list end] + } + set v [lindex $l {*}$args] + set newlist $l + + set path [list] + set subl $l + for {set i 0} {$i < [llength $args]} {incr i} { + set idx [lindex $args $i] + if {![llength [lrange $subl $idx $idx]]} { + error "tcl_lpop index \"$idx\" out of range" + } + lappend path [lindex $args $i] + set subl [lindex $l {*}$path] + } + + set sublist_path [lrange $args 0 end-1] + set tailidx [lindex $args end] + if {![llength $sublist_path]} { + #set newlist [lremove $newlist $tailidx] + set newlist [lreplace $newlist $tailidx $tailidx] + } else { + set sublist [lindex $newlist {*}$sublist_path] + #set sublist [lremove $sublist $tailidx] + set sublist [lreplace $sublist $tailidx $tailidx] + lset newlist {*}$sublist_path $sublist + } + #puts "[set l] -> $newlist" + set l $newlist + return $v + } + if {"::ledit" ni [info commands ::ledit]} { + interp alias {} ledit {} ::punk::lib::compat::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 { + -Inf { + #index below lower bound + set pre [list] + set fidx -1 + } + Inf { + #first index position is greater than index of last element in the list + set pre [lrange $l 0 end] + set fidx [llength $l] + } + default { + #set pre [lrange $l 0 $first-1] + set pre [lrange $l 0 $fidx-1] + } + } + set lidx [punk::lib::lindex_resolve [llength $l] $last] + switch -exact -- $lidx { + -Inf { + #index below lower bound + set post [lrange $l 0 end] + } + Inf { + #index above upper bound + set post [list] + } + default { + if {$lidx < $fidx} { + #from ledit man page: + #If last is less than first, then any specified elements will be inserted into the list before the element specified by first with no elements being deleted. + set post [lrange $l $fidx end] + } else { + #set post [lrange $l $last+1 end] + set post [lrange $l $lidx+1 end] + } + } + } + set l [list {*}$pre {*}$args {*}$post] + } + + + #slight isolation - varnames don't leak - but calling context vars can be affected + proc lmaptcl2 {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list ::tcl::info::vars]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result [apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + if {"::lmap" ne [info commands ::lmap]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lmap {} ::punk::lib::compat::lmaptcl + } + #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway + proc lmaptcl {varnames list script} { + set result [list] + set varlist [list] + foreach varname $varnames { + upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc + lappend varlist var_$varname + } + foreach $varlist $list { + lappend result [uplevel 1 $script] + } + return $result + } + + #tcl8.7/9 compatibility for 8.6 + if {[info commands ::tcl::string::insert] eq ""} { + #https://wiki.tcl-lang.org/page/string+insert + # Pure Tcl implementation of [string insert] command. + proc ::tcl::string::insert {string index insertString} { + # Convert end-relative and TIP 176 indexes to simple integers. + if {[regexp -expanded { + ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace + |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace + (?:([+-]) # op, omitted when index is "end" + ([+-]?\d+))? # n, omitted when index is "end" + [\t\n\v\f\r ]*$ # optional whitespace (unless "end") + } $index _ m op n]} { + # Convert first index to an integer. + switch $m { + end {set index [string length $string]} + default {scan $m %d index} + } + + # Add or subtract second index, if provided. + switch $op { + + {set index [expr {$index + $n}]} + - {set index [expr {$index - $n}]} + } + } elseif {![string is integer -strict $index]} { + # Reject invalid indexes. + return -code error "bad index \"$index\": must be\ + integer?\[+-\]integer? or end?\[+-\]integer?" + } + + # Concatenate the pre-insert, insertion, and post-insert strings. + string cat [string range $string 0 [expr {$index - 1}]] $insertString\ + [string range $string $index end] + } + + # Bind [string insert] to [::tcl::string::insert]. + tcl::namespace::ensemble configure string -map [tcl::dict::replace\ + [tcl::namespace::ensemble configure string -map]\ + insert ::tcl::string::insert] + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::lib { + variable PUNKARGS + tcl::namespace::export * + variable has_struct_list + set has_struct_list [expr {![catch {package require struct::list}]}] + variable has_struct_set + set has_struct_set [expr {![catch {package require struct::set}]}] + variable has_punk_ansi + set has_punk_ansi [expr {![catch {package require punk::ansi}]}] + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + 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] + } + + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + + # -- --- + #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists + #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 + #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows + # Review and retest as new versions come out. + # -- --- + proc list_multi_append1 {lvar1 lvar2} { + #clear winner in 2024 + upvar $lvar1 l1 $lvar2 l2 + lappend l1 {*}$l2 + return $l1 + } + proc list_multi_append2 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [list {*}$l1 {*}$l2] + } + proc list_multi_append3 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] + } + #testing e.g + #set l1_reset {a b c} + #set l2 {a b c d e f g} + #set l1 $l1_reset + #time {list_multi_append1 l1 l2} 1000 + #set l1 $l1_reset + #time {list_multi_append2 l1 l2} 1000 + # -- --- + + + proc lswap {lvar a z} { + 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 -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 -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 { + -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 { + -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 ""} { + append errmsg \n $a_msg + } + if {$z_msg ne ""} { + append errmsg \n $z_msg + } + error $errmsg + } + set item2 [lindex $l $z] + lset l $z [lindex $l $a] + lset l $a $item2 + return $l + } + #proc lswap2 {lvar a z} { + # upvar $lvar l + # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] + #} + + proc lswap2 {lvar a z} { + upvar $lvar l + #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] + } + + #an experimental test of swapping vars without intermediate variables + #It's an interesting idea - but probably of little to no practical use + # - the swap_intvars3 version using intermediate var is faster in Tcl + # - This is probably unsurprising - as it's simpler code. + # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. + #proc swap_intvars {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] + #} + #proc swap_intvars2 {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {$_x ^ $_y}] + # set _y [expr {$_x ^ $_y}] + # set _x [expr {$_x ^ $_y}] + #} + #proc swap_intvars3 {swapv1 swapv2} { + # #using intermediate variable + # upvar $swapv1 _x $swapv2 _y + # set z $_x + # set _x $_y + # set _y $z + #} + + #*** !doctools + #[subsection {Namespace punk::lib}] + #[para] Core API functions for punk::lib + #[list_begin definitions] + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + #support minimal set from to + proc range {from to} { + lseq $from $to + } + } else { + #lseq accepts basic expressions e.g 4-2 for both arguments + #e.g we can do lseq 0 [llength $list]-1 + #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. + proc range {from to} { + set to [offset_expr $to] + set from [offset_expr $from] + if {$to > $from} { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + #slower methods. + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from] + #} + #return $L + } elseif {$from > $to} { + set count [expr {$from - $to} + 1] + #1) + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from -1];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from -1] + #} + #return $L + } else { + return [list $from] + } + } + } + + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + 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-] || [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 { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + + + 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 { + #*** !doctools + #[call [fun invoke] [arg command]] + #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode + #[example { + # set script { + # puts stdout {hello on stdout} + # puts stderr {hello on stderr} + # exit 42 + # } + # invoke [list tclsh <<$script] + #}] + + #see https://wiki.tcl-lang.org/page/open + lassign [chan pipe] chanout chanin + lappend command 2>@$chanin + set fh [open |$command] + set stdout [read $fh] + close $chanin + set stderr [read $chanout] + close $chanout + if {[catch {close $fh} cres e]} { + dict with e {} + lassign [set -errorcode] sysmsg pid exit + if {$sysmsg eq {NONE}} { + #output to stderr caused [close] to fail. Do nothing + } elseif {$sysmsg eq {CHILDSTATUS}} { + return [list $stdout $stderr $exit] + } else { + return -options $e $stderr + } + } + return [list $stdout $stderr 0] + } + + proc pdict {args} { + package require punk::args + variable has_punk_ansi + if {!$has_punk_ansi} { + set sep " = " + } else { + #set sep " [a+ Web-seagreen]=[a] " + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " + } + set argspec [string map [list %sep% $sep] { + @id -id ::punk::lib::pdict + @cmd -name pdict -help\ + "Print dict keys,values to channel + The pdict function operates on variable names - passing the value to the showdict function which operates on values + (see also showdict)" + + @opts -any 1 + + #default separator to provide similarity to tcl's parray function + -separator -default "%sep%" + -roottype -default "dict" + -substructure -default {} + -channel -default stdout -help\ + "existing channel - or 'none' to return as string" + + @values -min 1 -max -1 + + dictvar -type string -help "name of variable. Can be a dict, list or array" + + patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + 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 */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segment in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + } + }] + #puts stderr "$argspec" + set argd [punk::args::parse $args withdef $argspec] + + 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 ::tcl::array::exists $dvar]] + if {$isarray} { + 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] + } + dict set opts -keysorttype dictionary + } else { + set dvalue [uplevel 1 [list set $dvar]] + } + showdict {*}$opts $dvalue {*}$patterns + } + + #TODO - much. + #showdict needs to be able to show different branches which share a root path + #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) + # - specify ansi colour per pattern so different branches can be highlighted? + # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc + # - The current version is incomplete but passably usable. + # - Copy proc and attempt rework so we can get back to this as a baseline for functionality + proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) + #set sep " [a+ Web-seagreen]=[a] " + variable has_punk_ansi + if {!$has_punk_ansi} { + set RST "" + set sep " = " + #set sep_mismatch " mismatch " + set sep \u2260 ;# equivalent [punk::ansi::convert_g0 [punk::ansi::g0 |]] (not equal symbol) + } else { + set RST [punk::ansi::a] + set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support + #set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]\u2260$RST " + } + package require punk::pipe + #package require punk ;#we need pipeline pattern matching features + package require textblock + + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + @id -id ::punk::lib::showdict + @cmd -name punk::lib::showdict -help "display dictionary keys and values" + #todo - table tableobject + -return -default "tailtohead" -choices {tailtohead sidebyside} + -channel -default none + -trimright -default 1 -type boolean -help\ + "Trim whitespace off rhs of each line. + This can help prevent a single long line that wraps in terminal from making + every line wrap due to long rhs padding." + -separator -default {%sep%} -help\ + "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help\ + "Separator to use when patterns mismatch" + -roottype -default "dict" -help\ + "list,dict,string" + -ansibase_keys -default "" -help\ + "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -substructure -default {} + -ansibase_values -default "" + -keytemplates -default {\$\{$key\}} -type list -help\ + "list of templates for keys at each level" + -keysorttype -default "none" -choices {none dictionary ascii integer real} + -keysortdirection -default increasing -choices {increasing decreasing} + -debug -default 0 -type boolean -help\ + "When enabled, produces some rudimentary debug output on stderr" + -- -type none -optional 1 + @values -min 1 -max -1 + dictvalue -type list -help\ + "dict or list value" + patterns -default "*" -type string -multiple 1 -help\ + "key or key glob pattern" + }]] + + #for punk::lib - we want to reduce pkg dependencies. + # - so we won't even use the tcllib debug pkg here + set opt_debug [dict get $argd opts -debug] + if {$opt_debug} { + if {[info body debug::showdict] eq ""} { + proc ::punk::lib::debug::showdict {args} { + catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} + } + } + } else { + if {[info body debug::showdict] ne ""} { + proc ::punk::lib::debug::showdict {args} {} + } + } + + set opt_sep [dict get $argd opts -separator] + set opt_mismatch_sep [dict get $argd opts -separator_mismatch] + set opt_keysorttype [dict get $argd opts -keysorttype] + set opt_keysortdirection [dict get $argd opts -keysortdirection] + set opt_trimright [dict get $argd opts -trimright] + set opt_keytemplates [dict get $argd opts -keytemplates] + debug::showdict "keytemplates ---> $opt_keytemplates <---" + set opt_ansibase_keys [dict get $argd opts -ansibase_keys] + set opt_ansibase_values [dict get $argd opts -ansibase_values] + set opt_return [dict get $argd opts -return] + set opt_roottype [dict get $argd opts -roottype] + set opt_structure [dict get $argd opts -substructure] + + set dval [dict get $argd values dictvalue] + set patterns [dict get $argd values patterns] + + set result "" + + #pattern hierarchy + # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest + # * @1 @0,%#,%str - segments + # a b 1 0 %# %str - keys + + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated + set pattern_next_substructure [dict create] + set pattern_this_structure [dict create] + + # -- --- --- --- + #REVIEW + #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. + #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #e.g pdict something * + #we want the keys from the result as individual lines on lhs + #e.g pdict something @@ + #we want on lhs result on rhs + # = v0 + #e.g pdict something @0-2,@4 + #we currently return: + #0 = v0 + #1 = v1 + #2 = v2 + #4 = v4 + #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) + #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. + #this is a tradeoff that could create surprises and make things messy and/or inconsistent. + #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. + #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys + #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment + #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) + # -- --- --- --- + + set filtered_keys [list] + 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 { + set keyset [list] + set keyset_structure [list] + + set segments [split $pattern_nest /] + set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns + #we need to use _split_patterns to separate (e.g to protect commas that appear within quotes) + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + #puts stderr "showdict-->_split_patterns: $patterninfo" + foreach v_idx $patterninfo { + lassign $v_idx v idx + #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) + set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern + if {[string index $p 0] eq "!"} { + set get_not 1 + set p [string range $p 1 end] + } else { + set get_not 0 + } + switch -exact -- $p { + * - "" { + if {$opt_roottype eq "list"} { + set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + dict set pattern_this_structure $p list + } elseif {$opt_roottype eq "dict"} { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } else { + lappend keyset %string + lappend keyset_structure string + dict set pattern_this_structure $p string + } + } + %# { + dict set pattern_this_structure $p string + lappend keyset %# + lappend keyset_structure string + } + # { + #todo get_not !# is test for listiness (see punk) + dict set pattern_this_structure $p list + lappend keyset # + lappend keyset_structure list + } + ## { + dict set pattern_this_structure $p dict + lappend keyset [list ## query] + lappend keyset_structure dict + } + @* { + #puts "showdict ---->@*<----" + dict set pattern_this_structure $p list + set keys [punk::lib::range 0 [llength $dval]-1] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } + @@ { + #get first k v from dict + dict set pattern_this_structure $p dict + lappend keyset [list @@ query] + lappend keyset_structure dict + } + @*k@* - @*K@* { + #returns keys only + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @*.@* { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + default { + #puts stderr "===p:$p" + #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key + switch -glob -- $p { + {@k\*@*} - {@K\*@*} { + #value glob return keys + #set search [string range $p 4 end] + #dict for {k v} $dval { + # if {[string match $search $v]} { + # lappend keyset $k + # } + #} + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @@* { + #exact match key - review - should raise error to match punk pipe behaviour? + set k [string range $p 2 end] + if {$get_not} { + if {[dict exists $dval $k]} { + set keys [dict keys [dict remove $dval $k]] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + lappend keyset {*}[dict keys $dval] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + } + } else { + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + } + dict set pattern_this_structure $p dict + } + @k@* - @K@* { + #TODO get_not + set k [string range $p 3 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict + } + {@\*@*} { + #return list of values + #set k [string range $p 3 end] + #lappend keyset {*}[dict keys $dval $k] + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*.@*} { + #TODO get_not + set k [string range $p 4 end] + set keys [dict keys $dval $k] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + {@v\*@*} - {@V\*@*} { + #value-glob return value + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*v@*} - {@\*V@*} { + #key-glob return value + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*@*} - {@\*v@*} - {@\*V@} { + #key glob return val + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @??@* { + #exact key match - no error + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + default { + set this_type $opt_roottype + if {[string match @* $p]} { + #list mode - trim optional list specifier @ + set p [string range $p 1 end] + dict set pattern_this_structure $p list + set this_type list + } elseif {[string match %* $p]} { + dict set pattern_this_structure $p string + lappend keyset $p + lappend keyset_structure string + set this_type string + } + if {$this_type eq "list"} { + dict set pattern_this_structure $p list + if {[string is integer -strict $p]} { + if {$get_not} { + set keys [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $keys $p] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + lappend keyset $p + lappend keyset_structure list + } + } elseif {[string match "?*-?*" $p]} { + #could be either - don't change type + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + #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} == 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 == -Inf} { + ##x + set lower 0 + } else { + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve [llength $dval] $b] + if {$upper == -Inf} { + ##x + #upper bound is below list range - + if {$lower_resolve > -Inf} { + ##x + set upper 0 + } else { + continue + } + } elseif {$upper == Inf} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists + } + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + set keys [punk::lib::range $lower $upper] + if {$get_not} { + set fullrange [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $fullrange {*}$keys] + if {$lower > $upper} { + set keys [lreverse $keys] + } + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + if {$get_not} { + lappend keyset [list !@$p query] + } else { + lappend keyset [list @$p query] + } + lappend keyset_structure list + } + } elseif {$this_type eq "string"} { + dict set pattern_this_structure $p string + } elseif {$this_type eq "dict"} { + #default equivalent to @\*@* + dict set pattern_this_structure $p dict + #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" + set keys [dict keys $dval $p] + if {$get_not} { + set keys [dict keys [dict remove $dval {*}$keys]] + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + puts stderr "list: unrecognised pattern $p" + } + } + } + } + } + } + + # -- --- --- --- + #check next pattern-segment for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $segments 1] + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + if {[llength $patterninfo] == 0} { + # // ? -review - what does this mean? for xpath this would mean at any level + set substructure [lindex $pattern_this_structure end] + } elseif {[llength $patterninfo] == 1} { + #ignore the NOT operator for purposes of query-type detection + if {[string index $pnext 0] eq "!"} { + set pnext [string range $pnext 1 end] + } + # single type in segment e.g /@@something/ + switch -exact -- $pnext { + "" { + set substructure string + } + @*k@* - @*K@* - @*.@* - ## { + set substructure dict + } + # { + set substructure list + } + ## { + set substructure dict + } + %# { + set substructure string + } + * { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + default { + switch -glob -- $pnext { + @??@* - @?@* - @@* { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } + default { + if {[string match @* $pnext]} { + set substructure list + } elseif {[string match %* $pnext]} { + set substructure string + } else { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + } + } + } + } + } else { + #e.g /@0,%str,.../ + #doesn't matter what the individual types are - we have a list result + set substructure list + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + if {$opt_keysorttype ne "none"} { + set int_keyset 1 + foreach k $keyset { + if {![string is integer -strict $k]} { + set int_keyset 0 + break + } + } + if {$int_keyset} { + set sortindices [lsort -indices -integer $keyset] + #set keyset [lsort -integer $keyset] + } else { + #set keyset [lsort -$opt_keysorttype $keyset] + set sortindices [lsort -indices -$opt_keysorttype $keyset] + } + set keyset [lmap i $sortindices {lindex $keyset $i}] + set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] + } + + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + + lappend filtered_keys {*}$keyset + lappend all_keyset_structure {*}$keyset_structure + + #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" + } + } + #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" + } else { + puts stdout "unrecognised roottype: $opt_roottype" + return $dval + } + + if {[llength $filtered_keys]} { + #both keys and values could have newline characters. + #simple use of 'format' won't cut it for more complex dict keys/values + #use block::width or our columns won't align in some cases + switch -- $opt_return { + "tailtohead" { + #last line of key is side by side (possibly with separator) with first line of value + #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values + #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries + + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt {${$key}} + } + #set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] + set display_keys [lmap key $filtered_keys {tstr -ret string -allowcommands $kt}] + set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] + + set kidx 0 + set last_hidekey 0 + foreach keydisplay $display_keys key $filtered_keys { + set thisval "?" + set hidekey 0 + set pattern_nest [lindex $pattern_key_index $kidx] + set pattern_nest_list [split $pattern_nest /] + #set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $key] + set this_type [lindex $all_keyset_structure $kidx] + #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" + + set is_match 1 ;#whether to display the normal separator or bad-match separator + switch -- $this_type { + dict { + #todo? - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict + # - default highlight dupes (ansi underline?) + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + % thisval.= $qry= $dval + } else { + set thisval [tcl::dict::get $dval $key] + } + + #set substructure [lrange $opt_structure 1 end] + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + + set subansibasekeys [lrange $opt_ansibase_keys 1 end] + set nextkeytemplates [lrange $opt_keytemplates 1 end] + #dict set nextopts -substructure $nextsub + dict set nextopts -keytemplates $nextkeytemplates + dict set nextopts -ansibase_keys $subansibasekeys + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" + + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + #puts stderr ">>> nextpatterns:'$nextpatterns' nextopts:'$nextopts'" + set is_match 0 + } + } + } + list { + if {[string is integer -strict $key]} { + set thisval [lindex $dval $key] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + % thisval.= $qry= $dval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + #if {![llength $nextpatterns]} { + # set nextpatterns * + #} + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + set is_match 0 + } + } + } + string { + set hidekey 1 + if {$key eq "%string"} { + set hidekey 1 + set thisval $dval + } elseif {$key eq "%ansiview"} { + set thisval [ansistring VIEW -lf 1 $dval] + } elseif {$key eq "%ansiviewstyle"} { + set thisval [ansistring VIEWSTYLE -lf 1 $dval] + } elseif {[string match *lpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which left -width $width] + } elseif {[string match *lpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which left -width $width -padchar $extra] + } elseif {[string match *rpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which right -width $width] + } elseif {[string match *rpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which right -width $width -padchar $extra] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + set thisval $dval + if {[string index $key 0] ne "%"} { + set key %$key + } + % thisval.= $key= $thisval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + #set nextopts [dict get $argd opts] + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + if {[llength $nextpatterns]} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + + } + } + if {$this_type eq "string" && $hidekey} { + lassign [textblock::size $thisval] _vw vwidth _vh vheight + #set blanks_above [string repeat \n [expr {$kheight -1}]] + set vblock $opt_ansibase_values$thisval$RST + #append result [textblock::join_basic -- $vblock] + #review - we wouldn't need this space if we had a literal %sp %sp-x ?? + append result " $vblock" + } else { + set ansibase_key [lindex $opt_ansibase_keys 0] + + lassign [textblock::size $keydisplay] _kw kwidth _kh kheight + lassign [textblock::size $thisval] _vw vwidth _vh vheight + + set totalheight [expr {$kheight + $vheight -1}] + set blanks_above [string repeat \n [expr {$kheight -1}]] + set blanks_below [string repeat \n [expr {$vheight -1}]] + + if {$is_match} { + set use_sep $opt_sep + } else { + set use_sep $opt_mismatch_sep + } + + + set sepwidth [textblock::width $use_sep] + set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] + set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] + set vblock $blanks_above$opt_ansibase_values$thisval$RST + #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace + if {$last_hidekey} { + append result \n + } + #append result [textblock::join_basic -- $kblock $sblock $vblock] \n + append result [textblock::join_basic_raw $kblock $sblock $vblock] \n + } + set last_hidekey $hidekey + incr kidx + } + } + "sidebyside" { + # TODO - fix + #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. + #use ansibase_key etc to make the output more comprehensible in that situation. + #This is why it is not the default. (review - terminal width detection and wrapping?) + set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] + foreach key $filtered_keys { + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST + #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n + #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic + append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n + } + } + } + } + if {$opt_trimright} { + set result [::join [lines_as_list -line trimright $result] \n] + } + if {[string last \n $result] == [string length $result]-1} { + set result [string range $result 0 end-1] + } + #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) + set chan [dict get $argd opts -channel] + switch -- $chan { + stderr - stdout { + puts $chan $result + } + none { + return $result + } + default { + #review - check member of chan names? + #just try outputting to the supplied channel for now + puts $chan $result + } + } + } + + proc is_list_all_in_list {small large} { + if {[llength $small] > [llength $large]} {return 0} + foreach x $large { + ::set ($x) {} + } + foreach x $small { + if {![info exists ($x)]} { + return 0 + } + } + return 1 + } + #v2 generally seems slower + proc is_list_all_in_list2 {small large} { + set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] + return [struct::list equal [lsort $small] $small_in_large] + } + if {!$has_struct_list || !$has_struct_set} { + set body { + package require struct::list + package require struct::set + } + append body [info body is_list_all_in_list2] + proc is_list_all_in_list2 {small large} $body + } + + proc is_list_all_ni_list {A B} { + foreach x $B { + ::set ($x) {} + } + foreach x $A { + if {[info exists ($x)]} { + return 0 + } + } + return 1 + } + proc is_list_all_ni_list2 {a b} { + set i [struct::set intersect $a $b] + return [expr {[llength $i] == 0}] + } + if {!$has_struct_set} { + set body { + package require struct::list + } + append body [info body is_list_all_ni_list2] + proc is_list_all_ni_list2 {a b} $body + } + + #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist + #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, + # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) + proc ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + #with ledit (also avail in 8.6 using punk::lib::compat::ledit + proc ldiff2 {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + foreach item $removeitems { + set posns [lsearch -all -exact $fromlist $item] + foreach p $posns {ledit fromlist $p $p} + } + return $fromlist + } + proc ldiff3 {fromlist removeitems} { + set doomed [list] + foreach item $removeitems { + lappend doomed {*}[lsearch -all -exact $fromlist $item] + } + lremove $fromlist {*}$doomed + } + + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) + #also struct::set difference with critcl is faster + proc setdiff {A B} { + if {[llength $A] == 0} {return {}} + set d [dict create] + foreach x $A {dict set d $x {}} + foreach x $B {dict unset d $x} + return [dict keys $d] + } + #bulk dict remove is slower than a foreach with dict unset + #proc setdiff2 {fromlist removeitems} { + # #if {[llength $fromlist] == 0} {return {}} + # set d [dict create] + # foreach x $fromlist { + # dict set d $x {} + # } + # return [dict keys [dict remove $d {*}$removeitems]] + #} + #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) + proc setdiff_unordered {A B} { + if {[llength $A] == 0} {return {}} + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] + } + + #default/fallback implementation + proc lunique_unordered {list} { + lunique $list + } + if {$has_struct_set} { + if {[struct::set equal [struct::set union {a a} {}] {a}]} { + proc lunique_unordered {list} { + struct::set union $list {} + } + } else { + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add + } + } + + + #order-preserving + proc lunique {list} { + set new {} + foreach item $list { + if {$item ni $new} { + lappend new $item + } + } + return $new + } + proc lunique2 {list} { + set doomed [list] + #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) + for {set i 0} {$i < [llength $list]} {} { + set item [lindex $list $i] + lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] + while {[incr i] in $doomed} {} + } + lremove $list {*}$doomed + } + #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env + proc lmapflat_closure {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + # -- --- --- + #capture - use uplevel 1 or namespace eval depending on context + set capture [uplevel 1 { + apply { varnames { + set capturevars [tcl::dict::create] + set capturearrs [tcl::dict::create] + foreach fullv $varnames { + set v [tcl::namespace::tail $fullv] + upvar 1 $v var + if {[info exists var]} { + if {(![array exists var])} { + tcl::dict::set capturevars $v $var + } else { + tcl::dict::set capturearrs capturedarray_$v [array get var] + } + } else { + #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set + } + } + return [tcl::dict::create vars $capturevars arrs $capturearrs] + } } [info vars] + } ] + # -- --- --- + set cvars [tcl::dict::get $capture vars] + set carrs [tcl::dict::get $capture arrs] + set apply_script "" + foreach arrayalias [tcl::dict::keys $carrs] { + set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { + array set %realname% [set %arrayalias%][unset %arrayalias%] + }] + } + + append apply_script [string map [list %script% $script] { + #foreach arrayalias [info vars capturedarray_*] { + # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + # array set $realname [set $arrayalias][unset arrayalias] + #} + #return [eval %script%] + %script% + }] + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ + $apply_script\ + ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] + } + return $result + } + #link version - can write to vars in calling context - but keeps varnames themselves isolated + #performance much better than capture version - but still a big price to pay for the isolation + proc lmapflat_link {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + #proc lmapflat {varnames list script} { + # concat {*}[uplevel 1 [list lmap $varnames $list $script]] + #} + #lmap can accept multiple var list pairs + proc lmapflat {args} { + concat {*}[uplevel 1 [list lmap {*}$args]] + } + proc lmapflat2 {args} { + concat {*}[uplevel 1 lmap {*}$args] + } + + #proc dict_getdef {dictValue args} { + # if {[llength $args] < 1} { + # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} + # } + # set keys [lrange $args -1 end-1] + # if {[tcl::dict::exists $dictValue {*}$keys]} { + # return [tcl::dict::get $dictValue {*}$keys] + # } else { + # return [lindex $args end] + # } + #} + if {[info commands ::tcl::dict::getdef] eq ""} { + proc dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef + } + + + #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" + #} + + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {([^+-]*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + + punk::args::define { + @id -id ::punk::lib::is_indexset + @cmd -name punk::lib::is_indexset\ + -summary\ + "Validate string is a comma-delimited 'indexset'."\ + -help\ + "Validate that a string is an 'indexset' + + An indexset consists of a comma delimited list of indexes or index-ranges. + 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') + ..10 + (index 'base' to 10) + 2..11 + (index 2 to 11) + .. + (all indices) + Common whitespace elements space,tab,newlines are 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. + + see indexset_resolve" + @values -min 1 -max 1 + indexset -type string + } + proc is_indexset {indexset} { + #collapse internal whitespace (for basic whitespace set we allow) + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] + if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} { + return 0 + } + set ranges [split $indexset ,] + foreach r $ranges { + set validateindices [list] + set rposn [string first .. $r] + if {$rposn >= 0} { + set sepsize 2 + set step 1 + } else { + #check for .n. 'stepped' range + set fdot [string first . $r] + set ldot [string last . $r] + set step [string range $r $fdot+1 $ldot-1] + #todo - allow basic mathops for step: 2+1 2+-1 etc same as tcl lindex, lseq + if {![string is integer -strict $step]} { + } + } + + if {$rposn >= 0} { + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } else { + #'range' is just an index + set validateindices [list $r] + } + foreach v $validateindices { + if {$v eq "" || $v eq "end"} {continue} + if {[string is integer -strict $v]} {continue} + if {[catch {lindex {} $v}]} { + return 0 + } + } + } + return 1 + } + #review - compare to IMAP4 methods of specifying ranges? + punk::args::define { + @id -id ::punk::lib::indexset_resolve + @cmd -name punk::lib::indexset_resolve\ + -summary\ + "Resolve an indexset to a list of integers based on supplied list or string length."\ + -help\ + "Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value. + 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. + 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 + + 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 + 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 3 + numitems -type integer + indexset -type indexset -help "comma delimited specification for indices to return" + 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] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + 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 based_max [expr {$numitems -1 + $base}] + + foreach ipart $iparts { + set ipart [string trim $ipart] + set rposn [string first .. $ipart] + if {$rposn>=0} { + #range + 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 $base} + set a [punk::lib::lindex_resolve $numitems $rawa $base] + if {$a == -Inf} { + #(was -3) + #undershot - leave negative + } elseif {$a == Inf} { + #overshot + 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 > $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 $base] + if {$b == -Inf} { + #undershot - leave negative + } 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 >= $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 >= $base && $a <= $based_max} { + #only a is in the range + if {$b < $base} { + set b $base + } else { + 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 >=$base && $b <= $based_max} { + #only b is in the range + if {$a < $base} { + set a $base + } else { + 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 < $base && $b > $base} { + #spans the range in forward order + 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 > $base && $b < $base} { + #spans the range in reverse order + 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 $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 -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\ + -summary\ + "Resolve an indexexpression to an integer based on supplied list or string length."\ + -help\ + "Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2 + to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating + whether the index was below or above the range of possible indices for the length supplied. + + Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. + This means the proc may be called with something like $x+2 end-$y etc + Sometimes the actual integer index is desired. + + 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) -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 + bounds indices, or in the case of lrange, return results anyway. + Like Tcl list commands - it will produce an error if the form of the index is not acceptable. + For empty lists/string (datalength 0), end and end+x indices are considered to be out of bounds on the upper side + - thus returning -2 + + Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. + We will get something like 10+1 - which can be resolved safely with expr + " + @values -min 2 -max 2 + datalength -type integer + index -type indexexpression + } + 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 + #[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. + #[para]This means the proc may be called with something like $x+2 end-$y etc + #[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) -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. + #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable + #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 + + #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which can be resolved safely with expr + + + #REVIEW - we need compat for 1_000 etc to handle things like toml even in 8.6? + #A basic string map means we aren't properly validating + #todo - be stricter about malformations such as 1000_ + if {![string is integer -strict 1_0]} { + #basic forward compatibility with integers such as 1_000 for 8.6.x + set index [tcl::string::map {_ {}} $index] + set len [tcl::string::map {_ {}} $len] + } + + if {![string is integer -strict $len] || $len < 0} { + 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 < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } else { + if {[string match end* $index]} { + if {$index ne "end"} { + set op [string index $index 3] + set offset [string range $index 4 end] + #note - offset could have leading + or - + # 'string is integer -strict +1' ==> true + #e.g end+-1 is valid (end++-1 is not) + if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} + if {$offset == 0} { + #(offset +0, -0 or 0 or 000 0_0 etc) + #op either + or - is irrelevant + #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}}] + 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 + } + } else { + #index is 'end' + if {$len == 0} { + #special case - 'end' with empty list - treat end like a positive number out of bounds + return Inf + } + #return [expr {$len - 1 + $base}] + return $based_max + } + } else { + #plain +- already handled above. + #we are trying to avoid evaluating unbraced expr of potentially insecure origin + #regexp must split a++b to a + +b (not a+ + b) ie first +/- is the op + if {[regexp {([^+-]*)([+-])(.*)} $index _match a op b]} { + if {[string is integer -strict $a] && [string is integer -strict $b]} { + if {$op eq "-"} { + set index [expr {$a - $b}] + } else { + set index [expr {$a + $b}] + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + if {$index < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf + } + return $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 -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] || $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 < $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}] + } + } + 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 $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 + } + 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 -Inf + } else { + return $idx + } + } + proc lindex_get {list index} { + set resultlist [lrange $list $index $index] + if {![llength $resultlist]} { + return -1 + } else { + #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. + #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator + return [tcl::dict::create value [lindex $resultlist 0]] + } + } + + proc string_splitbefore {str index} { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -Inf { + return [list "" $str] + } + Inf { + return [list $str ""] + } + } + } + return [list [string range $str 0 $index-1] [string range $str $index end]] + #scan %s stops at whitespace - not useful here. + #scan $s %${p}s%s + } + proc string_splitbefore_indices {str args} { + set parts [list $str] + set sizes [list [string length $str]] + set s 0 + foreach index $args { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -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} { + if {[lindex $sizes 0] != 0} { + ledit parts 0 0 {} [lindex $parts 0] + ledit sizes 0 0 0 [lindex $sizes 0] + } + continue + } + if {$index >= [string length $str]} { + if {[lindex $sizes end] != 0} { + ledit parts end end [lindex $parts end] {} + ledit sizes end end [lindex $sizes end] 0 + } + continue + } + set i -1 + set a 0 + foreach sz $sizes { + incr i + if {$a + $sz > $index} { + set p [lindex $parts $i] + #puts "a:$a index:$index" + if {$a == $index} { + break + } + ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end] + ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}] + break + } + incr a $sz + } + #puts "->parts:$parts" + #puts "->sizes:$sizes" + } + return $parts + } + + proc K {x y} {return $x} + #*** !doctools + #[call [fun K] [arg x] [arg y]] + #[para]The K-combinator function - returns the first argument, x and discards y + #[para]see [uri https://wiki.tcl-lang.org/page/K] + #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. + + + proc is_utf8_multibyteprefix {bytes} { + #*** !doctools + #[call [fun is_utf8_multibyteprefix] [arg str]] + #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character + #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint + #[para] Will return false for an already complete utf-8 codepoint + #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument + #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes + #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] + regexp {(?x) + ^ + (?: + [\xC0-\xDF] | #possible prefix for two-byte codepoint + [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for + ) + $ + } $bytes + } + + proc is_utf8_first {str} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + } $str + } + proc is_utf8_single {1234bytes} { + #*** !doctools + #[call [fun is_utf8_single] [arg 1234bytes]] + #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + $ + } $1234bytes + } + proc get_utf8_leading {rawbytes} { + #*** !doctools + #[call [fun get_utf8_leading] [arg rawbytes]] + #[para] return the leading portion of rawbytes that is a valid utf8 sequence. + #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint + #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. + #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. + #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics + #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned + #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes + if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + \A ( + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + + } $rawbytes completeChars]} { + return $completeChars + } + return "" + } + proc hex2dec {args} { + #*** !doctools + #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] + #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values + #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 + #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. + #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 + #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 + + set list_largeHex [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" + } + set opts [tcl::dict::create\ + -validate 1\ + -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $opts] + foreach {k v} $argopts { + tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v + } + # -- --- --- --- + set opt_validate [tcl::dict::get $opts -validate] + set opt_empty [tcl::dict::get $opts -empty_as_hex] + # -- --- --- --- + + set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] + if {$opt_validate} { + #Note appended F so that we accept list of empty strings as per the documentation + if {![string is xdigit -strict [join $list_largeHex ""]F ]} { + error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" + } + } + if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { + #mapping empty string to a value destroys any advantage of -scanonly + #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] + if {[lsearch $list_largeHex ""] >=0} { + error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" + } + } else { + set opt_empty [string trim [string map {_ ""} $opt_empty]] + if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] + set nonempty_head [lrange $list_largeHex 0 $first_empty-1] + set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] + } + + proc dec2hex {args} { + #*** !doctools + #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] + #[para]Convert a list of decimal integers to a list of hex values + #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. + #[para] -case upper|lower determines the case of the hex letters in the output + set list_decimals [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" + } + set defaults [tcl::dict::create\ + -width 1\ + -case upper\ + -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $defaults] + set fullopts [tcl::dict::create] + foreach {k v} $argopts { + tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v + } + set opts [tcl::dict::merge $defaults $fullopts] + # -- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_case [tcl::dict::get $opts -case] + set opt_empty [tcl::dict::get $opts -empty_as_decimal] + # -- --- --- --- + + + set resultlist [list] + switch -- [string tolower $opt_case] { + upper { + set spec X + } + lower { + set spec x + } + default { + error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" + } + } + set fmt "%${opt_width}.${opt_width}ll${spec}" + + set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] + if {![string is digit -strict [string map {_ ""} $opt_empty]]} { + if {[lsearch $list_decimals ""] >=0} { + error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" + } + } else { + set opt_empty [string map {_ ""} $opt_empty] + if {[set first_empty [lsearch $list_decimals ""]] >= 0} { + set nonempty_head [lrange $list_decimals 0 $first_empty-1] + set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] + } + + proc log2 x "expr {log(\$x)/[expr log(2)]}" + #*** !doctools + #[call [fun log2] [arg x]] + #[para]log base2 of x + #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time + #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) + + proc logbase {b x} { + #*** !doctools + #[call [fun logbase] [arg b] [arg x]] + #[para]log base b of x + #[para]This function uses expr's natural log and the change of base division. + #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 + expr {log($x)/log($b)} + } + proc factors {x} { + #*** !doctools + #[call [fun factors] [arg x]] + #[para]Return a sorted list of the positive factors of x where x > 0 + #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* + #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors + #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions + #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers + #[para]Comparisons were done with some numbers below 17 digits long + #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. + #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers + #but has the disadvantage of being slower for 'small' numbers and using more memory. + #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x + #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py + #[para] In other mathematical contexts zero may be considered not to divide anything. + set factors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {($x % $j) == 0} { + lappend factors $j [expr {$x / $j}] + } + incr j + } + lappend factors $x + return [lsort -unique -integer $factors] + } + proc oddFactors {x} { + #*** !doctools + #[call [fun oddFactors] [arg x]] + #[para]Return a list of odd integer factors of x, sorted in ascending order + set j 2 + set max [expr {sqrt($x)}] + set factors [list 1] + while {$j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2} { + if {$other ni $factors} { + lappend factors $other + } + } + if {$j % 2} { + if {$j ni $factors} { + lappend factors $j + } + } + } + incr j + } + return [lsort -integer -increasing $factors] + } + proc greatestFactorBelow {x} { + #*** !doctools + #[call [fun greatestFactorBelow] [arg x]] + #[para]Return the largest factor of x excluding itself + #[para]factor functions can be useful for console layout calculations + #[para]See Tcllib math::numtheory for more extensive implementations + if {$x % 2 == 0 || $x == 0} { + return [expr {$x / 2}] + } + set j 3 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {$x % $j == 0} { + return [expr {$x / $j}] + } + incr j 2 + } + return 1 + } + proc greatestOddFactorBelow {x} { + #*** !doctools + #[call [fun greatestOddFactorBelow] [arg x]] + #[para]Return the largest odd integer factor of x excluding x itself + if {$x %2 == 0} { + return [greatestOddFactor $x] + } + set j 3 + #dumb brute force - time taken to compute is wildly variable on big numbers + #todo - use a (memoized?) generator of primes to reduce the search space + #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. + set god 1 + set max [expr {sqrt($x)}] + while { $j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2 == 0} { + set god $j + } else { + set god [expr {$x / $j}] + #lowest j - so other side must be highest + break + } + } + incr j 2 + } + return $god + } + proc greatestOddFactor {x} { + #*** !doctools + #[call [fun greatestOddFactor] [arg x]] + #[para]Return the largest odd integer factor of x + #[para]For an odd value of x - this will always return x + if {$x % 2 != 0 || $x == 0} { + return $x + } + set r [expr {$x / 2}] + while {$r % 2 == 0} { + set r [expr {$r / 2}] + } + return $r + } + proc gcd {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the greatest common divisor of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para]Graphical use: + #[para]An a by b rectangle can be covered with square tiles of side-length c, + #[para]only if c is a common divisor of a and b + + # + # Apply Euclid's good old algorithm + # + if { $n > $m } { + set t $n + set n $m + set m $t + } + + while { $n > 0 } { + set r [expr {$m % $n}] + set m $n + set n $r + } + + return $m + } + proc lcm {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the lowest common multiple of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para] + set gcd [gcd $n $m] + return [expr {$n*$m/$gcd}] + } + proc commonDivisors {x y} { + #*** !doctools + #[call [fun commonDivisors] [arg x] [arg y]] + #[para]Return a list of all the common factors of x and y + #[para](equivalent to factors of their gcd) + return [factors [gcd $x $y]] + } + + #experimental only - there are better/faster ways + proc sieve n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + tcl::dict::for {next -} $nums break + } + return [concat $primes [tcl::dict::keys $nums]] + } + proc sieve2 n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + #dict for {next -} $nums break + set next [lindex $nums 0] + } + return [concat $primes [tcl::dict::keys $nums]] + } + + proc hasglobs {str} { + #*** !doctools + #[call [fun hasglobs] [arg str]] + #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] + #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. + regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving + } + + proc trimzero {number} { + #*** !doctools + #[call [fun trimzero] [arg number]] + #[para]Return number with left-hand-side zeros trimmed off - unless all zero + #[para]If number is all zero - a single 0 is returned + set trimmed [string trimleft $number 0] + if {[string length $trimmed] == 0} { + set trimmed 0 + } + return $trimmed + } + proc substring_count {str substring} { + #*** !doctools + #[call [fun substring_count] [arg str] [arg substring]] + #[para]Search str and return number of occurrences of substring + + #faster than lsearch on split for str of a few K + if {$substring eq ""} {return 0} + set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] + return [expr {$occurrences / [string length $substring]}] + } + + proc dict_merge_ordered {defaults main} { + #*** !doctools + #[call [fun dict_merge_ordered] [arg defaults] [arg main]] + #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. + #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. + #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. + + #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] + } + + proc askuser {question} { + #*** !doctools + #[call [fun askuser] [arg question]] + #[para]A basic utility to read an answer from stdin + #[para]The prompt is written to the terminal and then it waits for a user to type something + #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. + #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. + #[para](Generic terminal raw vs linemode detection not yet present) + #[para]The user must hit enter to submit the response + #[para]The return value is the string if any that was typed prior to hitting enter. + #[para]The question argument can be manually colourised using the various punk::ansi funcitons + #[example_begin] + # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] + # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { + # puts "Proceeding" + # } else { + # puts "Cancelled by user" + # } + #[example_end] + puts stdout $question + flush stdout + set stdin_state [chan configure stdin] + if {[catch { + package require punk::console + set console_raw [tsv::get console is_raw] + } err_console]} { + #assume normal line mode + set console_raw 0 + } + try { + chan configure stdin -blocking 1 + if {$console_raw} { + punk::console::disableRaw + set answer [gets stdin] + punk::console::enableRaw + } else { + set answer [gets stdin] + } + } finally { + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] + } + return $answer + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text {max -1}} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + if {$max != -1} { + set len [expr {min($len,$max)}] + } + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + #e.g linesort -decreasing $data + proc linesort {args} { + #*** !doctools + #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] + #[para]Sort lines in textblock + #[para]Returns another textblock with lines sorted + #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique + if {[llength $args] < 1} { + error "linesort missing lines argument" + } + set lines [lindex $args end] + set opts [lrange $args 0 end-1] + #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts + list_as_lines [lsort {*}$opts [linelist $lines]] + } + + proc list_as_lines {args} { + #*** !doctools + #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] + #[para]This simply joins the elements of the list with -joinchar + #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines + #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. + if {[set eop [lsearch $args --]] == [llength $args]-2} { + #end-of-opts not really necessary - except for consistency with lines_as_list + set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] + } + if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { + set joinchar [lindex $args 1] + set lines [lindex $args 2] + } elseif {[llength $args] == 1} { + set joinchar "\n" + set lines [lindex $args 0] + } else { + error "list_as_lines usage: list_as_lines ?-joinchar ? " + } + return [join $lines $joinchar] + } + proc list_as_lines2 {args} { + #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? + lassign [tcl::dict::values [punk::args::parse $args withdef { + -joinchar -default \n + @values -min 1 -max 1 + }]] leaders opts values + + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] + } + + proc lines_as_list {args} { + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. + #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error + #..because we don't know what to say if there are odd numbers of args + #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work + #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway + + if {[lsearch $args "--"] == [llength $args]-2} { + set opts [lrange $args 0 end-2] + } else { + set opts [lrange $args 0 end-1] + } + #set opts [tcl::dict::merge {-block {}} $opts] + set bposn [lsearch $opts -block] + if {$bposn < 0} { + lappend opts -block {} + } + set text [lindex $args end] + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] + } + #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds + proc lines_as_list2 {args} { + #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults + #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc + #we don't have to decide what is an opt vs a value + #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) + lassign [tcl::dict::values [punk::args::parse $args withdef { + @opts -any 1 + -block -default {} + }]] leaderdict opts valuedict + tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] + } + + # important for pipeline & match_assign + # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? + # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace + set linelist_body { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + ;#package require punk::ansi + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list/detectcode_in_list will check at first level. (not intended for detecting ansi in deeper structures) + + #we use detectcode_in_list instead of detect_in_list + #detectcode_in_list will detect unclosed (or unopened) paired sequences such as PM (privacy message) + # - but the main reason is it is slightly faster. + if {![punk::ansi::ta::detectcode_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach code $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + #not sure if this handles more complex hierarchies or mixins etc. + lassign $args obj method + if {![info object isa object $obj]} { + error "show_jump_tables unable to examine '$args'. $obj is not an oo object" + } + #classes are objects too and can have direct methods + if {$method in [info object methods $obj]} { + set data [tcl::unsupported::disassemble objmethod $obj $method] + } else { + if {![info object isa class $obj]} { + set obj [info object class $obj] + } + set data [tcl::unsupported::disassemble method $obj $method] + } + } else { + error "show_jump_tables expected a procname or a class/object and method" + } + set result "" + set in_jt 0 + foreach ln [split $data \n] { + set tln [::tcl::string::trim $ln] + if {!$in_jt} { + if {[::tcl::string::match *jumpTable* $ln]} { + punk::ns::call_frame + append result $ln \n + set in_jt 1 + } + } else { + if {[::tcl::string::match Command* $tln] || [::tcl::string::match "(*) *" $tln]} { + set in_jt 0 + } else { + append result $ln \n + } + } + } + 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)}] + } + proc temperature_c_to_f {deg_celsius} { + return [expr {($deg_celsius * (9/5.0)) + 32}] + } + + proc interp_sync_package_paths {interp} { + if {![interp exists $interp]} { + error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" + } + interp eval $interp [list set ::auto_path $::auto_path] + interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} + interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] + } + + proc valcopy {obj} { + append obj2 $obj {} + } + proc set_valcopy {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_valcopy varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + + + proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { + variable has_twapi + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + set localeid [twapi::get_system_default_lcid] + } + } + #when using twapi we currently only get the localeid - not the specific defaults + #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this + set default_delim "," + set default_groupsize 3 + + set results [list] + set nums [valcopy $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list + foreach inputnum $nums { + set number [valcopy $inputnum] + #also handle tcl 8.7+ underscores in numbers + set number [string map [list _ "" , ""] $number] + #normalize e.g 2e4 -> 20000.0 + set number [expr {$number}] + + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + lappend results [twapi::format_number $number $localeid -idigits -1] + continue + } else { + #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one + #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? + if {$delim eq ""} {set delim $default_delim} + if {$groupsize eq ""} {set groupsize $default_groupsize} + lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] + continue + } + } + #todo - get configured user defaults + if {$delim eq ""} { + set delim $default_delim + } + if {$groupsize eq ""} { + set groupsize $default_groupsize + } + + lappend results [delimit_number $number $delim $groupsize] + } + + if {[llength $results] == 1} { + #keep intrep as string rather than list + return [lindex $results 0] + } + return $results + } + + + #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse + # Given a number represented as a string, insert delimiters to break it up for + # readability. Normally, the delimiter will be a comma which will be inserted every + # three digits. However, the delimiter and groupsize are optional arguments, + # permitting use in other locales. + # + # The string is assumed to consist of digits, possibly preceded by spaces, + # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* + + proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { + set number [valcopy $unformattednumber] + set number [string map {_ ""} $number] + #normalize using expr - e.g 2e4 -> 20000.0 + set number [expr {$number}] + # First, extract right hand part of number, up to and including decimal point + set point [string last "." $number]; + if {$point >= 0} { + set PostDecimal [string range $number $point+1 end]; + set PostDecimalP 1; + } else { + set point [expr {[string length $number] + 1}] + set PostDecimal ""; + set PostDecimalP 0; + } + + # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? + set ind 0; + while {[string equal [string index $number $ind] \u0020]} { + incr ind; + } + set FirstNonSpace $ind; + set LastSpace [expr {$FirstNonSpace - 1}]; + set LeadingSpaces [string range $number 0 $LastSpace]; + + # Now extract the non-fractional part of the number, omitting leading spaces. + set MainNumber [string range $number $FirstNonSpace $point-1]; + + # Insert commas into the non-fractional part. + set Length [string length $MainNumber]; + set Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; + set DelimitedMain ""; + + #First we deal with the extra stuff. + if {$Phase > 0} { + append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; + } + set FirstInGroup $Phase; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; + while {$LastInGroup < $Length} { + if {$FirstInGroup > 0} { + append DelimitedMain $delim; + } + append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; + incr FirstInGroup $GroupSize + incr LastInGroup $GroupSize + } + + # Reassemble the number. + if {$PostDecimalP} { + return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; + } else { + return [format "%s%s" $LeadingSpaces $DelimitedMain]; + } + } + + #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 + #[list_end] [comment {--- end definitions namespace punk::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} + +tcl::namespace::eval punk::lib::test { + + + +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#todo - way to generate 'internal' docs separately? +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::lib::system { + #*** !doctools + #[subsection {Namespace punk::lib::system}] + #[para] Internal functions that are not part of the API + #[list_begin definitions] + + + proc mostFactorsBelow {n} { + ##*** !doctools + #[call [fun mostFactorsBelow] [arg n]] + #[para]Find the number below $n which has the greatest number of factors + #[para]This will get slow quickly as n increases (100K = 1s+ 2024) + set most 0 + set mostcount 0 + for {set i 1} {$i < $n} {incr i} { + set fc [llength [punk::lib::factors $i]] + if {$fc > $mostcount} { + set most $i + set mostcount $fc + } + } + return [list number $most numfactors $mostcount] + } + proc factorCountBelow_punk {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [punk::lib::factors $i]] + } + return $tally + } + proc factorCountBelow_numtheory {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) + package require math::numtheory + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [math::numtheory::factors $i]] + } + return $tally + } + + proc factors2 {x} { + ##*** !doctools + #[call [fun factors2] [arg x]] + #[para]Return a sorted list of factors of x + #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. + set smallfactors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j < $max} { + if {($x % $j) == 0} { + lappend smallfactors $j + lappend largefactors [expr {$x / $j}] + } + incr j + } + #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop + if {($x % $j) == 0} { + if {$j == ($x / $j)} { + lappend smallfactors $j + } + } + return [concat $smallfactors [lreverse $largefactors] $x] + } + + + + # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command + #important - used by punk::repl + proc incomplete {partial} { + #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + #puts stderr "-->$clist<--" + set waiting [list ""] + set innerpartials [list ""] + set escaped 0 + set i 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + incr i + continue + } ;# set escaped 0 at end + set p [lindex $innerpartials end] + if {$escaped == 0} { + #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) + switch -- $c { + {"} { + if {![info complete ${p}]} { + lappend waiting {"} + lappend innerpartials "" + } else { + if {[lindex $waiting end] eq {"}} { + #this quote is endquote + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + if {![info complete ${p}$c]} { + lappend waiting {"} + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } + {[} { + if {![info complete ${p}$c]} { + lappend waiting "\]" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "{" { + if {![info complete ${p}$c]} { + lappend waiting "\}" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "}" - + default { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } else { + set p ${p}${c} + lset innerpartials end $p + } + set escaped 0 + incr i + } + set incomplete [list] + foreach w $waiting { + #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. + switch -- $w { + {"} { + lappend incomplete $w + } + {]} { + lappend incomplete "\[" + } + "{" {} + "}" { + lappend incomplete "\{" + } + } + } + set debug 0 + if {$debug} { + foreach w $waiting p $innerpartials { + puts stderr "->awaiting:'$w' partial: $p" + } + } + return $incomplete + } + #This only works for very simple cases will get confused with for example: + # {set x "a["""} + proc incomplete_naive {partial} { + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + set waiting [list] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } + if {!$escaped} { + if {$c eq {"}} { + if {[lindex $waiting end] eq {"}} { + set waiting [lrange $waiting 0 end-1] + } else { + lappend waiting {"} + } + } elseif {$c eq "\["} { + lappend waiting "\]" + } elseif {$c eq "\{"} { + lappend waiting "\}" + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + } + } + } + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + return $incomplete + } + + #get info about punk nestindex key ie type: list,dict,undetermined + # pdict devel + proc nestindex_info {args} { + set argd [punk::args::parse $args withdef { + -parent -default "" + nestindex + }] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + #??? + + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] +} + +tcl::namespace::eval punk::lib::debug { + proc showdict {args} {} +} + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::lib +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::lib [tcl::namespace::eval punk::lib { + variable pkg punk::lib + variable version + set version 0.1.4 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm index e0532e41..fea6b146 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/libunknown-0.1.tm @@ -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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm index 8e4699dc..677ad6e4 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 82756da2..4a680500 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm index f976ae57..e56da520 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl-0.1.2.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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm index 9df5ae56..a074cd76 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.1.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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm index 0b5bd298..9adb8b36 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/trie-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::trie 0 0.1.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 0.1.0 + set version 0.1.0 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm index 451ad7a5..9c44ea72 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/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/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm index d83c17d9..93e4a41c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm @@ -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/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm index d6183e2a..5e8d1a25 100644 --- a/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/argparsingtest-0.1.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/vfs/_vfscommon.vfs/modules/overtype-1.7.2.tm b/src/vfs/_vfscommon.vfs/modules/overtype-1.7.2.tm new file mode 100644 index 00000000..aa7405e2 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/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] diff --git a/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm index 3c3c2c52..592c2e18 100644 --- a/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/poshinfo-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_poshinfo 0 0.1.0] #[copyright "2024"] #[titledesc {poshinfo prompt theme tool}] [comment {-- Name section and table of contents description --}] -#[moddesc {POSH-related prompt tool}] [comment {-- Description at end of page heading --}] +#[moddesc {POSH-related prompt tool}] [comment {-- Description at end of page heading --}] #[require poshinfo] #[keywords module terminal console theme prompt {prompt theme} POSH] #[description] @@ -113,7 +113,7 @@ tcl::namespace::eval poshinfo { #*** !doctools #[subsection {Namespace poshinfo}] - #[para] Core API functions for poshinfo + #[para] Core API functions for poshinfo #[list_begin definitions] @@ -121,11 +121,11 @@ tcl::namespace::eval poshinfo { proc info_from_filename {fname} { #string based filename processing: we are deliberately avoiding test of file existence etc here if {$fname eq ""} { - error "poshinfo::info_from_filename unable to determine name from empty string" + error "poshinfo::info_from_filename unable to determine name from empty string" } if {[string first . $fname] < 0} { #theoretically we could have a file without dots - but it's more likely an error in this context - error "poshinfo::info_from_filename supplied value '$fname' doesn't look like a filename. Cowardly refusing to guess a shortname." + error "poshinfo::info_from_filename supplied value '$fname' doesn't look like a filename. Cowardly refusing to guess a shortname." } set ftail [file tail $fname] set rootname [file rootname $ftail] @@ -141,7 +141,7 @@ tcl::namespace::eval poshinfo { set shortname [join [lrange $parts 0 end-1] .] } else { if {$rootname eq "schema"} { - set type schema + set type schema } else { #review - we can't tell diff betw . and .. set type unknown @@ -181,7 +181,7 @@ tcl::namespace::eval poshinfo { dict lappend themes_dict $shortname $themeinfo } } - } + } } } return $themes_dict @@ -204,14 +204,14 @@ tcl::namespace::eval poshinfo { -format -default all -multiple 1 -choices {all yaml json}\ -help "File format of posh theme - based on file extension" -type -default all -multiple 1\ - -help "e.g omp" + -help "e.g omp" -as -default "table" -choices {list showlist dict showdict table tableobject plaintext}\ -help "return type of result" - @values -min 0 + @values -min 0 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} { @@ -226,7 +226,7 @@ tcl::namespace::eval poshinfo { set themeinfo [lindex $themeinfolist 0] if {("all" in $formats || [dict get $themeinfo format] in $formats) && ("all" in $types || [dict get $themeinfo type] in $types)} { dict set restricted_themes_dict $shortname $themeinfolist - } + } } unset themes_dict switch -- $return_as { @@ -266,7 +266,7 @@ tcl::namespace::eval poshinfo { omp {} unknown { set bg Web-red - } + } default { #we shouldn't be getting other values set bg Web-yellow @@ -274,7 +274,7 @@ tcl::namespace::eval poshinfo { } if {$posh_theme eq [file normalize $path]} { set fg web-limegreen - } + } if {"$fg$bg" ne ""} { $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fg {*}$bg] } @@ -287,7 +287,7 @@ tcl::namespace::eval poshinfo { return [join [lines_as_list -line trimline $pt] \n] } table { - set tabletext [$t print] + set tabletext [$t print] $t destroy return $tabletext } @@ -313,9 +313,16 @@ tcl::namespace::eval poshinfo::lib { #*** !doctools #[subsection {Namespace poshinfo::lib}] - #[para] Secondary functions that are part of the API + #[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 @@ -333,17 +340,17 @@ tcl::namespace::eval poshinfo::lib { #*** !doctools #[subsection {Namespace poshinfo::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 poshinfo [tcl::namespace::eval poshinfo { variable pkg poshinfo variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/proctrace-0.2.tm b/src/vfs/_vfscommon.vfs/modules/proctrace-0.2.tm new file mode 100644 index 00000000..1cb9ed93 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/proctrace-0.2.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 0.2 +# 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 0.2 +}] +return + diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 5045579b..2b2118cf 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/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/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm index 0ab37079..fb5adce3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/aliascore-0.1.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/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm index ccc6bb78..3d9988b1 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ansi-0.1.1.tm @@ -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/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm index c20e3b51..3071ebd3 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.2.1.tm @@ -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/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm index 3a74754f..3f25023e 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/moduledoc/tclcore-0.1.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/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm index e1f2a440..39eeccd2 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::console 0 0.1.1] #[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 0.1.1 + set version 0.1.1 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm index 86126a5c..ce47841f 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.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,7 +1290,8 @@ 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 + 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 @@ -1359,12 +1360,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/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.1.tm new file mode 100644 index 00000000..d0e740fa --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/fileline-0.1.1.tm @@ -0,0 +1,1739 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::fileline 0.1.1 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::fileline 0 0.1.1] +#[copyright "2024"] +#[titledesc {file line-handling utilities}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] +#[require punk::fileline] +#[keywords module text parse file encoding BOM] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para]Utilities for in-memory analysis of text file data as both line data and byte/char-counted data whilst preserving the line-endings (even if mixed) +#[para]This is important for certain text files where examining the number of chars/bytes is important +#[para]For example - windows .cmd/.bat files need some byte counting to determine if labels lie on chunk boundaries and need to be moved. +#[para]This chunk-size counting will depend on the character encoding. +#[para]Despite including the word 'file', the library doesn't necessarily deal with reading/writing to the filesystem - +#[para]The raw data can be supplied as a string, or loaded from a file using punk::fileline::get_textinfo -file +#[subsection Concepts] +#[para]A chunk of textfile data (possibly representing a whole file - but usually at least a complete set of lines) is loaded into a punk::fileline::class::textinfo instance at object creation. +#[example_begin] +# package require punk::fileline +# package require fileutil +# set rawdata [lb]fileutil::cat data.txt -translation binary[rb] +# punk::fileline::class::textinfo create obj_data $rawdata +# puts stdout [lb]obj_data linecount[rb] +#[example_end] +#[subsection Notes] +#[para]Line records are referred to by a zero-based index instead of a one-based index as is commonly used when displaying files. +#[para]This is for programming consistency and convenience, and the module user should do their own conversion to one-based indexing for line display or messaging if desired. +#[para]No support for lone carriage-returns being interpreted as line-endings. +#[para]CR line-endings that are intended to be interpreted as such should be mapped to something else before the data is supplied to this module. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages needed by punk::fileline +#[list_begin itemized] + + package require Tcl 8.6- + package require punk::args + #*** !doctools + #[item] [package {Tcl 8.6-}] + #[item] [package {punk::args}] + + + # #package require frobz + # #*** !doctools + # #[item] [package {frobz}] + +#*** !doctools +#[list_end] [comment {- end dependencies list -}] + +#*** !doctools +#[subsection {optional dependencies}] +#[para] packages that add functionality but aren't strictly required +#[list_begin itemized] + + #*** !doctools + #[item] [package {punk::ansi}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + #[item] [package {punk::char}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + #[item] [package {overtype}] + #[para] - recommended for class::textinfo [method chunk_boundary_display] + + +#*** !doctools +#[list_end] [comment {- end optional dependencies list -}] + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline::class { + namespace export * + #*** !doctools + #[subsection {Namespace punk::fileline::class}] + #[para] class definitions + if {[info commands [namespace current]::textinfo] 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}] + # } + + + #uses zero based indexing. Caller can add 1 for line numbers + oo::class create [namespace current]::textinfo { + #*** !doctools + #[enum] CLASS [class textinfo] + #[list_begin definitions] + # [para] [emph METHODS] + + variable o_chunk ;#current state + variable o_chunkop_store + variable o_lineop_store + + variable o_chunk_epoch + variable o_line_epoch + variable o_payloadlist + variable o_linemap + variable o_LF_C + variable o_CRLF_C + + + variable o_bom_id + variable o_bom + variable o_bom_map + + #review - for now we expect datachunk to be data without BOM and already encoded appropriately + #fileline::get_textinfo has support for interpreting BOM - but we currently have no way to do that for data not coming from a file + #refactor to allow that code to be called from here? + constructor {datachunk args} { + #*** !doctools + #[call class::textinfo [method constructor] [arg datachunk] [opt {option value...}]] + #[para] Constructor for textinfo object which represents a chunk or all of a file + #[para] datachunk should be passed with the file data including line-endings as-is for full functionality. ie use something like: + #[example_begin] + # chan configure $fd -translation binary + # set chunkdata [lb]read $fd[rb]] + #or + # set chunkdata [lb]fileutil::cat -translation binary[rb] + #[example_end] + #[para] when loading the data + namespace eval [namespace current] { + set nspath [namespace path] + foreach p [list ::punk::fileline ::punk::fileline::ansi] { + if {$p ni $nspath} { + lappend nspath $p + } + } + namespace path $nspath + } + + set o_bom_map [list\ + utf-8 \u00ef\u00bb\u00bf\ + utf-16be \u00fe\u00ff\ + utf-16le \u00ff\u00fe\ + utf-32be \u0000\u0000\u00fe\u00ff\ + utf-32le \u00ff\u00fe\u0000\u0000\ + utf-7 \u002b\u002f\u0076\ + utf-1 \u00f7\u0064\u004c\ + utf-ebcdic \u00dd\u0073\u0066\u0073\ + utf-scsu \u0003\u00fe\u00ff\ + utf-bocu-1 \u00fb\u00ee\u0028\ + utf-gb18030 \u0084\u0031\u0095\u0033\ + ] + set o_bom_id "" + set o_bom "" ;#review + + set o_chunk $datachunk + set o_line_epoch [list] + set o_chunk_epoch [list "fromchunkchange-at-[clock micros]"] + set crlf_lf_placeholders [list \uFFFF \uFFFE] ;#defaults - if already exist in file - error out with message + set defaults [dict create\ + -substitutionmap {}\ + -crlf_lf_placeholders $crlf_lf_placeholders\ + -userid ""\ + ] + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "[self] constructor error: unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- + set opt_substitutionmap [dict get $opts -substitutionmap] ;#review - can be done by caller - or a loadable -policy + set opt_crlf_lf_placeholders [dict get $opts -crlf_lf_placeholders] + set opt_userid [dict get $opts -userid] + # -- --- --- --- --- --- --- + + if {[llength $opt_crlf_lf_placeholders] != 2 || [string length [lindex $opt_crlf_lf_placeholders 0]] !=1 || [string length [lindex $opt_crlf_lf_placeholders 1]] !=1} { + error "textinfo::constructor error: -crlf_lf_placeholders requires a list of exactly 2 chars" + } + lassign $opt_crlf_lf_placeholders o_LF_C o_CRLF_C + if {[string first $o_LF_C $o_chunk] >=0} { + set decval [scan $o_LF_C %c] + if {$decval < 32 || $decval > 127} { + set char_desc "(decimal value $decval)" + } else { + set char_desc "'$o_LF_C' (decimal value $decval)" + } + error "textinfo::constructor error: rawfiledata already contains linefeed substitution character $char_desc specified as first element of -crlf_lf_placeholders" + } + if {[string first $o_CRLF_C $o_chunk] >=0} { + set decval [scan $o_CRLF_C %c] + if {$decval < 32 || $decval > 127} { + set char_desc "(decimal value $decval)" + } else { + set char_desc "'$o_CRLF_C' (decimal value $decval)" + } + error "textinfo::constructor error: rawfiledata already contains carriagereturn-linefeed substitution character $char_desc specified as second element of -crlf_lf_placeholders" + } + if {$o_LF_C eq $o_CRLF_C} { + puts stderr "WARNING: same substitution character used for both elements of -crlf_lf_placeholders - byte counting may be off if file contains mixed line-endings" + } + + my regenerate_lines + + } + + method set_bomid {bomid} { + if {$bomid ni [dict keys $o_bom_map]} { + error "Unrecognised bom-id $bomid. Known values: [dict keys $o_bom_map]" + } + set o_bom_id $bomid + set o_bom [dict get $o_bom_map $bomid] + } + method get_bomid {} { + return $o_bom_id + } + method get_bom {} { + return $o_bom + } + + method chunk {chunkstart chunkend} { + #*** !doctools + #[call class::textinfo [method chunk] [arg chunkstart] [arg chunkend]] + #[para]Return a range of bytes from the underlying raw chunk data. + #[para] e.g The following retrieves the entire chunk + #[para] objName chunk 0 end + return [string range $o_chunk $chunkstart $chunkend] + } + method chunklen {} { + #*** !doctools + #[call class::textinfo [method chunklen]] + #[para] Number of bytes/characters in the raw data of the file + return [string length $o_chunk] + } + method chunk_boundary_display {chunkstart chunkend chunksize args} { + #*** !doctools + #[call class::textinfo [method chunk_boundary_display]] + #[para]Returns a string displaying the boundaries at chunksize bytes between chunkstart and chunkend + #[para]Defaults to using ansi colour if punk::ansi module is available. Use -ansi 0 to disable colour + set opts [dict create\ + -ansi $::punk::fileline::ansi::enabled\ + -offset 0\ + -displaybytes 200\ + -truncatedmark "..."\ + -completemark "---"\ + -moremark " + "\ + -continuemark " > "\ + -linemaxwidth 100\ + -linebase 0\ + -limit -1\ + -boundaries {}\ + -showconfig 0\ + -boundaryheader {Boundary %i% at %b%}\ + ] + foreach {k v} $args { + switch -- $k { + -ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader { + dict set opts $k $v + } + default { + error "[self]::chunk_boundary error: unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- + set opt_ansi [dict get $opts -ansi] + set opt_offset [dict get $opts -offset] + set opt_displaybytes [dict get $opts -displaybytes] + set opt_tmark [dict get $opts -truncatedmark] + set opt_cmark [dict get $opts -completemark] + set opt_linemax [dict get $opts -linemaxwidth] + set opt_linebase [dict get $opts -linebase] + set opt_linebase [string map [list _ ""] $opt_linebase] + set opt_limit [dict get $opts -limit] ;#limit number of boundaries to display + set opt_boundaries [dict get $opts -boundaries] ;#use pre-calculated boundaries if supplied + set opt_showconfig [dict get $opts -showconfig] + set opt_boundaryheader [dict get $opts -boundaryheader] + # -- --- --- --- --- --- + package require overtype + # will require punk::char and punk::ansi + + if {"::punk::fileline::ansi::ansistrip" ne [info commands ::punk::fileline::ansi::ansistrip]} { + namespace eval ::punk::fileline::ansi { + namespace import ::punk::ansi::* + } + } + + #This mechanism for enabling/disabling ansi is a bit clumsy - prone to errors with regard to keeping in sync with any api changes in punk ansi + #It's done here to allow this to be used without the full set of punk modules and/or shell - REVIEW + + #risk of failing to reset on error + set pre_ansi_enabled $::punk::fileline::ansi::enabled + if {$opt_ansi} { + set ::punk::fileline::ansi::enabled 1 + } else { + set ::punk::fileline::ansi::enabled 0 + } + if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { + proc ::punk::fileline::a {args} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::a {*}$args + } else { + return "" + } + } + proc ::punk::fileline::a+ {args} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::a+ {*}$args + } else { + return "" + } + } + proc ::punk::fileline::ansistrip {str} { + if {$::punk::fileline::ansi::enabled} { + tailcall ::punk::fileline::ansi::ansistrip $str + } else { + return $str + } + } + } + set maxline [lindex [my chunkrange_to_linerange $chunkend $chunkend] 0] + set minline [lindex [my chunkrange_to_linerange $chunkstart $chunkstart] 0] + + #suport simple end+-int (+-)start(+-)int to set linebase to line corresponding to chunkstart or chunkend + #also simple int+int and int-int - nothing more complicated (similar to Tcl lrange etc in that regard) + #commonly this will be something like -start or -end + if {![string is integer -strict $opt_linebase]} { + set sign "" + set errunrecognised "unrecognised -linebase value '$opt_linebase'. Expected positive or negative integer or -start -start-int -start+int -end -end-int -end+int or -eof (where leading - is optional but probably desirable) " + if {[string index $opt_linebase 0] eq "-"} { + set sign - + set tail [string range $opt_linebase 1 end] + } else { + set tail [string trimleft $opt_linebase +];#ignore + + } + #todo - switch -glob -- $tail + if {[string match eof* $tail]} { + set endmath [string range $tail 3 end] + #todo endmath? + if {$tail eq "eof"} { + set lastline [lindex [my chunkrange_to_linerange end end] 0] + set linebase ${sign}$lastline + } else { + error $errunrecognised + } + } elseif {[string match end* $tail]} { + set endmath [string range $tail 3 end] + if {[string length $endmath]} { + set op [string index $endmath 0] + if {$op in {+ -}} { + set operand [string range $endmath 1 end] + if {[string is integer -strict $operand]} { + if {$op eq "+"} { + set linebase [expr {$maxline + $operand}] + } else { + set linebase [expr {$maxline - $operand}] + } + } else { + error $errunrecognised + } + } else { + error $errunrecognised + } + } else { + set linebase $maxline + } + set linebase ${sign}$linebase + } elseif {[string match start* $tail]} { + set endmath [string range $tail 5 end] + if {[string length $endmath]} { + set op [string index $endmath 0] + if {$op in {+ -}} { + set operand [string range $endmath 1 end] + if {[string is integer -strict $operand]} { + if {$op eq "+"} { + set linebase [expr {$minline + $operand}] + } else { + set linebase [expr {$minline - $operand}] + } + } else { + error $errunrecognised + } + } else { + error $errunrecognised + } + } else { + set linebase $minline + } + set linebase ${sign}$linebase + } elseif {[string match *-* $tail]} { + set extras [lassign [split $tail -] int1 int2] + if {[llength $extras]} { + error $errunrecognised + } + if {![string is integer -strict $int1] || ![string is integer -strict $int2]} { + error $errunrecognised + } + set linebase [expr {$int1 - $int2}] + set linebase ${sign}$linebase + } elseif {[string match *+* $tail]} { + set extras [lassign [split $tail +] int1 int2] + if {[llength $extras]} { + error $errunrecognised + } + if {![string is integer -strict $int1] || ![string is integer -strict $int2]} { + error $errunrecognised + } + set linebase [expr {$int1 + $int2}] + set linebase ${sign}$linebase + } else { + error $errunrecognised + } + + } else { + set linebase $opt_linebase + } + + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + + if {![llength $opt_boundaries]} { + set binfo [lib::range_spans_chunk_boundaries $chunkstart $chunkend $chunksize -offset $opt_offset] + set boundaries [dict get $binfo boundaries] + } else { + set boundaries [list] + foreach b $opt_boundaries { + if {$chunkstart <= $b && $chunkend >= $b} { + lappend boundaries [expr {$b + $opt_offset}] + } + } + } + + + if {![llength $boundaries]} { + return "No boundaries found between $chunkstart and $chunkend for chunksize $chunksize (when offset $opt_offset)" + } + if {$opt_showconfig} { + set result "chunk range $chunkstart $chunkend line range $minline $maxline linebase $linebase limit $opt_limit\n" + } else { + set result "" + } + set pre_bytes [expr {$opt_displaybytes /2}] + set post_bytes $pre_bytes + set max_bytes [expr {[my chunklen] -1}] + if {$opt_limit > 0} { + set boundaries [lrange $boundaries[unset boundaries] 0 $opt_limit-1] + } + + set i 0 + foreach b $boundaries { + if {$opt_boundaryheader ne ""} { + set j [expr {$i+1}] + append result [string map [list %b% $b %i% $i %j% $j] $opt_boundaryheader] \n + } + set low [expr {max(($b - $pre_bytes),0)}] + set high [expr {min(($b + $post_bytes),$max_bytes)}] + + set lineinfolist [my chunkrange_to_lineinfolist $low $high -show_truncated 1] + set le_map [list \r\n \r \n ] + set result_list [list] + foreach lineinfo $lineinfolist { + set lineidx [dict get $lineinfo lineindex] + + set linenum [expr {$lineidx + $linebase}] + set s [dict get $lineinfo start] + set e [dict get $lineinfo end] + + set boundarymarker "" + set displayidx "" + set linenum_display $linenum + if {$s <= $b && $e >= $b} { + set idx [expr {$b - $s}] ;#index into whole position in whole line - not so useful if we're viewing a small section of a line + set char [string index [my line $lineidx] $idx] + set char_display [string map [list \r \n ] $char] + if {[dict get $lineinfo is_truncated]} { + set tside [dict get $lineinfo truncatedside] + set truncated [dict get $lineinfo truncated] + set tlen [string length $truncated] + if {"left" in $tside} { + set tleft [dict get $lineinfo truncatedleft] + set tleftlen [string length $tleft] + set displayidx [expr {$idx - $tleftlen}] + } elseif {"right" in $tside} { + set displayidx $idx + } + } else { + set displayidx $idx + } + set boundarymarker "'[a+ green bold]$char_display[a]'@$displayidx" + set linenum_display ${linenum_display},$idx + } + + set lhs_status $opt_cmark ;#default + set rhs_status $opt_cmark ;#default + if {[dict get $lineinfo is_truncated]} { + set line [dict get $lineinfo truncated] + set tside [dict get $lineinfo truncatedside] + if {"left" in $tside && "right" in $tside } { + set lhs_status $opt_tmark + set rhs_status $opt_tmark + } elseif {"left" in $tside} { + set lhs_status $opt_tmark + } elseif {"right" in $tside} { + set rhs_status $opt_tmark + } + + + } else { + set line [my line $lineidx] + } + if {$displayidx ne ""} { + set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] + } + set displayline [string map $le_map $line] + lappend result_list [list $linenum_display $boundarymarker $lhs_status $displayline $rhs_status] + } + set title_linenum "LNUM" + set linenums [lsearch -index 0 -all -inline -subindices $result_list *] + set markers [lsearch -index 1 -all -inline -subindices $result_list *] + set lines [lsearch -index 3 -all -inline -subindices $result_list *] + set title_marker "" + set title_line "Line" + #todo - use punk::char for unicode support of wide chars etc? + set widest_linenum [tcl::mathfunc::max {*}[lmap v [concat [list $title_linenum] $linenums] {string length $v}]] + set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [ansistrip $v]}]] + set widest_status [expr {max([string length $opt_cmark], [string length $opt_tmark])}] + set widest_line [tcl::mathfunc::max {*}[lmap v [concat [list $title_line] $lines] {string length $v}]] + foreach row $result_list { + lassign $row linenum marker lhs_status line rhs_status + append result [format " %-*s " $widest_linenum $linenum] + append result [format " %-*s " $widest_marker $marker] + append result [format " %-*s " $widest_status $lhs_status] + append result [format " %-*s " $widest_line $line] + append result [format " %-*s " $widest_status $rhs_status] \n + } + incr i + } + set ::punk::fileline::ansi::enabled $pre_ansi_enabled + return $result + } + method linecount {} { + #*** !doctools + #[call class::textinfo [method linecount]] + #[para] Number of lines in the raw data of the file, counted as per the policy in effect + return [llength $o_payloadlist] + } + + + method line {lineindex} { + #*** !doctools + #[call class::textinfo [method line] [arg lineindex]] + #[para]Reconstructs and returns the raw line using the payload and per-line stored line-ending metadata + #[para]A 'line' may be returned without a line-ending if the unerlying chunk had trailing data without a line-ending (or the chunk was loaded under a non-standard -policy setting) + #[para]Whilst such data may not conform to definitions (e.g POSIX) of the terms 'textfile' and 'line' - it is useful here to represent it as a line with metadata le set to "none" + #[para]To return just the data which might more commonly be needed for dealing with lines, use the [method linepayload] method - which returns the line data minus line-ending + + lassign [my numeric_linerange $lineindex 0] lineindex + + set le [dict get $o_linemap $lineindex le] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] $le] + return [lindex $o_payloadlist $lineindex]$le_chars + } + method chunk_find_glob {globsearch args} { + #todo - use linepayload_find_glob when -ignore_lineendings is 0 - but check truncations for 1st and last line + error "unimplemented" + } + method linepayload_find_glob {globsearch args} { + #*** !doctools + #[call class::textinfo [method linepayload_find_glob] [arg globsearch] [opt {option value...}]] + #[para]Return a lineinfolist (see [method lineinfo] and [method lineinfolist]) of lines where payload matches the [arg globsearch] string + #[para]To limit the returned results use the -limit n option - where -limit 0 means return all matches. + #[para]For example: [method linepayload_find_glob] "*test*" -limit 1 + #[para]The result is always a list of lineinfo dictionaries even if one item is returned + #[para] -limitfrom can be start|end + #[para]The order of results is always the order as they occur in the data - even if -limitfrom end is specified. + #[para]-limitfrom end means that only the last -limit items are returned + #[para]Note that as glob accepts [lb]chars[rb]] to mean match any character in the set given by chars, searching for literal square brackets should be done by escaping the bracket with a backslash + #[para]This is true even if only a single square bracket is being searched for. e.g {*[lb]file*} will not find the word file followed by a left square-bracket - even though the search didn't close the square brackets. + #[para]In the above case - the literal search should be {*\[lb]file*} + + set opts [dict create\ + -limit 0\ + -strategy 1\ + -start 0\ + -end end\ + -limitfrom start\ + ] + foreach {k v} $args { + switch -- $k { + -limit - -strategy - -start - -end - -limitfrom { + dict set opts $k $v + } + default { + error "linepayload_find_glob unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_limit [dict get $opts -limit] + if {![string is integer -strict $opt_limit] || $opt_limit < 0} { + error "linepayload_find_glob -limit must be positive integer" + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_strategy [dict get $opts -strategy] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_start [dict get $opts -start] + set opt_start [expr {$opt_start}] + if {$opt_start != 0} {error "-start unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_end [dict get $opts -end] + set max_line_index [expr {[llength $o_payloadlist]-1}] + if {$opt_end eq "end"} { + set opt_end $max_line_index + } + #TODO + if {$opt_end < $max_line_index} {error "-end less than max_line_index unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_limitfrom [dict get $opts -limitfrom] + #-limitfrom start|end only + #TODO + if {$opt_limitfrom ne "start"} {error "-limitfrom unimplemented"} + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + + + set lineinfolist [list] + + if {$opt_limit == 1} { + set idx [lsearch -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + if {$idx >=0} { + set i [expr {$opt_start + $idx}] + lappend lineinfolist [list lineindex $i [dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } elseif {$opt_limit == 0} { + set indices [lsearch -all -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + foreach irel $indices { + set i [expr {$opt_start + $irel}] + lappend lineinfolist [list lineindex $i [dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } else { + #todo - auto-strategy based on limit vs number of lines + if {$opt_strategy == 0} { + set posn 0 + for {set r 0} {$r < $opt_limit} {incr r} { + set n [lsearch [lrange $o_payloadlist $posn+$opt_start end] $globsearch] + if {$n >=0} { + set irel [expr {$posn + $n}] + set i [expr {$irel + $opt_start}] + lappend lineinfolist [list lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + set posn [expr {$irel+1}] + } + } + } else { + set indices [lsearch -all -glob [lrange $o_payloadlist $opt_start $opt_end] $globsearch] + set limited [lrange $indices 0 $opt_limit-1] + foreach irel $limited { + set i [expr {$opt_start + $irel}] + lappend lineinfolist [list lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i]] + } + } + } + return $lineinfolist + } + method linepayload {lineindex} { + #*** !doctools + #[call class::textinfo [method linepayload] [arg lineindex]] + #[para]Return the text of the line indicated by the zero-based lineindex + #[para]The line-ending is not returned in the data - but is still stored against this lineindex + #[para]Line Metadata such as the line-ending for a particular line and the byte/character range it occupies within the chunk can be retrieved with the [method linemeta] method + #[para]To retrieve both the line text and metadata in a single call the [method lineinfo] method can be used + #[para]To retrieve an entire line including line-ending use the [method line] method. + lassign [my numeric_linerange $lineindex 0] lineindex + return [lindex $o_payloadlist $lineindex] + } + method linepayloads {startindex endindex} { + #*** !doctools + #[call class::textinfo [method linepayloads] [arg startindex] [arg endindex]] + #[para]Return a list of just the payloads in the specified linindex range, with no metadata. + return [lrange $o_payloadlist $startindex $endindex] + } + method linemeta {lineindex} { + #*** !doctools + #[call class::textinfo [method linemeta] [arg lineindex]] + #[para]Return a dict of the metadata for the line indicated by the zero-based lineindex + #[para]Keys returned include + #[list_begin itemized] + #[item] le + #[para] A string representing the type of line-ending: crlf|lf|none + #[item] linelen + #[para] The number of characters/bytes in the whole line including line-ending if any + #[item] payloadlen + #[para] The number of character/bytes in the line excluding line-ending + #[item] start + #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line begins + #[item] end + #[para] The zero-based index into the associated raw file data indicating at which byte/character index this line ends + #[para] This end-point corresponds to the last character of the line-ending if any - not necessarily the last character of the line's payload + #[list_end] + lassign [my numeric_linerange $lineindex 0] lineindex + dict get $o_linemap $lineindex + } + method lineinfo {lineindex} { + #*** !doctools + #[call class::textinfo [method lineinfo] [arg lineindex]] + #[para]Return a dict of the metadata and text for the line indicated by the zero-based lineindex + #[para]This returns the same info as the [method linemeta] with an added key of 'payload' which is the text of the line without line-ending. + #[para]The 'payload' value is the same as is returned from the [method linepayload] method. + lassign [my numeric_linerange $lineindex 0] lineindex ;#convert lineindex to canonical number e.g 1_000 -> 1000 end -> highest index + return [dict create lineindex $lineindex {*}[dict get $o_linemap $lineindex] payload [lindex $o_payloadlist $lineindex]] + } + method lineinfolist {startidx endidx} { + #*** !doctools + #[call class::textinfo [method lineinfolist] [arg startidx] [arg endidx]] + #[para]Returns list of lineinfo dicts for each line in line index range startidx to endidx + lassign [my numeric_linerange $startidx $endidx] startidx endidx + set chunkstart [dict get $o_linemap $startidx start] + set chunkend [dict get $o_linemap $endidx end] + set line_list [my chunkrange_to_lineinfolist $chunkstart $chunkend] ;# assertion - no need to view truncations as we've picked start and end of complete lines + #verify sanity + set l_start [lindex $line_list 0] + if {[set idx_start [dict get $l_start lineindex]] ne $startidx} { + error "lineinfolist first lineindex $idx_start doesn't match startidx $startidx" + } + set l_end [lindex $line_list end] + if {[set idx_end [dict get $l_end lineindex]] ne $endidx} { + error "lineinfolist last lineindex $idx_end doesn't match endidx $endidx" + } + return $line_list + } + + method linerange_to_chunkrange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linerange_to_chunkrange] [arg startidx] [arg endidx]] + + lassign [my numeric_linerange $startidx $endidx] startidx endidx + #inclusive range + return [list [dict get $o_linemap $startidx start] [dict get $o_linemap $endidx end]] + } + method linerange_to_chunk {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linerange_to_chunk] [arg startidx] [arg endidx]] + set chunkrange [my linerange_to_chunkrange $startidx $endidx] + return [string range $o_chunk [lindex $chunkrange 0] [lindex $chunkrange 1]] + } + method lines {startidx endidx} { + #*** !doctools + #[call class::textinfo [method lines] [arg startidx] [arg endidx]] + lassign [my numeric_linerange $startidx $endidx] startidx endidx + set linelist [list] + set le_map [dict create lf \n crlf \r\n none ""] + for {set i $startidx} {$i <= $endidx} {incr i} { + lappend linelist "[lindex $o_payloadlist $i][dict get $le_map [dict get $o_linemap $i le]]" + } + return $linelist + } + method linepayloads {startidx endidx} { + #*** !doctools + #[call class::textinfo [method linepayloads] [arg startidx] [arg endidx]] + return [lrange $o_payloadlist $startidx $endidx] + } + method chunkrange_to_linerange {chunkstart chunkend} { + #*** !doctools + #[call class::textinfo [method chunkrange_to_linerange] [arg chunkstart] [arg chunkend]] + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + + set linestart -1 + for {set i 0} {$i < [llength $o_payloadlist]} {incr i} { + if {($chunkstart >= [dict get $o_linemap $i start]) && ($chunkstart <= [dict get $o_linemap $i end])} { + set linestart $i + break + } + } + if {$linestart == -1} { + error "Line with range in chunk spanning start index $chunkstart not found" + } + set lineend -1 + for {set i [expr {[llength $o_payloadlist] -1}]} {$i >=0} {incr i -1} { + if {($chunkend >= [dict get $o_linemap $i start]) && ($chunkend <= [dict get $o_linemap $i end])} { + set lineend $i + break + } + } + if {$lineend == -1} { + error "Line with range spanning end index $chunkend not found" + } + return [list $linestart $lineend] + } + method chunkrange_to_lineinfolist {chunkstart chunkend args} { + #*** !doctools + #[call class::textinfo [method chunkrange_to_lineinfolist] [arg chunkstart] [arg chunkend] [opt {option value...}]] + #[para]Return a list of dicts each with structure like the result of the [method lineinfo] method - but possibly with extra keys for truncation information if -show_truncated 1 is supplied + #[para]The truncation key in a lineinfo dict may be returned for first and/or last line in the resulting list. + #[para]truncation shows the shortened (missing bytes on left and/or right side) part of the entire line (potentially including line-ending or even partial line-ending) + #[para]Note that this truncation info is only in the return value of this method - and will not be reflected in [method lineinfo] queries to the main chunk. + + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend + set defaults [dict create\ + -show_truncated 0\ + ] + set known_opts [dict keys $defaults] + foreach {k v} $args { + if {$k ni $known_opts} { + error "chunkrange_to_lines error: unknown option '$k'. Known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- + set opt_show_truncated [dict get $opts -show_truncated] + # -- --- --- --- --- --- --- --- + + set infolist [list] + set linerange [my chunkrange_to_linerange $chunkstart $chunkend] + lassign $linerange start_lineindex end_lineindex + + #if -show_truncated + #return extra keys for first and last items (which may be the same item if chunkrange is entirely within a line) + #add is_truncated 0|1 to all lines + #Even if the start/end line is not fully within the chunkrange ie truncated - the 'payload' key will contain the original untruncated data + ########################### + # first line may have payload tail truncated - or just linefeed, or even a split linefeed + ########################### + set first [dict create lineindex $start_lineindex {*}[dict get $o_linemap $start_lineindex] payload [lindex $o_payloadlist $start_lineindex]] + set start_info [dict get $o_linemap $start_lineindex] + + + if {$chunkstart > [dict get $start_info start]} { + dict set first is_truncated 1 + dict set first truncatedside [list left] ;#truncatedside is a list which may have 'right' added if last line is same as first line + } else { + dict set first is_truncated 0 + } + + if {$opt_show_truncated} { + #line1 + if {$chunkstart > [dict get $start_info start]} { + #there is lhs truncation + set payload [lindex $o_payloadlist $start_lineindex] + set line_start [dict get $start_info start] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] [dict get $start_info le]] + set payload_and_le "${payload}${le_chars}" + set split [expr {$chunkstart - $line_start}] + set truncated [string range $payload_and_le $split end] + set lhs [string range $payload_and_le 0 $split-1] + + dict set first truncated $truncated + dict set first truncatedleft $lhs + } + } + ########################### + + ########################### + # middle lines if any - no truncation + ########################### + #difference in indexes of 1 would only mean 2 items to return + set middle_list [list] + if {($end_lineindex - $start_lineindex) > 1} { + for {set i [expr {$start_lineindex +1}]} {$i <= [expr {$end_lineindex -1}] } {incr i} { + #lineindex is key into main list + lappend middle_list [dict create lineindex $i {*}[dict get $o_linemap $i] payload [lindex $o_payloadlist $i] is_truncated 0] + } + } + ########################### + + ########################### + # tail line may have beginning or all of payload truncated - linefeed may be split if crlf + # may be same line as first line - in which case truncation at beginning as well + if {$end_lineindex == $start_lineindex} { + #same record + set end_info $start_info + + + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation + if {[dict get $first is_truncated]} { + dict set first truncatedside [list left right] + } else { + dict set first is_truncated 1 + dict set first truncatedside [list right] + } + } + + if {$opt_show_truncated} { + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation and we need to return the splits + #do rhs truncation - possibly in addition to existing lhs truncation + # ... + set payload [lindex $o_payloadlist $end_lineindex] + set line_start [dict get $end_info start] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] [dict get $end_info le]] + set payload_and_le "${payload}${le_chars}" + set split [expr {$chunkend - $line_start}] + set truncated [string range $payload_and_le 0 $split] + set rhs [string range $payload_and_le $split+1 end] + dict set first truncatedright $rhs + if {"left" ni [dict get $first truncatedside]} { + #rhs truncation only + puts "payload_and_le: $payload_and_le" + puts "LENGTH: [string length $payload_and_le]" + #--- + #--- + dict set first truncated $truncated + dict set first truncatedside [list right] + } else { + #truncated on both sides + set lhslen [string length [dict get $first truncatedleft]] + #re-truncate the truncation to reapply the original lhs truncation + set truncated [string range $truncated $lhslen end] + dict set first truncated $truncated + } + } + } + #no middle or last to append + lappend infolist $first + } else { + set last [dict create lineindex $end_lineindex {*}[dict get $o_linemap $end_lineindex] payload [lindex $o_payloadlist $end_lineindex]] + set end_info [dict get $o_linemap $end_lineindex] + + + if {$chunkend < [dict get $end_info end]} { + dict set last is_truncated 1 + dict set last truncatedside [list right] + } else { + dict set last is_truncated 0 + } + + if {$opt_show_truncated} { + if {$chunkend < [dict get $end_info end]} { + #there is rhs truncation - and last line in range is a different line to first one + set payload [lindex $o_payloadlist $end_lineindex] + set line_start [dict get $end_info start] + set line_end [dict get $end_info end] + set le [dict get $end_info le] + set le_size [dict get {lf 1 crlf 2 none 0} $le] + set le_chars [dict get [dict create lf \n crlf \r\n none ""] $le] + set payload_and_le "${payload}${le_chars}" + + set split [expr {$chunkend - $line_start}] + set truncated [string range $payload_and_le 0 $split] + set rhs [string range $payload_and_le $split+1 end] + + dict set last truncated $truncated + dict set last truncatedright $rhs + #this has the effect that truncating the rhs by 1 can result in truncated being larger than original payload for crlf lines - as payload now sees the cr + #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' + } + } + + + lappend infolist $first + if {[llength $middle_list]} { + lappend infolist {*}$middle_list + } + lappend infolist $last + } + ########################### + #assertion all records have is_truncated key. + #assertion if is_truncated == 1 truncatedside should contain a list of either left, right or both left and right + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. + return $infolist + } + + #need to check truncations so that any split \r\n is counted precisely todo + method chunk_le_counts {chunkstart chunkend} { + set infolines [my chunkrange_to_lineinfolist $chunkstart $chunkend -show_truncated 1] + set lf_count 0 + set crlf_count 0 + set none_count 0 + foreach d $infolines { + set le [dict get $d le] + if {$le eq "lf"} { + incr lf_count + } elseif {$le eq "crlf"} { + incr crlf_count + } else { + incr none_count + } + } + #even without split crlf - this can overcount by counting the lf or crlf in a line which had an ending not in the chunk range specified + + #check first and last infoline for truncations + #Also check if the truncation is directly between an crlf + #both an lhs split and an rhs split could land between cr and lf + #to be precise - we should presumably count the part within our chunk as either a none for cr or an lf + #This means a caller counting chunk by chunk using this method will sometimes get the wrong answer depending on where crlfs lie relative to their chosen chunk size + #This is presumably ok - as it should be a well known thing to watch out for. + #If we're only receiving chunk by chunk we can't reliably detect splits vs lone s in the data + #There are surely more efficient ways for a caller to count line-endings in the way that makes sense for them + #but we should makes things as easy as possible for users of this line/chunk structure anyway. + + set first [lindex $infolines 0] + if {[dict get $first is_truncated]} { + #could be the only line - and truncated at one or both ends. + #both a left and a right truncation could split a crlf + + } + set last [lindex $infolines end] + if {[dict get $first lineindex] != [dict get $last lineindex]} { + #only need to process last if it is a different line + #if so - then split can only be left side + + } + + + return [dict create lf $lf_count crlf $crlf_count unterminated $none_count warning line_ending_splits_unimplemented] + } + + #todo - test last line and merge as necessary with first line from new chunk - generate line data only for appended chunk + method append_chunk {rawchunk} { + error "sorry - unimplemented" + } + + method numeric_linerange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method numeric_linerange] [arg startidx] [arg endidx]] + #[para]A helper to return any Tcl-style end end-x values given to startidx or endidx; converted to their specific values based on the current state of the underlying line data + #[para]This is used internally by API functions such as [method line] to enable it to accept more expressive indices + return [my normalize_indices $startidx $endidx [expr {[dict size $o_linemap]-1}]] + } + method numeric_chunkrange {startidx endidx} { + #*** !doctools + #[call class::textinfo [method numeric_chunkrange] [arg startidx] [arg endidx]] + #[para]A helper to return any Tcl-style end end-x entries supplied to startidx or endidx; converted to their specific values based on the current state of the underlying chunk data + return [my normalize_indices $startidx $endidx [expr {[string length $o_chunk]-1}]] + } + method normalize_indices {startidx endidx max} { + #*** !doctools + #[call class::textinfo [method normalize_indices] [arg startidx] [arg endidx] [arg max]] + #[para]A utility to convert some of the of Tcl-style list-index expressions such as end, end-1 etc to valid indices in the range 0 to the supplied max + #[para]Basic addition and subtraction expressions such as 4-1 5+2 are accepted + #[para]startidx higher than endidx is allowed + #[para]Unlike Tcl's index expressions - we raise an error if the calculated index is out of bounds 0 to max + set original_startidx $startidx + set original_endidx $endidx + set startidx [string map [list _ ""] $startidx] ;#don't barf on Tcl 8.7+ underscores in numbers - we can't just use expr because it will not handle end-x + set endidx [string map [list _ ""] $endidx] + if {![string is digit -strict "$startidx$endidx"]} { + foreach whichvar [list start end] { + upvar 0 ${whichvar}idx index + if {![string is digit -strict $index]} { + switch -glob -- $index { + end { + set index $max + } + "*-*" { + #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions + lassign [split $index -] A B + if {$A eq "end"} { + set index [expr {$max - $B}] + } else { + set index [expr {$A - $B}] + } + } + "*+*" { + lassign [split $index +] A B + if {$A eq "end"} { + #review - this will just result in out of bounds error in final test - as desired + #By calculating here - we will see the result in the error message - but it's probably not particularly useful - as we don't really need end+ support at all. + set index [expr {$max + $B}] + } else { + set index [expr {$A + $B}] + } + } + default { + #May be something like +2 or -0 which braced expr can hanle + #we would like to avoid unbraced expr here - as we're potentially dealing with ranges that may come from external sources. + if {[catch {expr {$index}} index]} { + #could be end+x - but we don't want out of bounds to be valid + #set it to something that the final bounds expr test can deal with + set index Inf + } + } + } + } + } + } + #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. + #show the supplied index and what it was mapped to in the error message. + if {$startidx < 0 || $startidx > $max} { + error "Bad start index '$original_startidx'. $startidx out of bounds 0 - $max" + } + if {$endidx < 0 || $endidx > $max} { + error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" + } + return [list $startidx $endidx] + } + + method regenerate_lines {args} { + #*** !doctools + #[call class::textinfo [method regenerate_lines]] + #[para]generate a list of lines from the current state of the stored raw data chunk and keep a map of line-endings indexed by lineindex + #[para]This is called automatically by the Constructor during object creation + #[para]It is exposed in the API experimentally - as chunk and line manipulation functions are considered. + #[para]TODO - review whether such manual control will be necessary/desirable + + #we don't store the actual line-endings as characters (for better layout of debug/display of data) - instead we store names lf|crlf|none + + # first split on lf - then crlf. As we've replaced with single substution chars - the order doesn't matter. + set o_payloadlist [list] + set o_linemap [dict create] + set crlf_replace [list \r\n $o_CRLF_C \n $o_LF_C] + set normalised_data [string map $crlf_replace $o_chunk] + + set lf_lines [split $normalised_data $o_LF_C] + + set idx 0 + set lf_count 0 + set crlf_count 0 + set filedata_offset 0 + set i 0 + set imax [expr {[llength $lf_lines]-1}] + foreach lfln $lf_lines { + set crlf_parts [split $lfln $o_CRLF_C] + if {[llength $crlf_parts] <= 1} { + #no crlf + set payloadlen [string length $lfln] + set le_size 1 + set le lf + if {$i == $imax} { + #no more lf segments - and no crlfs + if {$payloadlen > 0} { + #last line in split has chars - therefore there was no trailing line-ending + set le_size 0 + set le none + } else { + #empty space after last line-ending + #not really a line - we get here from splitting on our lf-replacement char + #An editor might display this pseudo-line with a line number - but we won't treat it as one here + break + } + } + lappend o_payloadlist $lfln + set linelen [expr {$payloadlen + $le_size}] + #we include line-ending in byte count for a line. + dict set o_linemap $idx [list le $le linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr lf_count + incr idx + } else { + foreach crlfpart [lrange $crlf_parts 0 end-1] { + lappend o_payloadlist $crlfpart + set payloadlen [string length $crlfpart] + set linelen [expr {$payloadlen + 2}] + dict set o_linemap $idx [list le crlf linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr crlf_count + incr idx + } + set lfpart [lindex $crlf_parts end] + set payloadlen [string length $lfpart] + if {$i == $imax} { + #no more lf segments - but we did find crlf in last (or perhaps only) lf line + #last element in our split has no le + if {$payloadlen > 0} { + set le_size 0 + set le none + } else { + #set le_size 2 + #set le crlf + break + } + } else { + #more lf segments to come + set le_size 1 + set le lf + } + + lappend o_payloadlist $lfpart + set linelen [expr {$payloadlen + $le_size}] + dict set o_linemap $idx [list le $le linelen $linelen payloadlen $payloadlen start $filedata_offset end [expr {$filedata_offset + $linelen -1}]] + incr filedata_offset $linelen + incr lf_count + incr idx + } + incr i + #incr filedata_offset ;#move up 1 so start entry for next line is greater than end entry for previous line + } + set le_count [expr {$lf_count + $crlf_count}] + if {$le_count != [llength $o_payloadlist]} { + puts stderr "fileline::class::textinfo warning. regenerate_lines lf_count: $lf_count + crlf_count: $crlf_count does not equal length of lines stored: [llength $o_payloadlist]" + } + + } + method regenerate_chunk {} { + #o_payloadlist + #o_linemap + set oldsize [string length $o_chunk] + set newchunk "" + #review - what was the intention here? + puts stderr "regenerate_chunk -warning code incomplete" + dict for {idx lineinfo} $o_linemap { + #??? + #set + + } + + return [list newsize [string length $newchunk] oldsize $oldsize] + } + + + #*** !doctools + #[list_end] + } + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline { + namespace export * + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::fileline}] + #[para] Core API functions for punk::fileline + #[list_begin definitions] + + punk::args::define { + @id -id ::punk::fileline::get_textinfo + @cmd -name punk::fileline::get_textinfo -help\ + "return: textinfo object instance" + -file -default {} -type existingfile + -translation -default iso8859-1 + -encoding -default "\uFFFF" + -includebom -default 0 + @values -min 0 -max 1 + } + proc get_textinfo {args} { + #*** !doctools + #[call get_textinfo [opt {option value...}] [opt datachunk]] + #[para]Returns textinfo object instance representing data in string datachunk or if -file filename supplied - data loaded from a file + #[para]The encoding used is as specified in the -encoding option - or from the Byte Order Mark (bom) at the beginning of the data + #[para]For Tcl 8.6 - encodings such as utf-16le may not be available - so the bytes are swapped appropriately depending on the platform byteOrder and encoding 'unicode' is used. + #[para]encoding defaults to utf-8 if no -encoding specified and no BOM was found + #[para]Whether -encoding was specified or not - by default the BOM characters are not retained in the line-data + #[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data + #[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered. + #[para] e.g utf-8,utf-16be, utf-16le, utf-32be, utf32-le, SCSU, BOCU-1,GB18030, UTF-EBCDIC, utf-1, utf-7 + #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is. + #[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::parse $args withid ::punk::fileline::get_textinfo]] leaders opts values + # -- --- --- --- + set opt_file [dict get $opts -file] + set opt_translation [dict get $opts -translation] + set opt_encoding [dict get $opts -encoding] + set opt_includebom [dict get $opts -includebom] + # -- --- --- --- + + 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]} { + puts stderr "Ignoring trailing argument [string length [lindex $values 0]] bytes. Not used when -file is specified" + } + } else { + set rawchunk [lindex $values 0] + } + set rawlen [string length $rawchunk] + #examine first 4 bytes for possible BOM + #big-endian BOMs + # ----------------------------------- + #EFBBBF - utf-8 reliabletxt + #FEFF - utf-16be reliabletxt + #FFFE - utf-16le reliabletxt + #0000FEFF - utf-32be reliabletxt + #FFFE0000 - utf-32le + #0000FFFE - utf-32be(2143) non-standard! (not supported) + #FEFF0000 - utf-32le(3412) non-standard! (not supported - will detect as utf-16be) + #2B2F76 - utf-7 (not supported) + #F7644C - utf-1 (not supported) + #DD736673 - UTF-EBCDIC (not supported) + #0EFEFF - SCSU (not supported) + #FBEE28 - BOCU-1 Binary Ordered Compression for Unicode (mime-compatible) - (not supported - fall back to utf-8) + #84319533 - GB18030 - Chinese gov standard (fall back to cp936 with warning if no encoding name) + # ----------------------------------- + + set first32 [string range $rawchunk 0 3] + #scan using capital H for big-endian order + set first32_be [binary scan $first32 H* maybe_bom] ;#we use H* instead of H8 for 8 nibbles (4 bytes) - because our first32 may contain less than 4 bytes - in which case we won't match + set bomid "" + set bomenc "" + set is_reliabletxt 0 ;#see http://reliabletxt.com - only utf-8 with bom, utf-16be, utf-16le, utf-32be supported as at 2024 + set startdata 0 + #todo switch -glob + if {[string match "efbbbf*" $maybe_bom]} { + set bomid utf-8 + set bomenc utf-8 + set is_reliabletxt 1 + set startdata 3 + } elseif {$maybe_bom eq "0000feff"} { + set bomid utf-32be + set bomenc utf-32be + set is_reliabletxt 1 + set startdata 4 + } elseif {$maybe_bom eq "fffe0000"} { + #Technically ambiguous - could be utf-16le bom followed by utf-16 null character (2 byte null) + puts stderr "WARNING - ambiguous BOM fffe0000 found. Treating as utf-32le - but could be utf-16le - consider manually setting -encoding or converting data to another encoding." + set bomid utf-32le + set bomenc utf-32le + set startdata 4 + } elseif {[string match "feff*" $maybe_bom]} { + set bomid utf-16be + set bomenc utf-16be + set is_reliabletxt 1 + set startdata 2 + } elseif {[string match "fffe*" $maybe_bom]} { + set bomid utf-16le + set bomenc utf-16le + set is_reliabletxt 1 + set startdata 2 + } elseif {$maybe_bom eq "0efeff"} { + set bomid scsu + set bomenc "binary" + set startdata 3 + } elseif {$maybe_bom eq "fbee28"} { + set bomid bocu-1 + 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" + 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? + } + set bomid gb18030 + set startdata 4 + } elseif {$maybe_bom eq "f7644c"} { + puts stderr "WARNING utf-1 BOM F7644C found - not supported. Falling back to binary" + set bomid utf-1 + set bomenc binary + set startdata 3 + } elseif {[string match "2b2f76*" $maybe_bom]} { + puts stderr "WARNING utf-7 BOM 2b2f76 found - not supported. Falling back to binary and leaving BOM in data!" + #review - work out how to strip bom - last 2 bits of 4th byte belong to following character + set bomid utf-7 + set bomenc binary + set startdata 0 + } + + #todo - check xml encoding attribute / html content-type + #todo - a separate chardet (https://chardet.readthedocs.io/ ) or mozilla like mechanism that can be manually called to autodetect character encoding + #This should be an explicit operation - not automatially done here unless we provide a flag for it. + + + if {$opt_includebom} { + set startdata 0 + } + + if {$opt_encoding eq "\uFFFF"} { + if {$bomenc ne "" && $bomenc ne "binary"} { + if {[package vcompare [package provide Tcl] 8.7] < 0} { + #tcl 8.6 has unicode encoding but not utf-16le etc + if {$bomenc ni [encoding names]} { + if {$bomenc eq "utf-16le"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } else { + set datachunk [encoding convertfrom unicode [system::wordswap16 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 16)" + } + } elseif {$bomenc eq "utf-16be"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [system::wordswap16 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 16)" + } else { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } + } elseif {$bomenc eq "utf-32le"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } else { + set datachunk [encoding convertfrom unicode [system::wordswap32 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 32)" + } + } elseif {$bomenc eq "utf-32be"} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set datachunk [encoding convertfrom unicode [system::wordswap32 [string range $rawchunk $startdata end]]] + set encoding_selected "unicode (wordswapped 32)" + } else { + set datachunk [encoding convertfrom unicode [string range $rawchunk $startdata end]] + set encoding_selected unicode + } + } else { + error "Encoding $bomenc unavailable in this version of Tcl" + } + } else { + set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] + set encoding_selected $bomenc + } + } else { + #tcl 8.7 plus has utf-16le etc + set datachunk [encoding convertfrom $bomenc [string range $rawchunk $startdata end]] + set encoding_selected $bomenc + } + } else { + #!? + if {$bomenc eq "binary"} { + set datachunk [string range $rawchunk $startdata end] + set encoding_selected binary + } else { + set datachunk [encoding convertfrom utf-8 [string range $rawchunk $startdata end]] + set encoding_selected utf-8 + } + } + } else { + #manually specified encoding overrides bom - but still remove bom-chars REVIEW + #e.g we still want bom info - but specify binary encoding + + if {$opt_encoding eq "binary"} { + set datachunk [string range $rawchunk $startdata end] + } else { + set datachunk [encoding convertfrom $opt_encoding [string range $rawchunk $startdata end]] + } + set encoding_selected $opt_encoding + } + + set textobj [class::textinfo new $datachunk] + if {$bomid ne ""} { + $textobj set_bomid $bomid + } + + + + + set summary "" + append summary "Bytes loaded : $rawlen" \n + append summary "BOM ID : $bomid" \n + append summary "Encoding selected : $encoding_selected" \n + append summary "Characters : [$textobj chunklen]" \n + append summary "Lines recognised : [$textobj linecount]" \n + set leinfo [$textobj chunk_le_counts 0 end] + append summary "crlf endings (windows) : [dict get $leinfo crlf]" \n + append summary "lf endings (unix) : [dict get $leinfo lf]" \n + append summary "unterminated lines : [dict get $leinfo unterminated]" \n + puts stdout $summary + return $textobj + } + + proc file_boundary_display {filename startbyte endbyte chunksize args} { + set fd [open $filename r] ;#use default error if file not readable + chan configure $fd -translation binary + set rawfiledata [read $fd] + close $fd + set textobj [class::textinfo new $rawfiledata] + set result [$textobj chunk_boundary_display $startbyte $endbyte $chunksize {*}$args] + $textobj destroy + return $result + } + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::fileline::lib { + namespace export * + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace punk::fileline::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + + proc range_spans_chunk_boundaries {start end chunksize args} { + #*** !doctools + #[call [fun lib::range_spans_chunk_boundaries] [arg start] [arg end] [arg chunksize]] + #[para]Takes start and end offset, generally representing bytes or character indices, and computes a list of boundaries at multiples of the chunksize that are spanned by the start and end range. + #[list_begin arguments] + # [arg_def integer start] + # [para] zero-based start index of range + # [arg_def integer end] + # [para] zero-based end index of range + # [arg_def integer chunksize] + # [para] Number of bytes/characters in chunk - must be positive and > 0 + #[list_end] + #[para]returns a dict with the keys is_span and boundaries + #[para]is_span 0|1 indicates if the range specified spans a boundary of chunksize + #[para]boundaries contains a list of the spanned boundaries - which are always multiples of the chunksize + #[para]e.g + #[example_begin] + # range_spans_chunk_boundaries 10 1750 512 + # is_span 1 boundaries {512 1024 1536} + #[example_end] + #[para]The -offset option + #[example_begin] + # range_spans_chunk_boundaries 10 1750 512 -offset 2 + # is_span 1 boundaries {514 1026 1538} + #[example_end] + #[para] This function automatically uses lseq (if Tcl >= 8.7) when number of boundaries spanned is approximately greater than 75 + if {[catch {package require Tcl 8.7-}]} { + #only one implementation available for older Tcl + tailcall punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize {*}$args + } + if {$chunksize < 1} { + error "range_spans_chunk_boundaries chunksize must be >= 1" + } + + if {(abs($end - $start) / $chunksize) < 75} { + tailcall punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize {*}$args + } else { + tailcall punk::fileline::system::_range_spans_chunk_boundaries_lseq $start $end $chunksize {*}$args + } + } + + proc range_boundaries {start end chunksizes args} { + set argd [punk::args::parse $args withdef { + -offset -default 0 + }] + lassign [dict values $argd] leaders opts remainingargs + + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval punk::fileline::system { + #*** !doctools + #[subsection {Namespace punk::fileline::system}] + #[para] Internal functions that are not part of the API + + proc wordswap16 {data} { + #scan in one endianness - format in the other. Whether we scan le/be first doesn't matter as long as we format using the opposite endianness + binary scan $data s* elements ;#scan little endian + return [binary format S* $elements] ;#format big endian + } + proc wordswap32 {data} { + binary scan $data i* elements + return [binary format I* $elements] + } + + proc scan32bit_be {i32} { + if {[binary scan $i32 I x]} { + return $x + } else { + error "couldn't scan $i32" + } + } + + #for 8.7+ using lseq + #much faster when resultant boundary size is large (at least when offset 0) + proc _range_spans_chunk_boundaries_lseq {start end chunksize args} { + if {$chunksize < 1} {error "chunksize must be > 0"} ;#sanitycheck in case called directly + set opts [dict create\ + -offset 0\ + ] + foreach {k v} $args { + switch -- $k { + -offset { + dict set opts $k $v + } + default { + error "unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- + set opt_offset [dict get $opts -offset] + # -- --- --- --- + + set smod [expr {$start % $chunksize}] + if {$smod != 0} { + set start [expr {$start + ($chunksize - $smod)}] + if {$start > $end} { + return [list is_span 0 boundaries {}] + } + } + set boundaries [lseq $start to $end $chunksize] + #offset can be negative + if {$opt_offset} { + if {$opt_offset + [lindex $boundaries end] > $end || $opt_offset + [lindex $boundaries 0] < $start} { + set overflow 1 + } else { + set overflow 0 + } + set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] + if {$overflow} { + #we don't know how many overflowed.. + set inrange [list] + foreach b $boundaries { + if {$b >= $start && $b <= $end} { + lappend inrange $b + } + } + set boundaries $inrange + } + } + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries] + } + + #faster than lseq for small number of resultant boundaries (~< 75) (which is a common use case) + #gets very slow (comparitively) with large resultsets + proc _range_spans_chunk_boundaries_tcl {start end chunksize args} { + if {$chunksize < 1} {error "chunksize must be > 0"} ;#sanitycheck in case called directly + set opts [dict create\ + -offset 0\ + ] + foreach {k v} $args { + switch -- $k { + -offset { + dict set opts $k $v + } + default { + error "unknown option '$k'. Known options: [dict keys $opts]" + } + } + } + # -- --- --- --- + set opt_offset [dict get $opts -offset] + # -- --- --- --- + + set is_span 0 + set smod [expr {$start % $chunksize}] + if {$smod != 0} { + set start [expr {$start + ($chunksize - $smod)}] + } + set boundaries [list] + + #we only need to pre-check the result-range for negative offsets - as our main loop stops before end? + if {$opt_offset < 0} { + #set btrack [expr {$start + $opt_offset}] ;#start back one to make sure we catch the first boundary + set btrack $bstart + set boff [expr {$btrack + $opt_offset}] ;#must be growing even if start and offset are negative - as chunksize is at least 1 + while {$boff < $start} { + incr btrack $chunksize + set boff [expr {$btrack + $opt_offset}] + } + set bstart $btrack + } else { + set bstart $start + } + for {set b $bstart} {[set boff [expr {$b + $opt_offset}]] <= $end} {incr b $chunksize} { + lappend boundaries $boff + } + + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries offset $opt_offset] + } + + proc _range_spans_chunk_boundaries_TIMEIT {start end chunksize {repeat 1}} { + puts "main : [time {punk::fileline::lib::range_spans_chunk_boundaries $start $end $chunksize} $repeat]" + puts "tcl : [time {punk::fileline::system::_range_spans_chunk_boundaries_tcl $start $end $chunksize} $repeat]" + if {![catch {package require Tcl 8.7-}]} { + puts "lseq : [time {punk::fileline::system::_range_spans_chunk_boundaries_lseq $start $end $chunksize} $repeat]" + } + } +} +namespace eval punk::fileline::ansi { + #*** !doctools + #[subsection {Namespace punk::fileline::ansi}] + #[para]These are ansi functions imported from punk::ansi - or no-ops if that package is unavailable + #[para]See [package punk::ansi] for documentation + #[list_begin definitions] + variable enabled 1 + #*** !doctools + #[call [fun ansi::a]] + #[call [fun ansi::a+]] + #[call [fun ansi::ansistrip]] + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::fileline::ansi ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::fileline [namespace eval punk::fileline { + variable pkg punk::fileline + variable version + set version 0.1.1 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.3.tm index 5ec354a7..234dbcb2 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.3.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]] @@ -301,7 +311,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,7 +352,7 @@ 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 @@ -396,8 +406,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 +509,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] + } # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == @@ -991,6 +1010,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 { @@ -1087,9 +1340,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] @@ -2191,7 +2444,7 @@ namespace eval punk::lib { ..10 (index 0 to 10) 2..11 - (index 2o to 11) + (index 2 to 11) .. (all indices) Common whitespace elements space,tab,newlines are ignored. @@ -2199,7 +2452,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} { @@ -4038,14 +4291,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 +4309,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 +4462,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/vfs/_vfscommon.vfs/modules/punk/lib-0.1.4.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.4.tm new file mode 100644 index 00000000..a7273752 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.4.tm @@ -0,0 +1,4935 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) 2024 +# +# @@ Meta Begin +# Application punk::lib 0.1.4 +# Meta platform tcl +# Meta license BSD +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin punkshell_module_punk::lib 0 0.1.4] +#[copyright "2024"] +#[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk library}] [comment {-- Description at end of page heading --}] +#[require punk::lib] +#[keywords module utility lib] +#[description] +#[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. +#[para]The base set includes string and math functions but has no specific theme + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::lib +#[subsection Concepts] +#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. +#[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::lib +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + + +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]] + if {$resolved eq {}} { + error [list {no such routine} $routine] + } + set routine $resolved + } + set routinens [tcl::namespace::qualifiers $routine] + if {$routinens eq {::}} { + set routinens {} + } + set routinetail [tcl::namespace::tail $routine] + + if {![string match ::* $extension]} { + set extension [uplevel 1 [ + list [tcl::namespace::which namespace] current]]::$extension + } + + if {![tcl::namespace::exists $extension]} { + error [list {no such namespace} $extension] + } + + set extension [tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] current]] + + tcl::namespace::eval $extension [ + list [tcl::namespace::which namespace] export *] + + while 1 { + set renamed ${routinens}::${routinetail}_[clock clicks] ;#clock clicks unlikely to collide when not directly consecutive such as: list [clock clicks] [clock clicks] + if {[tcl::namespace::which $renamed] eq {}} break + } + + rename $routine $renamed + + tcl::namespace::eval $extension [ + list namespace ensemble create -command $routine -unknown [ + list apply {{renamed ensemble routine args} { + list $renamed $routine + }} $renamed + ] + ] + + return $routine + } +} + +# 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} + append script \n + uplevel #0 $script + set rep1 [tcl::unsupported::representation $::j] + set script "" + set rep2 [tcl::unsupported::representation $::j] + + set nostring1 [string match "*no string" $rep1] + set nostring2 [string match "*no string" $rep2] + + #we assume it should have no string rep in either case + #Review: check Tcl versions for behaviour/consistency + if {!$nostring2} { + set bug true + } else { + 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 + set bug 0 + } else { + set bug [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}" + 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} + } + + set has_bug 0 + + set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest] + if {$show} { + puts outer: + puts $bytecode_outer + } + if {![interp issafe]} { + #test of safe subinterp only needed if we aren't already in a safe interp + if {![catch { + interp create x -safe + } errMsg]} { + x eval {proc ensembletest {} {string index a 0}} + set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}] + if {$show} { + puts safe: + puts $bytecode_safe + } + interp delete x + #mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead) + #It's possible the interp we're running in is also not compiling ensembles. + #we could then get a result of 2 - which still indicates a problem + if {[string last "invokeStk" $bytecode_safe] >= 1} { + incr has_bug + } + } else { + #our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp? + #unlikely - but we should warn + puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter" + } + } + + namespace delete [namespace current]::testcompile + + if {[string last "invokeStk" $bytecode_outer] >= 1} { + incr 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] + } +} + +tcl::namespace::eval punk::lib::compat { + #*** !doctools + #[subsection {Namespace punk::lib::compat}] + #[para] compatibility functions for features that may not be available in earlier Tcl versions + #[para] These are generally 'forward compatibility' functions ie allowing earlier versions to use later features/idioms by using a Tcl-only version of a missing builtin. + #[para] Such Tcl-only versions will inevitably be less performant - perhaps significantly so. + + #*** !doctools + #[list_begin definitions] + + + + + if {"::lremove" ne [info commands ::lremove]} { + #puts stderr "Warning - no built-in lremove" + interp alias {} lremove {} ::punk::lib::compat::lremove + } + proc lremove {list args} { + #*** !doctools + #[call [fun lremove] [arg list] [opt {index ...}]] + #[para] Forwards compatible lremove for versions 8.6 or less to support equivalent 8.7 lremove + + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lsearch -all -inline -index 1 -subindices $keep *] + } + #not significantly different in performance over test of 100 elements - getting somewhere near 10% for 1k integers + proc lremove2 {list args} { + set data [lmap v $list {list data $v}] + foreach doomed_index $args { + if {[llength $doomed_index] != 1} {error "bad index \"$doomed_index\": must be integer?\[+-]integer? or end?\[+-]integer?"} + lset data $doomed_index x ;#x won't collide as all our data has been mapped to 2 elements per value + } + set keep [lsearch -all -inline -not -exact $data x] + return [lmap v $keep {lindex $v 1}] + } + #outside of lmap - don't know of any particularly nice ways to flatten to subindex 1 of each element.. + #flattening then lsearch with -stride and * would be nice - but it's not avail in 8.6 + + if {![info exists ::auto_index(readFile)]} { + if {[info commands ::readFile] eq ""} { + proc ::readFile {filename {mode text}} { + #readFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + + # Read the file + set f [open $filename [dict get {text r binary rb} $mode]] + try { + return [read $f] + } finally { + close $f + } + } + } + } + if {![info exists ::auto_index(writeFile)]} { + if {[info commands ::writeFile] eq ""} { + proc ::writeFile {args} { + #writeFile not seen in auto_index or as command: installed by punk::lib + # Parse the arguments + switch [llength $args] { + 2 { + lassign $args filename data + set mode text + } + 3 { + lassign $args filename mode data + set MODES {binary text} + set ERR [list -level 1 -errorcode [list TCL LOOKUP MODE $mode]] + set mode [tcl::prefix match -message "mode" -error $ERR $MODES $mode] + } + default { + set COMMAND [lindex [info level 0] 0] + return -code error -errorcode {TCL WRONGARGS} "wrong # args: should be \"$COMMAND filename ?mode? data\"" + } + } + + # Write the File + set f [open $filename [dict get {text w binary wb} $mode]] + try { + puts -nonewline $f $data + } finally { + close $f + } + } + } + } + + if {"::lpop" ne [info commands ::lpop]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lpop {} ::punk::lib::compat::lpop + 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 + #[call [fun lpop] [arg listvar] [opt {index}]] + #[para] Forwards compatible lpop for versions 8.6 or less to support equivalent 8.7 lpop + upvar $lvar l + if {![llength $args]} { + set args [list end] + } + set v [lindex $l {*}$args] + set newlist $l + + set path [list] + set subl $l + for {set i 0} {$i < [llength $args]} {incr i} { + set idx [lindex $args $i] + if {![llength [lrange $subl $idx $idx]]} { + error "tcl_lpop index \"$idx\" out of range" + } + lappend path [lindex $args $i] + set subl [lindex $l {*}$path] + } + + set sublist_path [lrange $args 0 end-1] + set tailidx [lindex $args end] + if {![llength $sublist_path]} { + #set newlist [lremove $newlist $tailidx] + set newlist [lreplace $newlist $tailidx $tailidx] + } else { + set sublist [lindex $newlist {*}$sublist_path] + #set sublist [lremove $sublist $tailidx] + set sublist [lreplace $sublist $tailidx $tailidx] + lset newlist {*}$sublist_path $sublist + } + #puts "[set l] -> $newlist" + set l $newlist + return $v + } + if {"::ledit" ni [info commands ::ledit]} { + interp alias {} ledit {} ::punk::lib::compat::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 { + -Inf { + #index below lower bound + set pre [list] + set fidx -1 + } + Inf { + #first index position is greater than index of last element in the list + set pre [lrange $l 0 end] + set fidx [llength $l] + } + default { + #set pre [lrange $l 0 $first-1] + set pre [lrange $l 0 $fidx-1] + } + } + set lidx [punk::lib::lindex_resolve [llength $l] $last] + switch -exact -- $lidx { + -Inf { + #index below lower bound + set post [lrange $l 0 end] + } + Inf { + #index above upper bound + set post [list] + } + default { + if {$lidx < $fidx} { + #from ledit man page: + #If last is less than first, then any specified elements will be inserted into the list before the element specified by first with no elements being deleted. + set post [lrange $l $fidx end] + } else { + #set post [lrange $l $last+1 end] + set post [lrange $l $lidx+1 end] + } + } + } + set l [list {*}$pre {*}$args {*}$post] + } + + + #slight isolation - varnames don't leak - but calling context vars can be affected + proc lmaptcl2 {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list ::tcl::info::vars]] + set nscaller [uplevel 1 [list ::tcl::namespace::current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result [apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + if {"::lmap" ne [info commands ::lmap]} { + #puts stderr "Warning - no built-in lpop" + interp alias {} lmap {} ::punk::lib::compat::lmaptcl + } + #lmap came in Tcl 8.6 - so probably not much need for a tcl forward compatibility version - but here it is anyway + proc lmaptcl {varnames list script} { + set result [list] + set varlist [list] + foreach varname $varnames { + upvar 1 $varname var_$varname ;#ensure no collisions with vars in this proc + lappend varlist var_$varname + } + foreach $varlist $list { + lappend result [uplevel 1 $script] + } + return $result + } + + #tcl8.7/9 compatibility for 8.6 + if {[info commands ::tcl::string::insert] eq ""} { + #https://wiki.tcl-lang.org/page/string+insert + # Pure Tcl implementation of [string insert] command. + proc ::tcl::string::insert {string index insertString} { + # Convert end-relative and TIP 176 indexes to simple integers. + if {[regexp -expanded { + ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace + |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace + (?:([+-]) # op, omitted when index is "end" + ([+-]?\d+))? # n, omitted when index is "end" + [\t\n\v\f\r ]*$ # optional whitespace (unless "end") + } $index _ m op n]} { + # Convert first index to an integer. + switch $m { + end {set index [string length $string]} + default {scan $m %d index} + } + + # Add or subtract second index, if provided. + switch $op { + + {set index [expr {$index + $n}]} + - {set index [expr {$index - $n}]} + } + } elseif {![string is integer -strict $index]} { + # Reject invalid indexes. + return -code error "bad index \"$index\": must be\ + integer?\[+-\]integer? or end?\[+-\]integer?" + } + + # Concatenate the pre-insert, insertion, and post-insert strings. + string cat [string range $string 0 [expr {$index - 1}]] $insertString\ + [string range $string $index end] + } + + # Bind [string insert] to [::tcl::string::insert]. + tcl::namespace::ensemble configure string -map [tcl::dict::replace\ + [tcl::namespace::ensemble configure string -map]\ + insert ::tcl::string::insert] + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::compat ---}] +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval punk::lib { + variable PUNKARGS + tcl::namespace::export * + variable has_struct_list + set has_struct_list [expr {![catch {package require struct::list}]}] + variable has_struct_set + set has_struct_set [expr {![catch {package require struct::set}]}] + variable has_punk_ansi + set has_punk_ansi [expr {![catch {package require punk::ansi}]}] + set has_twapi 0 + if {"windows" eq $::tcl_platform(platform)} { + 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] + } + + + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + proc tm_version_isvalid {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionpart $versionpart]]} { + return 1 + } else { + return 0 + } + } + proc tm_version_major {version} { + if {![tm_version_isvalid $version]} { + error "Invalid version '$version' is not a proper Tcl module version number" + } + set firstpart [lindex [split $version .] 0] + #check for a/b in first segment + if {[string is integer -strict $firstpart]} { + return $firstpart + } + if {[string first a $firstpart] > 0} { + return [lindex [split $firstpart a] 0] + } + if {[string first b $firstpart] > 0} { + return [lindex [split $firstpart b] 0] + } + error "tm_version_major unable to determine major version from version number '$version'" + } + proc tm_version_canonical {ver} { + #accepts a single valid version only - not a bounded or unbounded spec + if {![tm_version_isvalid $ver]} { + error "tm_version_canonical version '$ver' is not valid for a package version" + } + set parts [split $ver .] + set newparts [list] + foreach o $parts { + set trimmed [string trimleft $o 0] + set firstnonzero [string index $trimmed 0] + switch -exact -- $firstnonzero { + "" { + lappend newparts 0 + } + a - b { + #e.g 000bnnnn -> bnnnnn + set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] + if {$tailtrimmed eq ""} { + set tailtrimmed 0 + } + lappend newparts 0$firstnonzero$tailtrimmed + } + default { + #digit + if {[string is integer -strict $trimmed]} { + #e.g 0100 -> 100 + lappend newparts $trimmed + } else { + #e.g 0100b003 -> 100b003 (still need to process tail) + if {[set apos [string first a $trimmed]] > 0} { + set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}a${rhs} + } elseif {[set bpos [string first b $trimmed]] > 0} { + set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch + set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits + set rhs [string trimleft $rhs 0] + if {$rhs eq ""} { + set rhs 0 + } + lappend newparts ${lhs}b${rhs} + } else { + #assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b + error "tm_version_canonical error - trimfail - unexpected" + } + } + } + } + } + return [join $newparts .] + } + proc tm_version_required_canonical {versionspec} { + #also trim leading zero from any dottedpart? + #Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. + #e.g 1.01 is equivalent to 1.1 and 01.001 + #also 1b3 == 1b0003 + + if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version + set errmsg "tm_version_required_canonical - invalid version specification" + if {[string first - $versionspec] < 0} { + #no dash + #looks like a minbounded version (ie a single version with no dash) convert to min-max form + set from $versionspec + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {tm_version_major $from} majorv]} { + set from [tm_version_canonical $from] + return "${from}-[expr {$majorv +1}]" + } else { + error "$errmsg '$versionspec'" + } + } else { + # min- or min-max + #validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) + set parts [split $versionspec -] ;#we expect only 2 parts + lassign $parts from to + if {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![tm_version_isvalid $to]} { + error "$errmsg '$versionspec'" + } + set to [tm_version_canonical $to] + return $from-$to + } else { + return $from- + } + } else { + error "$errmsg '$versionspec'" + } + error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + + # -- --- + #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists + #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 + #8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows + # Review and retest as new versions come out. + # -- --- + proc list_multi_append1 {lvar1 lvar2} { + #clear winner in 2024 + upvar $lvar1 l1 $lvar2 l2 + lappend l1 {*}$l2 + return $l1 + } + proc list_multi_append2 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [list {*}$l1 {*}$l2] + } + proc list_multi_append3 {lvar1 lvar2} { + upvar $lvar1 l1 $lvar2 l2 + set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0] + } + #testing e.g + #set l1_reset {a b c} + #set l2 {a b c d e f g} + #set l1 $l1_reset + #time {list_multi_append1 l1 l2} 1000 + #set l1 $l1_reset + #time {list_multi_append2 l1 l2} 1000 + # -- --- + + + proc lswap {lvar a z} { + 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 -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 -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 { + -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 { + -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 ""} { + append errmsg \n $a_msg + } + if {$z_msg ne ""} { + append errmsg \n $z_msg + } + error $errmsg + } + set item2 [lindex $l $z] + lset l $z [lindex $l $a] + lset l $a $item2 + return $l + } + #proc lswap2 {lvar a z} { + # upvar $lvar l + # #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + # set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]] + #} + + proc lswap2 {lvar a z} { + upvar $lvar l + #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower + set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]] + } + + #an experimental test of swapping vars without intermediate variables + #It's an interesting idea - but probably of little to no practical use + # - the swap_intvars3 version using intermediate var is faster in Tcl + # - This is probably unsurprising - as it's simpler code. + # Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks. + #proc swap_intvars {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}] + #} + #proc swap_intvars2 {swapv1 swapv2} { + # upvar $swapv1 _x $swapv2 _y + # set _x [expr {$_x ^ $_y}] + # set _y [expr {$_x ^ $_y}] + # set _x [expr {$_x ^ $_y}] + #} + #proc swap_intvars3 {swapv1 swapv2} { + # #using intermediate variable + # upvar $swapv1 _x $swapv2 _y + # set z $_x + # set _x $_y + # set _y $z + #} + + #*** !doctools + #[subsection {Namespace punk::lib}] + #[para] Core API functions for punk::lib + #[list_begin definitions] + + if {[info commands lseq] ne ""} { + #tcl 8.7+ lseq significantly faster, especially for larger ranges + #The internal rep can be an 'arithseries' with no string representation + #support minimal set from to + proc range {from to} { + lseq $from $to + } + } else { + #lseq accepts basic expressions e.g 4-2 for both arguments + #e.g we can do lseq 0 [llength $list]-1 + #if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper. + proc range {from to} { + set to [offset_expr $to] + set from [offset_expr $from] + if {$to > $from} { + set count [expr {($to -$from) + 1}] + if {$from == 0} { + return [lsearch -all [lrepeat $count 0] *] + } else { + incr from -1 + return [lmap v [lrepeat $count 0] {incr from}] + } + #slower methods. + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from] + #} + #return $L + } elseif {$from > $to} { + set count [expr {$from - $to} + 1] + #1) + if {$to == 0} { + return [lreverse [lsearch -all [lrepeat $count 0] *]] + } else { + incr from + return [lmap v [lrepeat $count 0] {incr from -1}] + } + + #2) + #set i -1 + #set L [lrepeat $count 0] + #lmap v $L {lset L [incr i] [incr from -1];lindex {}} + #return $L + #3) + #set L {} + #for {set i 0} {$i < $count} {incr i} { + # lappend L [incr from -1] + #} + #return $L + } else { + return [list $from] + } + } + } + + proc lzip {args} { + switch -- [llength $args] { + 0 {return {}} + 1 {return [lindex $args 0]} + 2 {return [lzip2lists {*}$args]} + 3 {return [lzip3lists {*}$args]} + 4 {return [lzip4lists {*}$args]} + 5 {return [lzip5lists {*}$args]} + 6 {return [lzip6lists {*}$args]} + 7 {return [lzip7lists {*}$args]} + 8 {return [lzip8lists {*}$args]} + 9 {return [lzip9lists {*}$args]} + 10 {return [lzip10lists {*}$args]} + 11 - 12 - 13 - 14 - 15 - 16 - 17 - 18 - 19 - 20 - 21 - 22 - 23 - 24 - 25 - 26 - 27 - 28 - 29 - 30 - 31 - 32 { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } + default { + if {[llength $args] < 4000} { + set n [llength $args] + if {[info commands ::punk::lib::lzip${n}lists] eq ""} { + puts "calling ::punk::lib::Build_lzipn $n" + ::punk::lib::Build_lzipn $n + } + return [lzip${n}lists {*}$args] + } else { + return [lzipn {*}$args] + } + } + } + } + + proc Build_lzipn {n} { + set arglist [list] + #use punk::lib::range which defers to lseq if available + set vars [lmap i [punk::lib::range 0 $n] {string cat v$i}] ;#v0 v1 v2.. (v0 ignored) + set body "\nlmap " + for {set i 1} {$i <= $n} {incr i} { + lappend arglist l$i + append body "[lindex $vars $i] \$l$i " + } + append body "\{list " + for {set i 1} {$i <= $n} {incr i} { + append body "\$[lindex $vars $i] " + } + append body "\}" \n + puts "proc punk::lib::lzip${n}lists {$arglist} \{" + puts "$body" + puts "\}" + proc ::punk::lib::lzip${n}lists $arglist $body + } + + #fastest is to know the number of lists to be zipped + proc lzip2lists {l1 l2} { + lmap a $l1 b $l2 {list $a $b} + } + proc lzip3lists {l1 l2 l3} { + lmap a $l1 b $l2 c $l3 {list $a $b $c} + } + proc lzip4lists {l1 l2 l3 l4} { + lmap a $l1 b $l2 c $l3 d $l4 {list $a $b $c $d} + } + proc lzip5lists {l1 l2 l3 l4 l5} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 {list $a $b $c $d $e} + } + proc lzip6lists {l1 l2 l3 l4 l5 l6} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 {list $a $b $c $d $e $f} + } + proc lzip7lists {l1 l2 l3 l4 l5 l6 l7} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 {list $a $b $c $d $e $f $g} + } + proc lzip8lists {l1 l2 l3 l4 l5 l6 l7 l8} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 {list $a $b $c $d $e $f $g $h} + } + proc lzip9lists {l1 l2 l3 l4 l5 l6 l7 l8 l9} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 {list $a $b $c $d $e $f $g $h $i} + } + proc lzip10lists {l1 l2 l3 l4 l5 l6 l7 l8 l9 l10} { + lmap a $l1 b $l2 c $l3 d $l4 e $l5 f $l6 g $l7 h $l8 i $l9 j $l10 {list $a $b $c $d $e $f $g $h $i $j} + } + + #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly + # review - + proc lzipn_alt args { + #stackoverflow - courtesy glenn jackman (modified) + foreach l $args { + lappend vars [incr n] + lappend lmap_args $n $l + } + lmap {*}$lmap_args {lmap v $vars {set $v}} + } + + #2024 - outperforms lmap version - presumably because list sizes reduced as it goes(?) + proc lzipn_tcl8 {args} { + #wiki - courtesy JAL + set list_l $args + set zip_l [] + while {1} { + set cur [lmap a_l $list_l { lindex $a_l 0 }] + set list_l [lmap a_l $list_l { lrange $a_l 1 end }] + + if {[join $cur {}] eq {}} { + break + } + lappend zip_l $cur + } + return $zip_l + } + proc lzipn_tcl9a {args} { + #compared to wiki version + #comparable for lists len <3 or number of args < 3 + #approx 2x faster for large lists or more lists + #needs -stride single index bug fix to use empty string instead of NULL + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [lrepeat [expr {$numcolumns * [llength $args]}] {}] + set outlist [lrepeat $numcolumns {}] + set s 0 + foreach len $lens list $args { + #ledit flatlist $s $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] + ledit flatlist $s [expr {$s + $len - 1}] {*}$list + incr s $numcolumns + } + #needs single index lstride bugfix + for {set c 0} {$c < $numcolumns} {incr c} { + ledit outlist $c $c [lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *] + } + return $outlist + } + proc lzipn_tcl9b {args} { + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} + } + proc lzipn_tcl9c {args} { + #SLOW + if {![llength $args]} {return {}} + set lens [lmap l $args {llength $l}] + set numcolumns [::tcl::mathfunc::max {*}$lens] + set flatlist [list] + foreach len $lens list $args { + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + } + set zip_l {} + set cols_remaining $numcolumns + for {set c 0} {$c < $numcolumns} {incr c} { + if {$cols_remaining == 1} { + return [list {*}$zip_l $flatlist] + } + lappend zip_l [lsearch -stride $cols_remaining -index 0 -inline -all -subindices $flatlist *] + set flen [llength $flatlist] + set flatlist [lremove $flatlist {*}[lseq 0 to $flen-1 by $cols_remaining]] + incr cols_remaining -1 + } + 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-] || [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 { + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + } + + + 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 { + #*** !doctools + #[call [fun invoke] [arg command]] + #[para]Invoke an external command (using tcl open command) capturing stdout,stderr and the exitcode + #[example { + # set script { + # puts stdout {hello on stdout} + # puts stderr {hello on stderr} + # exit 42 + # } + # invoke [list tclsh <<$script] + #}] + + #see https://wiki.tcl-lang.org/page/open + lassign [chan pipe] chanout chanin + lappend command 2>@$chanin + set fh [open |$command] + set stdout [read $fh] + close $chanin + set stderr [read $chanout] + close $chanout + if {[catch {close $fh} cres e]} { + dict with e {} + lassign [set -errorcode] sysmsg pid exit + if {$sysmsg eq {NONE}} { + #output to stderr caused [close] to fail. Do nothing + } elseif {$sysmsg eq {CHILDSTATUS}} { + return [list $stdout $stderr $exit] + } else { + return -options $e $stderr + } + } + return [list $stdout $stderr 0] + } + + proc pdict {args} { + package require punk::args + variable has_punk_ansi + if {!$has_punk_ansi} { + set sep " = " + } else { + #set sep " [a+ Web-seagreen]=[a] " + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " + } + set argspec [string map [list %sep% $sep] { + @id -id ::punk::lib::pdict + @cmd -name pdict -help\ + "Print dict keys,values to channel + The pdict function operates on variable names - passing the value to the showdict function which operates on values + (see also showdict)" + + @opts -any 1 + + #default separator to provide similarity to tcl's parray function + -separator -default "%sep%" + -roottype -default "dict" + -substructure -default {} + -channel -default stdout -help\ + "existing channel - or 'none' to return as string" + + @values -min 1 -max -1 + + dictvar -type string -help "name of variable. Can be a dict, list or array" + + patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + 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 */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segment in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + } + }] + #puts stderr "$argspec" + set argd [punk::args::parse $args withdef $argspec] + + 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 ::tcl::array::exists $dvar]] + if {$isarray} { + 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] + } + dict set opts -keysorttype dictionary + } else { + set dvalue [uplevel 1 [list set $dvar]] + } + showdict {*}$opts $dvalue {*}$patterns + } + + #TODO - much. + #showdict needs to be able to show different branches which share a root path + #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) + # - specify ansi colour per pattern so different branches can be highlighted? + # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc + # - The current version is incomplete but passably usable. + # - Copy proc and attempt rework so we can get back to this as a baseline for functionality + proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) + #set sep " [a+ Web-seagreen]=[a] " + variable has_punk_ansi + if {!$has_punk_ansi} { + set RST "" + set sep " = " + #set sep_mismatch " mismatch " + set sep \u2260 ;# equivalent [punk::ansi::convert_g0 [punk::ansi::g0 |]] (not equal symbol) + } else { + set RST [punk::ansi::a] + set sep " [punk::ansi::a+ Green]=$RST " ;#stick to basic default colours for wider terminal support + #set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch$RST " + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]\u2260$RST " + } + package require punk::pipe + #package require punk ;#we need pipeline pattern matching features + package require textblock + + set argd [punk::args::parse $args withdef [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + @id -id ::punk::lib::showdict + @cmd -name punk::lib::showdict -help "display dictionary keys and values" + #todo - table tableobject + -return -default "tailtohead" -choices {tailtohead sidebyside} + -channel -default none + -trimright -default 1 -type boolean -help\ + "Trim whitespace off rhs of each line. + This can help prevent a single long line that wraps in terminal from making + every line wrap due to long rhs padding." + -separator -default {%sep%} -help\ + "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help\ + "Separator to use when patterns mismatch" + -roottype -default "dict" -help\ + "list,dict,string" + -ansibase_keys -default "" -help\ + "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -substructure -default {} + -ansibase_values -default "" + -keytemplates -default {\$\{$key\}} -type list -help\ + "list of templates for keys at each level" + -keysorttype -default "none" -choices {none dictionary ascii integer real} + -keysortdirection -default increasing -choices {increasing decreasing} + -debug -default 0 -type boolean -help\ + "When enabled, produces some rudimentary debug output on stderr" + -- -type none -optional 1 + @values -min 1 -max -1 + dictvalue -type list -help\ + "dict or list value" + patterns -default "*" -type string -multiple 1 -help\ + "key or key glob pattern" + }]] + + #for punk::lib - we want to reduce pkg dependencies. + # - so we won't even use the tcllib debug pkg here + set opt_debug [dict get $argd opts -debug] + if {$opt_debug} { + if {[info body debug::showdict] eq ""} { + proc ::punk::lib::debug::showdict {args} { + catch {puts stderr "punk::lib::showdict-> [string cat {*}$args]"} + } + } + } else { + if {[info body debug::showdict] ne ""} { + proc ::punk::lib::debug::showdict {args} {} + } + } + + set opt_sep [dict get $argd opts -separator] + set opt_mismatch_sep [dict get $argd opts -separator_mismatch] + set opt_keysorttype [dict get $argd opts -keysorttype] + set opt_keysortdirection [dict get $argd opts -keysortdirection] + set opt_trimright [dict get $argd opts -trimright] + set opt_keytemplates [dict get $argd opts -keytemplates] + debug::showdict "keytemplates ---> $opt_keytemplates <---" + set opt_ansibase_keys [dict get $argd opts -ansibase_keys] + set opt_ansibase_values [dict get $argd opts -ansibase_values] + set opt_return [dict get $argd opts -return] + set opt_roottype [dict get $argd opts -roottype] + set opt_structure [dict get $argd opts -substructure] + + set dval [dict get $argd values dictvalue] + set patterns [dict get $argd values patterns] + + set result "" + + #pattern hierarchy + # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest + # * @1 @0,%#,%str - segments + # a b 1 0 %# %str - keys + + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated + set pattern_next_substructure [dict create] + set pattern_this_structure [dict create] + + # -- --- --- --- + #REVIEW + #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. + #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #e.g pdict something * + #we want the keys from the result as individual lines on lhs + #e.g pdict something @@ + #we want on lhs result on rhs + # = v0 + #e.g pdict something @0-2,@4 + #we currently return: + #0 = v0 + #1 = v1 + #2 = v2 + #4 = v4 + #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) + #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. + #this is a tradeoff that could create surprises and make things messy and/or inconsistent. + #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. + #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys + #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment + #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) + # -- --- --- --- + + set filtered_keys [list] + 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 { + set keyset [list] + set keyset_structure [list] + + set segments [split $pattern_nest /] + set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns + #we need to use _split_patterns to separate (e.g to protect commas that appear within quotes) + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + #puts stderr "showdict-->_split_patterns: $patterninfo" + foreach v_idx $patterninfo { + lassign $v_idx v idx + #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) + set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern + if {[string index $p 0] eq "!"} { + set get_not 1 + set p [string range $p 1 end] + } else { + set get_not 0 + } + switch -exact -- $p { + * - "" { + if {$opt_roottype eq "list"} { + set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + dict set pattern_this_structure $p list + } elseif {$opt_roottype eq "dict"} { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } else { + lappend keyset %string + lappend keyset_structure string + dict set pattern_this_structure $p string + } + } + %# { + dict set pattern_this_structure $p string + lappend keyset %# + lappend keyset_structure string + } + # { + #todo get_not !# is test for listiness (see punk) + dict set pattern_this_structure $p list + lappend keyset # + lappend keyset_structure list + } + ## { + dict set pattern_this_structure $p dict + lappend keyset [list ## query] + lappend keyset_structure dict + } + @* { + #puts "showdict ---->@*<----" + dict set pattern_this_structure $p list + set keys [punk::lib::range 0 [llength $dval]-1] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } + @@ { + #get first k v from dict + dict set pattern_this_structure $p dict + lappend keyset [list @@ query] + lappend keyset_structure dict + } + @*k@* - @*K@* { + #returns keys only + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @*.@* { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + default { + #puts stderr "===p:$p" + #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key + switch -glob -- $p { + {@k\*@*} - {@K\*@*} { + #value glob return keys + #set search [string range $p 4 end] + #dict for {k v} $dval { + # if {[string match $search $v]} { + # lappend keyset $k + # } + #} + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @@* { + #exact match key - review - should raise error to match punk pipe behaviour? + set k [string range $p 2 end] + if {$get_not} { + if {[dict exists $dval $k]} { + set keys [dict keys [dict remove $dval $k]] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + lappend keyset {*}[dict keys $dval] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + } + } else { + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + } + dict set pattern_this_structure $p dict + } + @k@* - @K@* { + #TODO get_not + set k [string range $p 3 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict + } + {@\*@*} { + #return list of values + #set k [string range $p 3 end] + #lappend keyset {*}[dict keys $dval $k] + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*.@*} { + #TODO get_not + set k [string range $p 4 end] + set keys [dict keys $dval $k] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + {@v\*@*} - {@V\*@*} { + #value-glob return value + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + if {$get_not} { + lappend keyset [list !$p query] + } else { + lappend keyset [list $p query] + } + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*v@*} - {@\*V@*} { + #key-glob return value + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*@*} - {@\*v@*} - {@\*V@} { + #key glob return val + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @??@* { + #exact key match - no error + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + default { + set this_type $opt_roottype + if {[string match @* $p]} { + #list mode - trim optional list specifier @ + set p [string range $p 1 end] + dict set pattern_this_structure $p list + set this_type list + } elseif {[string match %* $p]} { + dict set pattern_this_structure $p string + lappend keyset $p + lappend keyset_structure string + set this_type string + } + if {$this_type eq "list"} { + dict set pattern_this_structure $p list + if {[string is integer -strict $p]} { + if {$get_not} { + set keys [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $keys $p] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + lappend keyset $p + lappend keyset_structure list + } + } elseif {[string match "?*-?*" $p]} { + #could be either - don't change type + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + #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} == 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 == -Inf} { + ##x + set lower 0 + } else { + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve [llength $dval] $b] + if {$upper == -Inf} { + ##x + #upper bound is below list range - + if {$lower_resolve > -Inf} { + ##x + set upper 0 + } else { + continue + } + } elseif {$upper == Inf} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists + } + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + set keys [punk::lib::range $lower $upper] + if {$get_not} { + set fullrange [punk::lib::range 0 [llength $dval]-1] + set keys [lremove $fullrange {*}$keys] + if {$lower > $upper} { + set keys [lreverse $keys] + } + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + if {$get_not} { + lappend keyset [list !@$p query] + } else { + lappend keyset [list @$p query] + } + lappend keyset_structure list + } + } elseif {$this_type eq "string"} { + dict set pattern_this_structure $p string + } elseif {$this_type eq "dict"} { + #default equivalent to @\*@* + dict set pattern_this_structure $p dict + #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" + set keys [dict keys $dval $p] + if {$get_not} { + set keys [dict keys [dict remove $dval {*}$keys]] + } + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + puts stderr "list: unrecognised pattern $p" + } + } + } + } + } + } + + # -- --- --- --- + #check next pattern-segment for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $segments 1] + set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] + if {[llength $patterninfo] == 0} { + # // ? -review - what does this mean? for xpath this would mean at any level + set substructure [lindex $pattern_this_structure end] + } elseif {[llength $patterninfo] == 1} { + #ignore the NOT operator for purposes of query-type detection + if {[string index $pnext 0] eq "!"} { + set pnext [string range $pnext 1 end] + } + # single type in segment e.g /@@something/ + switch -exact -- $pnext { + "" { + set substructure string + } + @*k@* - @*K@* - @*.@* - ## { + set substructure dict + } + # { + set substructure list + } + ## { + set substructure dict + } + %# { + set substructure string + } + * { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + default { + switch -glob -- $pnext { + @??@* - @?@* - @@* { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } + default { + if {[string match @* $pnext]} { + set substructure list + } elseif {[string match %* $pnext]} { + set substructure string + } else { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + } + } + } + } + } else { + #e.g /@0,%str,.../ + #doesn't matter what the individual types are - we have a list result + set substructure list + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + if {$opt_keysorttype ne "none"} { + set int_keyset 1 + foreach k $keyset { + if {![string is integer -strict $k]} { + set int_keyset 0 + break + } + } + if {$int_keyset} { + set sortindices [lsort -indices -integer $keyset] + #set keyset [lsort -integer $keyset] + } else { + #set keyset [lsort -$opt_keysorttype $keyset] + set sortindices [lsort -indices -$opt_keysorttype $keyset] + } + set keyset [lmap i $sortindices {lindex $keyset $i}] + set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] + } + + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + + lappend filtered_keys {*}$keyset + lappend all_keyset_structure {*}$keyset_structure + + #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" + } + } + #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" + } else { + puts stdout "unrecognised roottype: $opt_roottype" + return $dval + } + + if {[llength $filtered_keys]} { + #both keys and values could have newline characters. + #simple use of 'format' won't cut it for more complex dict keys/values + #use block::width or our columns won't align in some cases + switch -- $opt_return { + "tailtohead" { + #last line of key is side by side (possibly with separator) with first line of value + #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values + #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries + + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt {${$key}} + } + #set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] + set display_keys [lmap key $filtered_keys {tstr -ret string -allowcommands $kt}] + set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] + + set kidx 0 + set last_hidekey 0 + foreach keydisplay $display_keys key $filtered_keys { + set thisval "?" + set hidekey 0 + set pattern_nest [lindex $pattern_key_index $kidx] + set pattern_nest_list [split $pattern_nest /] + #set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $key] + set this_type [lindex $all_keyset_structure $kidx] + #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" + + set is_match 1 ;#whether to display the normal separator or bad-match separator + switch -- $this_type { + dict { + #todo? - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict + # - default highlight dupes (ansi underline?) + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + % thisval.= $qry= $dval + } else { + set thisval [tcl::dict::get $dval $key] + } + + #set substructure [lrange $opt_structure 1 end] + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + + set subansibasekeys [lrange $opt_ansibase_keys 1 end] + set nextkeytemplates [lrange $opt_keytemplates 1 end] + #dict set nextopts -substructure $nextsub + dict set nextopts -keytemplates $nextkeytemplates + dict set nextopts -ansibase_keys $subansibasekeys + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" + + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + #puts stderr ">>> nextpatterns:'$nextpatterns' nextopts:'$nextopts'" + set is_match 0 + } + } + } + list { + if {[string is integer -strict $key]} { + set thisval [lindex $dval $key] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + % thisval.= $qry= $dval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + #if {![llength $nextpatterns]} { + # set nextpatterns * + #} + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + set is_match 0 + } + } + } + string { + set hidekey 1 + if {$key eq "%string"} { + set hidekey 1 + set thisval $dval + } elseif {$key eq "%ansiview"} { + set thisval [ansistring VIEW -lf 1 $dval] + } elseif {$key eq "%ansiviewstyle"} { + set thisval [ansistring VIEWSTYLE -lf 1 $dval] + } elseif {[string match *lpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which left -width $width] + } elseif {[string match *lpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which left -width $width -padchar $extra] + } elseif {[string match *rpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which right -width $width] + } elseif {[string match *rpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which right -width $width -padchar $extra] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + set thisval $dval + if {[string index $key 0] ne "%"} { + set key %$key + } + % thisval.= $key= $thisval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + #set nextopts [dict get $argd opts] + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + if {[llength $nextpatterns]} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + + } + } + if {$this_type eq "string" && $hidekey} { + lassign [textblock::size $thisval] _vw vwidth _vh vheight + #set blanks_above [string repeat \n [expr {$kheight -1}]] + set vblock $opt_ansibase_values$thisval$RST + #append result [textblock::join_basic -- $vblock] + #review - we wouldn't need this space if we had a literal %sp %sp-x ?? + append result " $vblock" + } else { + set ansibase_key [lindex $opt_ansibase_keys 0] + + lassign [textblock::size $keydisplay] _kw kwidth _kh kheight + lassign [textblock::size $thisval] _vw vwidth _vh vheight + + set totalheight [expr {$kheight + $vheight -1}] + set blanks_above [string repeat \n [expr {$kheight -1}]] + set blanks_below [string repeat \n [expr {$vheight -1}]] + + if {$is_match} { + set use_sep $opt_sep + } else { + set use_sep $opt_mismatch_sep + } + + + set sepwidth [textblock::width $use_sep] + set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] + set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] + set vblock $blanks_above$opt_ansibase_values$thisval$RST + #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace + if {$last_hidekey} { + append result \n + } + #append result [textblock::join_basic -- $kblock $sblock $vblock] \n + append result [textblock::join_basic_raw $kblock $sblock $vblock] \n + } + set last_hidekey $hidekey + incr kidx + } + } + "sidebyside" { + # TODO - fix + #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. + #use ansibase_key etc to make the output more comprehensible in that situation. + #This is why it is not the default. (review - terminal width detection and wrapping?) + set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] + foreach key $filtered_keys { + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST + #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n + #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic + append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n + } + } + } + } + if {$opt_trimright} { + set result [::join [lines_as_list -line trimright $result] \n] + } + if {[string last \n $result] == [string length $result]-1} { + set result [string range $result 0 end-1] + } + #stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place) + set chan [dict get $argd opts -channel] + switch -- $chan { + stderr - stdout { + puts $chan $result + } + none { + return $result + } + default { + #review - check member of chan names? + #just try outputting to the supplied channel for now + puts $chan $result + } + } + } + + proc is_list_all_in_list {small large} { + if {[llength $small] > [llength $large]} {return 0} + foreach x $large { + ::set ($x) {} + } + foreach x $small { + if {![info exists ($x)]} { + return 0 + } + } + return 1 + } + #v2 generally seems slower + proc is_list_all_in_list2 {small large} { + set small_in_large [lsort [struct::set intersect [lsort -unique $small] $large ]] + return [struct::list equal [lsort $small] $small_in_large] + } + if {!$has_struct_list || !$has_struct_set} { + set body { + package require struct::list + package require struct::set + } + append body [info body is_list_all_in_list2] + proc is_list_all_in_list2 {small large} $body + } + + proc is_list_all_ni_list {A B} { + foreach x $B { + ::set ($x) {} + } + foreach x $A { + if {[info exists ($x)]} { + return 0 + } + } + return 1 + } + proc is_list_all_ni_list2 {a b} { + set i [struct::set intersect $a $b] + return [expr {[llength $i] == 0}] + } + if {!$has_struct_set} { + set body { + package require struct::list + } + append body [info body is_list_all_ni_list2] + proc is_list_all_ni_list2 {a b} $body + } + + #somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist + #struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on, + # especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg) + proc ldiff {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + set result {} + foreach item $fromlist { + if {$item ni $removeitems} { + lappend result $item + } + } + return $result + } + #with ledit (also avail in 8.6 using punk::lib::compat::ledit + proc ldiff2 {fromlist removeitems} { + if {[llength $removeitems] == 0} {return $fromlist} + foreach item $removeitems { + set posns [lsearch -all -exact $fromlist $item] + foreach p $posns {ledit fromlist $p $p} + } + return $fromlist + } + proc ldiff3 {fromlist removeitems} { + set doomed [list] + foreach item $removeitems { + lappend doomed {*}[lsearch -all -exact $fromlist $item] + } + lremove $fromlist {*}$doomed + } + + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) + #also struct::set difference with critcl is faster + proc setdiff {A B} { + if {[llength $A] == 0} {return {}} + set d [dict create] + foreach x $A {dict set d $x {}} + foreach x $B {dict unset d $x} + return [dict keys $d] + } + #bulk dict remove is slower than a foreach with dict unset + #proc setdiff2 {fromlist removeitems} { + # #if {[llength $fromlist] == 0} {return {}} + # set d [dict create] + # foreach x $fromlist { + # dict set d $x {} + # } + # return [dict keys [dict remove $d {*}$removeitems]] + #} + #array is about 15% faster than dict - but unordered. (which is ok for sets - but we have struct::set for that) + proc setdiff_unordered {A B} { + if {[llength $A] == 0} {return {}} + array set tmp {} + foreach x $A {::set tmp($x) .} + foreach x $B {catch {unset tmp($x)}} + return [array names tmp] + } + + #default/fallback implementation + proc lunique_unordered {list} { + lunique $list + } + if {$has_struct_set} { + if {[struct::set equal [struct::set union {a a} {}] {a}]} { + proc lunique_unordered {list} { + struct::set union $list {} + } + } else { + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add + } + } + + + #order-preserving + proc lunique {list} { + set new {} + foreach item $list { + if {$item ni $new} { + lappend new $item + } + } + return $new + } + proc lunique2 {list} { + set doomed [list] + #expr 'in' probably faster than using a dict - for lists approx < 20,000 items. (wiki wisdom - url?) + for {set i 0} {$i < [llength $list]} {} { + set item [lindex $list $i] + lappend doomed {*}[lrange [lsearch -all -exact -start $i $list $item] 1 end] + while {[incr i] in $doomed} {} + } + lremove $list {*}$doomed + } + #The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env + proc lmapflat_closure {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + # -- --- --- + #capture - use uplevel 1 or namespace eval depending on context + set capture [uplevel 1 { + apply { varnames { + set capturevars [tcl::dict::create] + set capturearrs [tcl::dict::create] + foreach fullv $varnames { + set v [tcl::namespace::tail $fullv] + upvar 1 $v var + if {[info exists var]} { + if {(![array exists var])} { + tcl::dict::set capturevars $v $var + } else { + tcl::dict::set capturearrs capturedarray_$v [array get var] + } + } else { + #A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set + } + } + return [tcl::dict::create vars $capturevars arrs $capturearrs] + } } [info vars] + } ] + # -- --- --- + set cvars [tcl::dict::get $capture vars] + set carrs [tcl::dict::get $capture arrs] + set apply_script "" + foreach arrayalias [tcl::dict::keys $carrs] { + set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + append apply_script [string map [list %realname% $realname %arrayalias% $arrayalias] { + array set %realname% [set %arrayalias%][unset %arrayalias%] + }] + } + + append apply_script [string map [list %script% $script] { + #foreach arrayalias [info vars capturedarray_*] { + # set realname [string range $arrayalias [string first _ $arrayalias]+1 end] + # array set $realname [set $arrayalias][unset arrayalias] + #} + #return [eval %script%] + %script% + }] + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + [concat $varnames [tcl::dict::keys $cvars] [tcl::dict::keys $carrs] ]\ + $apply_script\ + ] {*}[subst $values] {*}[tcl::dict::values $cvars] {*}[tcl::dict::values $carrs] ] + } + return $result + } + #link version - can write to vars in calling context - but keeps varnames themselves isolated + #performance much better than capture version - but still a big price to pay for the isolation + proc lmapflat_link {varnames list script} { + set result [list] + set values [list] + foreach v $varnames { + lappend values "\$$v" + } + set linkvars [uplevel 1 [list info vars]] + set nscaller [uplevel 1 [list namespace current]] + + set apply_script "" + foreach vname $linkvars { + append apply_script [string map [list %vname% $vname]\ + {upvar 2 %vname% %vname%}\ + ] \n + } + append apply_script $script \n + + #puts "--> $apply_script" + foreach $varnames $list { + lappend result {*}[apply\ + [list\ + $varnames\ + $apply_script\ + $nscaller\ + ] {*}[subst $values]\ + ] + } + return $result + } + + #proc lmapflat {varnames list script} { + # concat {*}[uplevel 1 [list lmap $varnames $list $script]] + #} + #lmap can accept multiple var list pairs + proc lmapflat {args} { + concat {*}[uplevel 1 [list lmap {*}$args]] + } + proc lmapflat2 {args} { + concat {*}[uplevel 1 lmap {*}$args] + } + + #proc dict_getdef {dictValue args} { + # if {[llength $args] < 1} { + # error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} + # } + # set keys [lrange $args -1 end-1] + # if {[tcl::dict::exists $dictValue {*}$keys]} { + # return [tcl::dict::get $dictValue {*}$keys] + # } else { + # return [lindex $args end] + # } + #} + if {[info commands ::tcl::dict::getdef] eq ""} { + proc dict_getdef {dictValue args} { + set keys [lrange $args 0 end-1] + if {[tcl::dict::exists $dictValue {*}$keys]} { + return [tcl::dict::get $dictValue {*}$keys] + } else { + return [lindex $args end] + } + } + } else { + #we pay a minor perf penalty for the wrap + interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef + } + + + #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" + #} + + #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features + #safe in that we don't evaluate the expression as a string. + proc offset_expr {expression} { + set expression [tcl::string::map {_ {}} $expression] + if {[tcl::string::is integer -strict $expression]} { + return [expr {$expression}] + } + if {[regexp {([^+-]*)([+-])(.*)} $expression _match a op b] && [tcl::string::is integer -strict $a] && [tcl::string::is integer -strict $b]} { + if {$op eq "-"} { + return [expr {$a - $b}] + } else { + return [expr {$a + $b}] + } + } else { + error "bad expression '$expression': must be integer?\[+-\]integer?" + } + } + + punk::args::define { + @id -id ::punk::lib::is_indexset + @cmd -name punk::lib::is_indexset\ + -summary\ + "Validate string is a comma-delimited 'indexset'."\ + -help\ + "Validate that a string is an 'indexset' + + An indexset consists of a comma delimited list of indexes or index-ranges. + 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') + ..10 + (index 'base' to 10) + 2..11 + (index 2 to 11) + .. + (all indices) + Common whitespace elements space,tab,newlines are 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. + + see indexset_resolve" + @values -min 1 -max 1 + indexset -type string + } + proc is_indexset {indexset} { + #collapse internal whitespace (for basic whitespace set we allow) + set indexset [string map [list " " "" \t "" \r\n "" \n ""] $indexset] + if {![regexp {^[\-\+_end,\.0-9]*$} $indexset]} { + return 0 + } + set ranges [split $indexset ,] + foreach r $ranges { + set validateindices [list] + set rposn [string first .. $r] + if {$rposn >= 0} { + set sepsize 2 + set step 1 + } else { + #check for .n. 'stepped' range + set fdot [string first . $r] + set ldot [string last . $r] + set step [string range $r $fdot+1 $ldot-1] + #todo - allow basic mathops for step: 2+1 2+-1 etc same as tcl lindex, lseq + if {![string is integer -strict $step]} { + } + } + + if {$rposn >= 0} { + lappend validateindices {*}[string range $r 0 $rposn-1] {*}[string range $r $rposn+2 end] + } else { + #'range' is just an index + set validateindices [list $r] + } + foreach v $validateindices { + if {$v eq "" || $v eq "end"} {continue} + if {[string is integer -strict $v]} {continue} + if {[catch {lindex {} $v}]} { + return 0 + } + } + } + return 1 + } + #review - compare to IMAP4 methods of specifying ranges? + punk::args::define { + @id -id ::punk::lib::indexset_resolve + @cmd -name punk::lib::indexset_resolve\ + -summary\ + "Resolve an indexset to a list of integers based on supplied list or string length."\ + -help\ + "Resolve an 'indexset' to a list of actual indices within the range of the provided numitems value. + 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. + 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 + + 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 + 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 3 + numitems -type integer + indexset -type indexset -help "comma delimited specification for indices to return" + 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] + uplevel 1 [list return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg] + } + 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 based_max [expr {$numitems -1 + $base}] + + foreach ipart $iparts { + set ipart [string trim $ipart] + set rposn [string first .. $ipart] + if {$rposn>=0} { + #range + 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 $base} + set a [punk::lib::lindex_resolve $numitems $rawa $base] + if {$a == -Inf} { + #(was -3) + #undershot - leave negative + } elseif {$a == Inf} { + #overshot + 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 > $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 $base] + if {$b == -Inf} { + #undershot - leave negative + } 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 >= $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 >= $base && $a <= $based_max} { + #only a is in the range + if {$b < $base} { + set b $base + } else { + 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 >=$base && $b <= $based_max} { + #only b is in the range + if {$a < $base} { + set a $base + } else { + 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 < $base && $b > $base} { + #spans the range in forward order + 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 > $base && $b < $base} { + #spans the range in reverse order + 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 $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 -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\ + -summary\ + "Resolve an indexexpression to an integer based on supplied list or string length."\ + -help\ + "Resolve an index which may be of the forms accepted by Tcl list or string commands such as end-2 or 2+2 + to the actual integer index for the supplied list/string length, or to a negative value below -1 indicating + whether the index was below or above the range of possible indices for the length supplied. + + Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. + This means the proc may be called with something like $x+2 end-$y etc + Sometimes the actual integer index is desired. + + 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) -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 + bounds indices, or in the case of lrange, return results anyway. + Like Tcl list commands - it will produce an error if the form of the index is not acceptable. + For empty lists/string (datalength 0), end and end+x indices are considered to be out of bounds on the upper side + - thus returning -2 + + Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. + We will get something like 10+1 - which can be resolved safely with expr + " + @values -min 2 -max 2 + datalength -type integer + index -type indexexpression + } + 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 + #[para]Users may define procs which accept a list/string index and wish to accept the forms understood by Tcl. + #[para]This means the proc may be called with something like $x+2 end-$y etc + #[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) -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. + #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable + #[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2 + + #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which can be resolved safely with expr + + + #REVIEW - we need compat for 1_000 etc to handle things like toml even in 8.6? + #A basic string map means we aren't properly validating + #todo - be stricter about malformations such as 1000_ + if {![string is integer -strict 1_0]} { + #basic forward compatibility with integers such as 1_000 for 8.6.x + set index [tcl::string::map {_ {}} $index] + set len [tcl::string::map {_ {}} $len] + } + + if {![string is integer -strict $len] || $len < 0} { + 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 < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf + } else { + #integer may still have + sign - normalize with expr + return [expr {$index}] + } + } else { + if {[string match end* $index]} { + if {$index ne "end"} { + set op [string index $index 3] + set offset [string range $index 4 end] + #note - offset could have leading + or - + # 'string is integer -strict +1' ==> true + #e.g end+-1 is valid (end++-1 is not) + if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} + if {$offset == 0} { + #(offset +0, -0 or 0 or 000 0_0 etc) + #op either + or - is irrelevant + #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}}] + 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 + } + } else { + #index is 'end' + if {$len == 0} { + #special case - 'end' with empty list - treat end like a positive number out of bounds + return Inf + } + #return [expr {$len - 1 + $base}] + return $based_max + } + } else { + #plain +- already handled above. + #we are trying to avoid evaluating unbraced expr of potentially insecure origin + #regexp must split a++b to a + +b (not a+ + b) ie first +/- is the op + if {[regexp {([^+-]*)([+-])(.*)} $index _match a op b]} { + if {[string is integer -strict $a] && [string is integer -strict $b]} { + if {$op eq "-"} { + set index [expr {$a - $b}] + } else { + set index [expr {$a + $b}] + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + } else { + error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" + } + if {$index < $base} { + return -Inf + } elseif {$index > $based_max} { + return Inf + } + return $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 -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] || $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 < $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}] + } + } + 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 $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 + } + 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 -Inf + } else { + return $idx + } + } + proc lindex_get {list index} { + set resultlist [lrange $list $index $index] + if {![llength $resultlist]} { + return -1 + } else { + #we still don't know the actual integer index for an index such as end-x or int-int without parsing and evaluating ourself. + #we can return the value - but only in a way that won't collide with our -1 out-of-range indicator + return [tcl::dict::create value [lindex $resultlist 0]] + } + } + + proc string_splitbefore {str index} { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -Inf { + return [list "" $str] + } + Inf { + return [list $str ""] + } + } + } + return [list [string range $str 0 $index-1] [string range $str $index end]] + #scan %s stops at whitespace - not useful here. + #scan $s %${p}s%s + } + proc string_splitbefore_indices {str args} { + set parts [list $str] + set sizes [list [string length $str]] + set s 0 + foreach index $args { + if {![string is integer -strict $index]} { + set index [punk::lib::lindex_resolve [string length $str] $index] + switch -- $index { + -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} { + if {[lindex $sizes 0] != 0} { + ledit parts 0 0 {} [lindex $parts 0] + ledit sizes 0 0 0 [lindex $sizes 0] + } + continue + } + if {$index >= [string length $str]} { + if {[lindex $sizes end] != 0} { + ledit parts end end [lindex $parts end] {} + ledit sizes end end [lindex $sizes end] 0 + } + continue + } + set i -1 + set a 0 + foreach sz $sizes { + incr i + if {$a + $sz > $index} { + set p [lindex $parts $i] + #puts "a:$a index:$index" + if {$a == $index} { + break + } + ledit parts $i $i [string range $p 0 [expr {$index -$a -1}]] [string range $p $index-$a end] + ledit sizes $i $i [expr {$index - $a}] [expr {($a + $sz)-$index}] + break + } + incr a $sz + } + #puts "->parts:$parts" + #puts "->sizes:$sizes" + } + return $parts + } + + proc K {x y} {return $x} + #*** !doctools + #[call [fun K] [arg x] [arg y]] + #[para]The K-combinator function - returns the first argument, x and discards y + #[para]see [uri https://wiki.tcl-lang.org/page/K] + #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. + + + proc is_utf8_multibyteprefix {bytes} { + #*** !doctools + #[call [fun is_utf8_multibyteprefix] [arg str]] + #[para] Returns a boolean if str is potentially a prefix for a multibyte utf-8 character + #[para] ie - tests if it is possible that appending more data will result in a utf-8 codepoint + #[para] Will return false for an already complete utf-8 codepoint + #[para] It is assumed the incomplete sequence is at the beginning of the bytes argument + #[para] Suitable input for this might be from the unreturned tail portion of get_utf8_leading $testbytes + #[para] e.g using: set head [lb]get_utf8_leading $testbytes[rb] ; set tail [lb]string range $testbytes [lb]string length $head[rb] end[rb] + regexp {(?x) + ^ + (?: + [\xC0-\xDF] | #possible prefix for two-byte codepoint + [\xE0-\xEF] [\x80-\xBF]{0,1} | #possible prefix for three-byte codepoint + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for + ) + $ + } $bytes + } + + proc is_utf8_first {str} { + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + } $str + } + proc is_utf8_single {1234bytes} { + #*** !doctools + #[call [fun is_utf8_single] [arg 1234bytes]] + #[para] Tests input of 1,2,3 or 4 bytes and responds with a boolean indicating if it is a valid utf-8 character (codepoint) + regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + ^ + (?: + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + $ + } $1234bytes + } + proc get_utf8_leading {rawbytes} { + #*** !doctools + #[call [fun get_utf8_leading] [arg rawbytes]] + #[para] return the leading portion of rawbytes that is a valid utf8 sequence. + #[para] This will stop at the point at which the bytes can't be interpreted as a complete utf-8 codepoint + #[para] e.g It will not return the first byte or 2 of a 3-byte utf-8 character if the last byte is missing, and will return only the valid utf-8 string from before the first byte of the incomplete character. + #[para] It will also only return the prefix before any bytes that cannot be part of a utf-8 sequence at all. + #[para] Note that while this will return valid utf8 - it has no knowledge of grapheme clusters or diacritics + #[para] This means if it is being used to process bytes split at some arbitrary point - the trailing data that isn't returned could be part of a grapheme cluster that belongs with the last character of the leading string already returned + #[para] The utf-8 BOM \xEF\xBB\xBF is a valid UTF8 3-byte sequence and so can also be returned as part of the leading utf8 bytes + if {[regexp {(?x) # Expanded regexp syntax, so I can put in comments :-) + \A ( + [\x00-\x7F] | # Single-byte chars (ASCII range) + [\xC0-\xDF] [\x80-\xBF] | # Two-byte chars (\u0080-\u07FF) + [\xE0-\xEF] [\x80-\xBF]{2} | # Three-byte chars (\u0800-\uFFFF) + [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) + ) + + } $rawbytes completeChars]} { + return $completeChars + } + return "" + } + proc hex2dec {args} { + #*** !doctools + #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] + #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values + #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 + #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. + #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 + #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 + + set list_largeHex [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" + } + set opts [tcl::dict::create\ + -validate 1\ + -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $opts] + foreach {k v} $argopts { + tcl::dict::set opts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v + } + # -- --- --- --- + set opt_validate [tcl::dict::get $opts -validate] + set opt_empty [tcl::dict::get $opts -empty_as_hex] + # -- --- --- --- + + set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map {_ ""} [string trim $h]}] + if {$opt_validate} { + #Note appended F so that we accept list of empty strings as per the documentation + if {![string is xdigit -strict [join $list_largeHex ""]F ]} { + error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" + } + } + if {![string is xdigit -strict [string map {_ ""} $opt_empty]]} { + #mapping empty string to a value destroys any advantage of -scanonly + #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] + if {[lsearch $list_largeHex ""] >=0} { + error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" + } + } else { + set opt_empty [string trim [string map {_ ""} $opt_empty]] + if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { + #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] + set nonempty_head [lrange $list_largeHex 0 $first_empty-1] + set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] + } + + proc dec2hex {args} { + #*** !doctools + #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] + #[para]Convert a list of decimal integers to a list of hex values + #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. + #[para] -case upper|lower determines the case of the hex letters in the output + set list_decimals [lindex $args end] + set argopts [lrange $args 0 end-1] + if {[llength $argopts]%2 !=0} { + error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" + } + set defaults [tcl::dict::create\ + -width 1\ + -case upper\ + -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ + ] + set known_opts [tcl::dict::keys $defaults] + set fullopts [tcl::dict::create] + foreach {k v} $argopts { + tcl::dict::set fullopts [tcl::prefix match -message "options for [tcl::namespace::current]::dec2hex. Unexpected option" $known_opts $k] $v + } + set opts [tcl::dict::merge $defaults $fullopts] + # -- --- --- --- + set opt_width [tcl::dict::get $opts -width] + set opt_case [tcl::dict::get $opts -case] + set opt_empty [tcl::dict::get $opts -empty_as_decimal] + # -- --- --- --- + + + set resultlist [list] + switch -- [string tolower $opt_case] { + upper { + set spec X + } + lower { + set spec x + } + default { + error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" + } + } + set fmt "%${opt_width}.${opt_width}ll${spec}" + + set list_decimals [lmap d $list_decimals[unset list_decimals] {string map {_ ""} [string trim $d]}] + if {![string is digit -strict [string map {_ ""} $opt_empty]]} { + if {[lsearch $list_decimals ""] >=0} { + error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" + } + } else { + set opt_empty [string map {_ ""} $opt_empty] + if {[set first_empty [lsearch $list_decimals ""]] >= 0} { + set nonempty_head [lrange $list_decimals 0 $first_empty-1] + set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] + } + } + return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] + } + + proc log2 x "expr {log(\$x)/[expr log(2)]}" + #*** !doctools + #[call [fun log2] [arg x]] + #[para]log base2 of x + #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time + #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) + + proc logbase {b x} { + #*** !doctools + #[call [fun logbase] [arg b] [arg x]] + #[para]log base b of x + #[para]This function uses expr's natural log and the change of base division. + #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 + expr {log($x)/log($b)} + } + proc factors {x} { + #*** !doctools + #[call [fun factors] [arg x]] + #[para]Return a sorted list of the positive factors of x where x > 0 + #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* + #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors + #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions + #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers + #[para]Comparisons were done with some numbers below 17 digits long + #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. + #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers + #but has the disadvantage of being slower for 'small' numbers and using more memory. + #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x + #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py + #[para] In other mathematical contexts zero may be considered not to divide anything. + set factors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {($x % $j) == 0} { + lappend factors $j [expr {$x / $j}] + } + incr j + } + lappend factors $x + return [lsort -unique -integer $factors] + } + proc oddFactors {x} { + #*** !doctools + #[call [fun oddFactors] [arg x]] + #[para]Return a list of odd integer factors of x, sorted in ascending order + set j 2 + set max [expr {sqrt($x)}] + set factors [list 1] + while {$j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2} { + if {$other ni $factors} { + lappend factors $other + } + } + if {$j % 2} { + if {$j ni $factors} { + lappend factors $j + } + } + } + incr j + } + return [lsort -integer -increasing $factors] + } + proc greatestFactorBelow {x} { + #*** !doctools + #[call [fun greatestFactorBelow] [arg x]] + #[para]Return the largest factor of x excluding itself + #[para]factor functions can be useful for console layout calculations + #[para]See Tcllib math::numtheory for more extensive implementations + if {$x % 2 == 0 || $x == 0} { + return [expr {$x / 2}] + } + set j 3 + set max [expr {sqrt($x)}] + while {$j <= $max} { + if {$x % $j == 0} { + return [expr {$x / $j}] + } + incr j 2 + } + return 1 + } + proc greatestOddFactorBelow {x} { + #*** !doctools + #[call [fun greatestOddFactorBelow] [arg x]] + #[para]Return the largest odd integer factor of x excluding x itself + if {$x %2 == 0} { + return [greatestOddFactor $x] + } + set j 3 + #dumb brute force - time taken to compute is wildly variable on big numbers + #todo - use a (memoized?) generator of primes to reduce the search space + #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. + set god 1 + set max [expr {sqrt($x)}] + while { $j <= $max} { + if {$x % $j == 0} { + set other [expr {$x / $j}] + if {$other % 2 == 0} { + set god $j + } else { + set god [expr {$x / $j}] + #lowest j - so other side must be highest + break + } + } + incr j 2 + } + return $god + } + proc greatestOddFactor {x} { + #*** !doctools + #[call [fun greatestOddFactor] [arg x]] + #[para]Return the largest odd integer factor of x + #[para]For an odd value of x - this will always return x + if {$x % 2 != 0 || $x == 0} { + return $x + } + set r [expr {$x / 2}] + while {$r % 2 == 0} { + set r [expr {$r / 2}] + } + return $r + } + proc gcd {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the greatest common divisor of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para]Graphical use: + #[para]An a by b rectangle can be covered with square tiles of side-length c, + #[para]only if c is a common divisor of a and b + + # + # Apply Euclid's good old algorithm + # + if { $n > $m } { + set t $n + set n $m + set m $t + } + + while { $n > 0 } { + set r [expr {$m % $n}] + set m $n + set n $r + } + + return $m + } + proc lcm {n m} { + #*** !doctools + #[call [fun gcd] [arg n] [arg m]] + #[para]Return the lowest common multiple of m and n + #[para]Straight from Lars Hellström's math::numtheory library in Tcllib + #[para] + set gcd [gcd $n $m] + return [expr {$n*$m/$gcd}] + } + proc commonDivisors {x y} { + #*** !doctools + #[call [fun commonDivisors] [arg x] [arg y]] + #[para]Return a list of all the common factors of x and y + #[para](equivalent to factors of their gcd) + return [factors [gcd $x $y]] + } + + #experimental only - there are better/faster ways + proc sieve n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + tcl::dict::for {next -} $nums break + } + return [concat $primes [tcl::dict::keys $nums]] + } + proc sieve2 n { + set primes [list] + if {$n < 2} {return $primes} + set nums [tcl::dict::create] + for {set i 2} {$i <= $n} {incr i} { + tcl::dict::set nums $i "" + } + set next 2 + set limit [expr {sqrt($n)}] + while {$next <= $limit} { + for {set i $next} {$i <= $n} {incr i $next} {tcl::dict::unset nums $i} + lappend primes $next + #dict for {next -} $nums break + set next [lindex $nums 0] + } + return [concat $primes [tcl::dict::keys $nums]] + } + + proc hasglobs {str} { + #*** !doctools + #[call [fun hasglobs] [arg str]] + #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] + #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. + regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving + } + + proc trimzero {number} { + #*** !doctools + #[call [fun trimzero] [arg number]] + #[para]Return number with left-hand-side zeros trimmed off - unless all zero + #[para]If number is all zero - a single 0 is returned + set trimmed [string trimleft $number 0] + if {[string length $trimmed] == 0} { + set trimmed 0 + } + return $trimmed + } + proc substring_count {str substring} { + #*** !doctools + #[call [fun substring_count] [arg str] [arg substring]] + #[para]Search str and return number of occurrences of substring + + #faster than lsearch on split for str of a few K + if {$substring eq ""} {return 0} + set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] + return [expr {$occurrences / [string length $substring]}] + } + + proc dict_merge_ordered {defaults main} { + #*** !doctools + #[call [fun dict_merge_ordered] [arg defaults] [arg main]] + #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. + #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. + #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. + + #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] + } + + proc askuser {question} { + #*** !doctools + #[call [fun askuser] [arg question]] + #[para]A basic utility to read an answer from stdin + #[para]The prompt is written to the terminal and then it waits for a user to type something + #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. + #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. + #[para](Generic terminal raw vs linemode detection not yet present) + #[para]The user must hit enter to submit the response + #[para]The return value is the string if any that was typed prior to hitting enter. + #[para]The question argument can be manually colourised using the various punk::ansi funcitons + #[example_begin] + # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] + # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { + # puts "Proceeding" + # } else { + # puts "Cancelled by user" + # } + #[example_end] + puts stdout $question + flush stdout + set stdin_state [chan configure stdin] + if {[catch { + package require punk::console + set console_raw [tsv::get console is_raw] + } err_console]} { + #assume normal line mode + set console_raw 0 + } + try { + chan configure stdin -blocking 1 + if {$console_raw} { + punk::console::disableRaw + set answer [gets stdin] + punk::console::enableRaw + } else { + set answer [gets stdin] + } + } finally { + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] + } + return $answer + } + + #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. + proc indent {text {prefix " "}} { + set result [list] + foreach line [split $text \n] { + if {[string trim $line] eq ""} { + lappend result "" + } else { + lappend result $prefix[string trimright $line] + } + } + return [join $result \n] + } + #dedent? + proc undent {text {max -1}} { + if {$text eq ""} { + return "" + } + set lines [split $text \n] + set nonblank [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + continue + } + lappend nonblank $ln + } + set lcp [longestCommonPrefix $nonblank] + if {$lcp eq ""} { + return $text + } + regexp {^([\t ]*)} $lcp _m lcp + if {$lcp eq ""} { + return $text + } + set len [string length $lcp] + if {$max != -1} { + set len [expr {min($len,$max)}] + } + set result [list] + foreach ln $lines { + if {[string trim $ln] eq ""} { + lappend result "" + } else { + lappend result [string range $ln $len end] + } + } + return [join $result \n] + } + #A version of textutil::string::longestCommonPrefixList + proc longestCommonPrefix {items} { + if {[llength $items] <= 1} { + return [lindex $items 0] + } + set items [lsort $items[unset items]] + set min [lindex $items 0] + set max [lindex $items end] + #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) + #(sort order nothing to do with length - e.g min may be longer than max) + if {[string length $min] > [string length $max]} { + set temp $min + set min $max + set max $temp + } + set n [string length $min] + set prefix "" + set i -1 + while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { + append prefix $c + } + return $prefix + } + + #e.g linesort -decreasing $data + proc linesort {args} { + #*** !doctools + #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] + #[para]Sort lines in textblock + #[para]Returns another textblock with lines sorted + #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique + if {[llength $args] < 1} { + error "linesort missing lines argument" + } + set lines [lindex $args end] + set opts [lrange $args 0 end-1] + #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts + list_as_lines [lsort {*}$opts [linelist $lines]] + } + + proc list_as_lines {args} { + #*** !doctools + #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] + #[para]This simply joins the elements of the list with -joinchar + #[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines + #[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. + if {[set eop [lsearch $args --]] == [llength $args]-2} { + #end-of-opts not really necessary - except for consistency with lines_as_list + set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] + } + if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { + set joinchar [lindex $args 1] + set lines [lindex $args 2] + } elseif {[llength $args] == 1} { + set joinchar "\n" + set lines [lindex $args 0] + } else { + error "list_as_lines usage: list_as_lines ?-joinchar ? " + } + return [join $lines $joinchar] + } + proc list_as_lines2 {args} { + #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible? + lassign [tcl::dict::values [punk::args::parse $args withdef { + -joinchar -default \n + @values -min 1 -max 1 + }]] leaders opts values + + return [join [tcl::dict::get $values 0] [tcl::dict::get $opts -joinchar]] + } + + proc lines_as_list {args} { + #*** !doctools + #[call [fun lines_as_list] [opt {option value ...}] [arg text]] + #[para]Returns a list of possibly trimmed lines depeding on options + #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf + #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements + + #The underlying function linelist has the validation code which gives nicer usage errors. + #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error + #..because we don't know what to say if there are odd numbers of args + #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work + #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway + + if {[lsearch $args "--"] == [llength $args]-2} { + set opts [lrange $args 0 end-2] + } else { + set opts [lrange $args 0 end-1] + } + #set opts [tcl::dict::merge {-block {}} $opts] + set bposn [lsearch $opts -block] + if {$bposn < 0} { + lappend opts -block {} + } + set text [lindex $args end] + #tailcall linelist {*}$opts $text + return [linelist {*}$opts $text] + } + #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds + proc lines_as_list2 {args} { + #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults + #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc + #we don't have to decide what is an opt vs a value + #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) + lassign [tcl::dict::values [punk::args::parse $args withdef { + @opts -any 1 + -block -default {} + }]] leaderdict opts valuedict + tailcall linelist {*}$opts {*}[tcl::dict::values $valuedict] + } + + # important for pipeline & match_assign + # -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ? + # -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace + set linelist_body { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + ;#package require punk::ansi + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list/detectcode_in_list will check at first level. (not intended for detecting ansi in deeper structures) + + #we use detectcode_in_list instead of detect_in_list + #detectcode_in_list will detect unclosed (or unopened) paired sequences such as PM (privacy message) + # - but the main reason is it is slightly faster. + if {![punk::ansi::ta::detectcode_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + #set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + #get_codes_single lists only the codes. no plaintext or empty elements + set ansisplits [punk::ansi::ta::get_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits] == 0} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end] ;#may or may not be SGR + set lastcodeoffset [expr {[string length $lastcode]-1}] + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[string range $ln end-$lastcodeoffset end] eq $lastcode} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[string range $ln end-$lastcodeoffset end] eq $lastcode && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #code is at tail (no trailing plaintext) + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach code $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + + set linelist_body_original { + set usage "linelist ?-ansiresets auto|? ?-ansireplays 0|1? ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" + if {[llength $args] == 0} { + error "linelist missing textchunk argument usage:$usage" + } + set text [lindex $args end] + set text [string map {\r\n \n} $text] ;#review - option? + + set arglist [lrange $args 0 end-1] + set opts [tcl::dict::create\ + -block {trimhead1 trimtail1}\ + -line {}\ + -commandprefix ""\ + -ansiresets auto\ + -ansireplays 0\ + ] + foreach {o v} $arglist { + switch -- $o { + -block - -line - -commandprefix - -ansiresets - -ansireplays { + tcl::dict::set opts $o $v + } + default { + error "linelist: Unrecognized option '$o' usage:$usage" + } + } + } + # -- --- --- --- --- --- + set opt_block [tcl::dict::get $opts -block] + if {[llength $opt_block]} { + foreach bo $opt_block { + switch -- $bo { + trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} + default { + set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] + error "linelist: unknown -block option value: $bo known values: $known_blockopts" + } + } + } + #normalize certain combos + if {"trimhead" in $opt_block && [set posn [lsearch $opt_block trimhead1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimtail" in $opt_block && [set posn [lsearch $opt_block trimtail1]] >=0} { + set opt_block [lreplace $opt_block $posn $posn] + } + if {"trimall" in $opt_block} { + #no other block options make sense in combination with this + set opt_block [list "trimall"] + } + + #TODO + if {"triminner" in $opt_block } { + error "linelist -block triminner not implemented - sorry" + } + + } + + + # -- --- --- --- --- --- + set opt_line [tcl::dict::get $opts -line] + set tl_left 0 + set tl_right 0 + set tl_both 0 + foreach lo $opt_line { + switch -- $lo { + trimline { + set tl_both 1 + } + trimleft { + set tl_left 1 + } + trimright { + set tl_right 1 + } + default { + set known_lineopts [list trimline trimleft trimright] + error "linelist: unknown -line option value: $lo known values: $known_lineopts" + } + } + } + #normalize trimleft trimright combo + if {$tl_left && $tl_right} { + set opt_line [list "trimline"] + set tl_both 1 + } + # -- --- --- --- --- --- + set opt_commandprefix [tcl::dict::get $opts -commandprefix] + # -- --- --- --- --- --- + set opt_ansiresets [tcl::dict::get $opts -ansiresets] + # -- --- --- --- --- --- + set opt_ansireplays [tcl::dict::get $opts -ansireplays] + if {$opt_ansireplays} { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 1 + } + } else { + if {$opt_ansiresets eq "auto"} { + set opt_ansiresets 0 + } + } + # -- --- --- --- --- --- + set linelist [list] + set nlsplit [split $text \n] + if {![llength $opt_line]} { + set linelist $nlsplit + #lappend linelist {*}$nlsplit + } else { + #already normalized trimleft+trimright to trimline + if {$tl_both} { + foreach ln $nlsplit { + lappend linelist [string trim $ln] + } + } elseif {$tl_left} { + foreach ln $nlsplit { + lappend linelist [string trimleft $ln] + } + } elseif {$tl_right} { + foreach ln $nlsplit { + lappend linelist [string trimright $ln] + } + } + } + + if {"collateempty" in $opt_block} { + set inputlist $linelist[set linelist [list]] + set last "-" + foreach input $inputlist { + if {$input ne ""} { + lappend linelist $input + set last "-" + } else { + if {$last ne ""} { + lappend linelist "" + } + set last "" + } + } + } + + if {"trimall" in $opt_block} { + set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] + } else { + set start 0 + if {"trimhead" in $opt_block} { + set idx 0 + set lastempty -1 + foreach ln $linelist { + if {[lindex $linelist $idx] ne ""} { + break + } else { + set lastempty $idx + } + incr idx + } + if {$lastempty >=0} { + set start [expr {$lastempty +1}] + } + } + set linelist [lrange $linelist $start end] + + if {"trimtail" in $opt_block} { + set revlinelist [lreverse $linelist][set linelist {}] + set i 0 + foreach ln $revlinelist { + if {$ln ne ""} { + set linelist [lreverse [lrange $revlinelist $i end]] + break + } + incr i + } + } + + # --- --- + set start 0 + set end "end" + if {"trimhead1" in $opt_block} { + if {[lindex $linelist 0] eq ""} { + set start 1 + } + } + if {"trimtail1" in $opt_block} { + if {[lindex $linelist end] eq ""} { + set end "end-1" + } + } + set linelist [lrange $linelist $start $end] + } + + #review - we need to make sure ansiresets don't accumulate/grow on any line + #Each resulting line should have a reset of some type at start and a pure-reset at end to stop + #see if we can find an ST sequence that most terminals will not display for marking sections? + if {$opt_ansireplays} { + #package require punk::ansi + + if {$opt_ansiresets} { + set RST "\x1b\[0m" + } else { + set RST "" + } + set replaycodes $RST ;#todo - default? + set transformed [list] + #shortcircuit common case of no ansi + #NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the list have backslash escapes due to Tcl list quoting and escaping behaviour. + #This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled) + #ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable + #detect_in_list will check at first level. (not intended for detecting ansi in deeper structures) + if {![punk::ansi::ta::detect_in_list $linelist]} { + if {$opt_ansiresets} { + foreach ln $linelist { + lappend transformed $RST$ln$RST + } + set linelist $transformed + } + } else { + + #INLINE punk::ansi::codetype::is_sgr_reset + #regexp {\x1b\[0*m$} $code + set re_is_sgr_reset {\x1b\[0*m$} + #INLINE punk::ansi::codetype::is_sgr + #regexp {\033\[[0-9;:]*m$} $code + set re_is_sgr {\x1b\[[0-9;:]*m$} + + foreach ln $linelist { + #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable + + set ansisplits [punk::ansi::ta::split_codes_single $ln] ;#REVIEW - this split accounts for a large portion of the time taken to run this function. + if {[llength $ansisplits]<= 1} { + #plaintext only - no ansi codes in line + lappend transformed [string cat $replaycodes $ln $RST] + #leave replaycodes as is for next line + set nextreplay $replaycodes + } else { + set tail $RST + set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR + if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { + if {[lindex $ansisplits end] eq ""} { + #last plaintext is empty. So the line is already suffixed with a reset + set tail "" + set nextreplay $RST + } else { + #trailing text has been reset within line - but no tail reset present + #we normalize by putting a tail reset on anyway + set tail $RST + set nextreplay $RST + } + } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { + #No tail reset - and no need to examine whole line to determine stack that is in effect + set tail $RST + set nextreplay $lastcode + } else { + #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect + #last codeset doesn't end in a pure-reset + #whether code was at very end or not - add a reset tail + set tail $RST + #determine effective replay for line + set codestack [list start] + foreach {pt code} $ansisplits { + if {[punk::ansi::codetype::is_sgr_reset $code]} { + set codestack [list] ;#different from 'start' marked - this means we've had a reset + } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { + set codestack [list $code] + } else { + if {[punk::ansi::codetype::is_sgr $code]} { + #todo - proper test of each code - so we only take latest background/foreground etc. + #requires handling codes with varying numbers of parameters. + #basic simplification - remove straight dupes. + set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. + set codestack [lremove $codestack {*}$dup_posns] + lappend codestack $code + } ;#else gx0 or other code - we don't want to stack it with SGR codes + } + } + if {$codestack eq [list start]} { + #No SGRs - may have been other codes + set line_has_sgr 0 + } else { + #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes + set line_has_sgr 1 + if {[lindex $codestack 0] eq "start"} { + set codestack [lrange $codestack 1 end] + } + } + + #set newreplay [join $codestack ""] + set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] + + if {$line_has_sgr && $newreplay ne $replaycodes} { + #adjust if it doesn't already does a reset at start + if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { + set nextreplay $newreplay + } else { + set nextreplay $RST$newreplay + } + } else { + set nextreplay $replaycodes + } + } + if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { + #no point attaching any replay + lappend transformed [string cat $ln $tail] + } else { + lappend transformed [string cat $replaycodes $ln $tail] + } + } + set replaycodes $nextreplay + } + set linelist $transformed + } + } + + if {[llength $opt_commandprefix]} { + set transformed [list] + foreach ln $linelist { + lappend transformed [{*}$opt_commandprefix $ln] + } + set linelist $transformed + } + + return $linelist + } + if {$has_punk_ansi} { + #optimise linelist as much as possible + set linelist_body [string map { ""} $linelist_body] + } else { + #punk ansi not avail at time of package load. + #by putting in calls to punk::ansi the user will get appropriate error messages + set linelist_body [string map { "package require punk::ansi"} $linelist_body] + } + proc linelist {args} $linelist_body + + + interp alias {} errortime {} punk::lib::errortime + proc errortime {script groupsize {iters 2}} { + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance + set i 0 + set times {} + if {$iters < 2} {set iters 2} + + for {set i 0} {$i < $iters} {incr i} { + set result [uplevel [list time $script $groupsize]] + lappend times [lindex $result 0] + } + + set average 0.0 + set s2 0.0 + + foreach time $times { + set average [expr {$average + double($time)/$iters}] + } + + foreach time $times { + set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] + } + + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] + + return "$average +/- $sigma microseconds per iteration" + } + + #test function to use with show_jump_tables + #todo - check if switch compilation to jump tables differs by Tcl version + proc switch_char_test {c} { + set dec [scan $c %c] + foreach t [list 1 2 3] { + switch -- $c { + x { + return [list $dec x $t] + } + y { + return [list $dec y $t] + } + z { + return [list $dec z $t] + } + } + } + + #tcl 8.6/8.7 (at least) + #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable + switch -- $c { + a { + return [list $dec a] + } + {"} { + return [list $dec dquote] + } + {[} {return [list $dec lb]} + {]} {return [list $dec rb]} + "{" { + return [list $dec lbrace] + } + "}" { + return [list $dec rbrace] + } + default { + return [list $dec $c] + } + } + + + + } + + #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) + proc show_jump_tables {args} { + #avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06. + if {[llength $args] == 1} { + set data [tcl::unsupported::disassemble proc [lindex $args 0]] + } elseif {[llength $args] == 2} { + #review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself. + #not sure if this handles more complex hierarchies or mixins etc. + lassign $args obj method + if {![info object isa object $obj]} { + error "show_jump_tables unable to examine '$args'. $obj is not an oo object" + } + #classes are objects too and can have direct methods + if {$method in [info object methods $obj]} { + set data [tcl::unsupported::disassemble objmethod $obj $method] + } else { + if {![info object isa class $obj]} { + set obj [info object class $obj] + } + set data [tcl::unsupported::disassemble method $obj $method] + } + } else { + error "show_jump_tables expected a procname or a class/object and method" + } + set result "" + set in_jt 0 + foreach ln [split $data \n] { + set tln [::tcl::string::trim $ln] + if {!$in_jt} { + if {[::tcl::string::match *jumpTable* $ln]} { + punk::ns::call_frame + append result $ln \n + set in_jt 1 + } + } else { + if {[::tcl::string::match Command* $tln] || [::tcl::string::match "(*) *" $tln]} { + set in_jt 0 + } else { + append result $ln \n + } + } + } + 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)}] + } + proc temperature_c_to_f {deg_celsius} { + return [expr {($deg_celsius * (9/5.0)) + 32}] + } + + proc interp_sync_package_paths {interp} { + if {![interp exists $interp]} { + error "interp_sync_package_paths error. interp '$interp' not found. Create it first with \[interp create $interp\]" + } + interp eval $interp [list set ::auto_path $::auto_path] + interp eval $interp {tcl::tm::remove {*}[tcl::tm::list]} + interp eval $interp [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] + } + + proc valcopy {obj} { + append obj2 $obj {} + } + proc set_valcopy {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_valcopy varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + + + proc format_number {numbers_or_commaformattednumbers {delim ""} {groupsize ""}} { + variable has_twapi + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + set localeid [twapi::get_system_default_lcid] + } + } + #when using twapi we currently only get the localeid - not the specific defaults + #when not using twapi, or on non-windows platforms - we don't currently have a mechanism to look up user preferences for this + set default_delim "," + set default_groupsize 3 + + set results [list] + set nums [valcopy $numbers_or_commaformattednumbers] ;#stops single num from getting internal rep of list + foreach inputnum $nums { + set number [valcopy $inputnum] + #also handle tcl 8.7+ underscores in numbers + set number [string map [list _ "" , ""] $number] + #normalize e.g 2e4 -> 20000.0 + set number [expr {$number}] + + if {$has_twapi} { + if {$delim eq "" && $groupsize eq ""} { + lappend results [twapi::format_number $number $localeid -idigits -1] + continue + } else { + #setting just one of delim or groupsize means we don't get the user's localeid based default for the non-set one + #todo - document it? Find a way to lookup localeid based defaults whenever either is unspecified? + if {$delim eq ""} {set delim $default_delim} + if {$groupsize eq ""} {set groupsize $default_groupsize} + lappend results [twapi::format_number $number 0 -idigits -1 -sthousand $delim -sgrouping $groupsize] + continue + } + } + #todo - get configured user defaults + if {$delim eq ""} { + set delim $default_delim + } + if {$groupsize eq ""} { + set groupsize $default_groupsize + } + + lappend results [delimit_number $number $delim $groupsize] + } + + if {[llength $results] == 1} { + #keep intrep as string rather than list + return [lindex $results 0] + } + return $results + } + + + #from wiki https://wiki.tcl-lang.org/page/Delimiting+Numberse + # Given a number represented as a string, insert delimiters to break it up for + # readability. Normally, the delimiter will be a comma which will be inserted every + # three digits. However, the delimiter and groupsize are optional arguments, + # permitting use in other locales. + # + # The string is assumed to consist of digits, possibly preceded by spaces, + # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* + + proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { + set number [valcopy $unformattednumber] + set number [string map {_ ""} $number] + #normalize using expr - e.g 2e4 -> 20000.0 + set number [expr {$number}] + # First, extract right hand part of number, up to and including decimal point + set point [string last "." $number]; + if {$point >= 0} { + set PostDecimal [string range $number $point+1 end]; + set PostDecimalP 1; + } else { + set point [expr {[string length $number] + 1}] + set PostDecimal ""; + set PostDecimalP 0; + } + + # Now extract any leading spaces. review - regex for whitespace instead of just ascii space? + set ind 0; + while {[string equal [string index $number $ind] \u0020]} { + incr ind; + } + set FirstNonSpace $ind; + set LastSpace [expr {$FirstNonSpace - 1}]; + set LeadingSpaces [string range $number 0 $LastSpace]; + + # Now extract the non-fractional part of the number, omitting leading spaces. + set MainNumber [string range $number $FirstNonSpace $point-1]; + + # Insert commas into the non-fractional part. + set Length [string length $MainNumber]; + set Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; + set DelimitedMain ""; + + #First we deal with the extra stuff. + if {$Phase > 0} { + append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; + } + set FirstInGroup $Phase; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; + while {$LastInGroup < $Length} { + if {$FirstInGroup > 0} { + append DelimitedMain $delim; + } + append DelimitedMain [string range $MainNumber $FirstInGroup $LastInGroup]; + incr FirstInGroup $GroupSize + incr LastInGroup $GroupSize + } + + # Reassemble the number. + if {$PostDecimalP} { + return [format "%s%s.%s" $LeadingSpaces $DelimitedMain $PostDecimal]; + } else { + return [format "%s%s" $LeadingSpaces $DelimitedMain]; + } + } + + #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 + #[list_end] [comment {--- end definitions namespace punk::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +tcl::namespace::eval punk::lib::flatgrid { + namespace export filler_count rows cols col row block + + #WARNING - requires lseq and 'lsearch -stride' + #WARNING - lsearch -stride oddity with empty strings https://core.tcl-lang.org/tcl/tktview/edebb6a4 + #todo - 8.6 fallback? + + proc filler_count {listlen numcolumns} { + #if {$numcolumns <= 0} {error "filler_count requires 1 or more numcolumns"} ;#or allow divide by zero error + #if {$listlen == 0} {return $numcolumns} ;#an option - but returning zero might make more sense + expr {($numcolumns - ($listlen % $numcolumns)) % $numcolumns} + } + proc rows {list numcolumns {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set rows [list] + set i 1 + foreach s [lrange $splits 0 end-1] { + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + incr i + } + return $rows + } + proc cols {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] *] + } + return $cols + } + proc cols2 {list numcolumns {blank NULL}} { + set cols [list] + foreach colindex [lseq 0 $numcolumns-1] { + lappend cols [col2 $list $numcolumns $colindex $blank] + } + return $cols + } + proc col {list numcolumns colindex {blank NULL}} { + lsearch -stride $numcolumns -index [list $colindex 0] -subindices -all -inline [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] * + } + proc col2 {list numcolumns colindex {blank NULL}} { + set numblanks [filler_count [llength $list] $numcolumns] + set padded_list [list {*}$list {*}[lrepeat $numblanks $blank]] + set splits [lseq 0 to [llength $padded_list] by $numcolumns] + set col [list] + foreach s [lrange $splits 0 end-1] { + lappend col [lindex $padded_list $s+$colindex] + } + return $col + } + proc col3 {list numcolumns colindex {blank NULL}} { + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap s [lrange [lseq 0 to [llength $padded_list] by $numcolumns] 0 end-1] {lindex $padded_list $s+$colindex} + } + proc col4 {list numcolumns colindex {blank NULL}} { + #slow + set vars [lrepeat $numcolumns _] + lset vars $colindex v + if {$blank eq ""} { + return [lmap $vars $list {set v}] + } + set padded_list [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] + lmap $vars [list {*}$list {*}[lrepeat [filler_count [llength $list] $numcolumns] $blank]] {set v} + } + + proc block {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } + proc block2 {list numcolumns {blank NULL}} { + set colblocks [list] + foreach c [cols2 $list $numcolumns $blank] { + lappend colblocks [join $c \n] " " + } + textblock::join -- {*}$colblocks + } +} + +tcl::namespace::eval punk::lib::test { + + + +} + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#todo - way to generate 'internal' docs separately? +#*** !doctools +#[section Internal] +tcl::namespace::eval punk::lib::system { + #*** !doctools + #[subsection {Namespace punk::lib::system}] + #[para] Internal functions that are not part of the API + #[list_begin definitions] + + + proc mostFactorsBelow {n} { + ##*** !doctools + #[call [fun mostFactorsBelow] [arg n]] + #[para]Find the number below $n which has the greatest number of factors + #[para]This will get slow quickly as n increases (100K = 1s+ 2024) + set most 0 + set mostcount 0 + for {set i 1} {$i < $n} {incr i} { + set fc [llength [punk::lib::factors $i]] + if {$fc > $mostcount} { + set most $i + set mostcount $fc + } + } + return [list number $most numfactors $mostcount] + } + proc factorCountBelow_punk {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [punk::lib::factors $i]] + } + return $tally + } + proc factorCountBelow_numtheory {n} { + ##*** !doctools + #[call [fun factorCountBelow] [arg n]] + #[para]For numbers 1 to n - keep a tally of the total count of factors + #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result + #[para]and as a rudimentary performance comparison + #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) + package require math::numtheory + set tally 0 + for {set i 1} {$i <= $n} {incr i} { + incr tally [llength [math::numtheory::factors $i]] + } + return $tally + } + + proc factors2 {x} { + ##*** !doctools + #[call [fun factors2] [arg x]] + #[para]Return a sorted list of factors of x + #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. + set smallfactors [list 1] + set j 2 + set max [expr {sqrt($x)}] + while {$j < $max} { + if {($x % $j) == 0} { + lappend smallfactors $j + lappend largefactors [expr {$x / $j}] + } + incr j + } + #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop + if {($x % $j) == 0} { + if {$j == ($x / $j)} { + lappend smallfactors $j + } + } + return [concat $smallfactors [lreverse $largefactors] $x] + } + + + + # incomplete - report which is the innermost bracket/quote etc awaiting completion for a Tcl command + #important - used by punk::repl + proc incomplete {partial} { + #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + #puts stderr "-->$clist<--" + set waiting [list ""] + set innerpartials [list ""] + set escaped 0 + set i 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + incr i + continue + } ;# set escaped 0 at end + set p [lindex $innerpartials end] + if {$escaped == 0} { + #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) + switch -- $c { + {"} { + if {![info complete ${p}]} { + lappend waiting {"} + lappend innerpartials "" + } else { + if {[lindex $waiting end] eq {"}} { + #this quote is endquote + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + if {![info complete ${p}$c]} { + lappend waiting {"} + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } + {[} { + if {![info complete ${p}$c]} { + lappend waiting "\]" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "{" { + if {![info complete ${p}$c]} { + lappend waiting "\}" + lappend innerpartials "" + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + "}" - + default { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + set innerpartials [lrange $innerpartials 0 end-1] + } else { + set p ${p}${c} + lset innerpartials end $p + } + } + } + } else { + set p ${p}${c} + lset innerpartials end $p + } + set escaped 0 + incr i + } + set incomplete [list] + foreach w $waiting { + #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. + switch -- $w { + {"} { + lappend incomplete $w + } + {]} { + lappend incomplete "\[" + } + "{" {} + "}" { + lappend incomplete "\{" + } + } + } + set debug 0 + if {$debug} { + foreach w $waiting p $innerpartials { + puts stderr "->awaiting:'$w' partial: $p" + } + } + return $incomplete + } + #This only works for very simple cases will get confused with for example: + # {set x "a["""} + proc incomplete_naive {partial} { + if {[info complete $partial]} { + return [list] + } + set clist [split $partial ""] + set waiting [list] + set escaped 0 + foreach c $clist { + if {$c eq "\\"} { + set escaped [expr {!$escaped}] + continue + } + if {!$escaped} { + if {$c eq {"}} { + if {[lindex $waiting end] eq {"}} { + set waiting [lrange $waiting 0 end-1] + } else { + lappend waiting {"} + } + } elseif {$c eq "\["} { + lappend waiting "\]" + } elseif {$c eq "\{"} { + lappend waiting "\}" + } else { + set waitingfor [lindex $waiting end] + if {$c eq "$waitingfor"} { + set waiting [lrange $waiting 0 end-1] + } + } + } + } + set incomplete [list] + foreach w $waiting { + if {$w eq {"}} { + lappend incomplete $w + } elseif {$w eq "\]"} { + lappend incomplete "\[" + } elseif {$w eq "\}"} { + lappend incomplete "\{" + } + } + return $incomplete + } + + #get info about punk nestindex key ie type: list,dict,undetermined + # pdict devel + proc nestindex_info {args} { + set argd [punk::args::parse $args withdef { + -parent -default "" + nestindex + }] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + #??? + + } + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] +} + +tcl::namespace::eval punk::lib::debug { + proc showdict {args} {} +} + +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::lib +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::lib [tcl::namespace::eval punk::lib { + variable pkg punk::lib + variable version + set version 0.1.4 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm index e0532e41..fea6b146 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm +++ b/src/vfs/_vfscommon.vfs/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/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm index 8e4699dc..677ad6e4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/util-0.1.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/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm index c32ab366..9700ff64 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox-0.1.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/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm index f439ae79..fc1095c8 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/netbox/man-0.1.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/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index 82756da2..4a680500 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.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/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm index f976ae57..e56da520 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.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/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm index 9df5ae56..a074cd76 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl/codethread-0.1.1.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/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm index ff345623..7254fc59 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/safe-0.1.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/vfs/_vfscommon.vfs/modules/punk/trie-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/trie-0.1.0.tm index 0b5bd298..9adb8b36 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/trie-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/trie-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::trie 0 0.1.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 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm index 451ad7a5..9c44ea72 100644 --- a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/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/vfs/_vfscommon.vfs/modules/test/punk/lib-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/test/punk/lib-0.1.3.tm index cd98ac59..bc88302c 100644 Binary files a/src/vfs/_vfscommon.vfs/modules/test/punk/lib-0.1.3.tm and b/src/vfs/_vfscommon.vfs/modules/test/punk/lib-0.1.3.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm index d83c17d9..93e4a41c 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.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.