diff --git a/src/bootsupport/modules/punk/aliascore-0.1.0.tm b/src/bootsupport/modules/punk/aliascore-0.1.0.tm index 3d1d87e9..5b45b2bc 100644 --- a/src/bootsupport/modules/punk/aliascore-0.1.0.tm +++ b/src/bootsupport/modules/punk/aliascore-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] #[copyright "2024"] #[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::aliascore] #[keywords module alias] #[description] @@ -98,7 +98,7 @@ package require Tcl 8.6- # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::aliascore { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable aliases #use absolute ns ie must be prefixed with :: #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased @@ -136,7 +136,7 @@ tcl::namespace::eval punk::aliascore { #*** !doctools #[subsection {Namespace punk::aliascore}] - #[para] Core API functions for punk::aliascore + #[para] Core API functions for punk::aliascore #[list_begin definitions] @@ -144,13 +144,13 @@ tcl::namespace::eval punk::aliascore { #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" #} #todo - options as to whether we should raise an error if collisions found, undo aliases etc? @@ -208,13 +208,13 @@ tcl::namespace::eval punk::aliascore { #todo - ensure exported? noclobber? if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { #puts stderr "importing $cmd" - tcl::namespace::eval :: [list namespace import $cmd] + tcl::namespace::eval :: [list namespace import $cmd] } else { #target command name differs from exported name #e.g stripansi -> punk::ansi::ansistrip #import and rename #puts stderr "importing $cmd (with rename to ::$a)" - tcl::namespace::eval $tempns [list namespace import $cmd] + tcl::namespace::eval $tempns [list namespace import $cmd] catch {rename ${tempns}::[namespace tail $cmd] ::$a} } } else { @@ -242,18 +242,18 @@ tcl::namespace::eval punk::aliascore { # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::aliascore::lib { - namespace export {[a-z]*} ;# Convention: export all lowercase + namespace export {[a-z]*} ;# Convention: export all lowercase namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::aliascore::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 + # #[para]Description of utility1 + # return 1 #} @@ -271,17 +271,17 @@ namespace eval punk::aliascore::lib { namespace eval punk::aliascore::system { #*** !doctools #[subsection {Namespace punk::aliascore::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::aliascore [namespace eval punk::aliascore { variable pkg punk::aliascore variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index b367be2a..50ea5082 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -19,21 +19,21 @@ #[manpage_begin punkshell_module_punk::ansi 0 0.1.1] #[copyright "2023"] #[titledesc {Ansi string functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] +#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] #[require punk::ansi] #[keywords module ansi terminal console string] #[description] -#[para]Ansi based terminal control string functions -#[para]See [package punk::ansi::console] for related functions for controlling a console +#[para]Ansi based terminal control string functions +#[para]See [package punk::ansi::console] for related functions for controlling a console # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Overview] -#[para] overview of punk::ansi +#[para] overview of punk::ansi #[para]punk::ansi functions return their values - no implicit emission to console/stdout #[subsection Concepts] -#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner +#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner #[para]There are many differences in terminal implementations - but most should support a core set of features #[para]punk::ansi does not contain any code for direct terminal manipulation via the local system APIs. #[para]Sticking to ansi codes where possible may be better for cross-platform and remote operation where such APIs are unlikely to be useable. @@ -45,7 +45,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::ansi +#[para] packages used by punk::ansi #[list_begin itemized] package require Tcl 8.6- @@ -72,7 +72,7 @@ tcl::namespace::eval punk::ansi::class { if {![llength [tcl::info::commands class_ansi]]} { oo::class create class_ansi { - variable o_ansistringobj + variable o_ansistringobj variable o_render_dimensions ;#last dimensions at which we rendered variable o_rendered @@ -83,7 +83,7 @@ tcl::namespace::eval punk::ansi::class { } #a straight string compare may be faster.. but a checksum is much smaller in memory, so we'll use that by default. - set o_rendered_what "" + set o_rendered_what "" #There may also be advantages to renering to a class_ansistring class object set o_render_dimensions $dimensions @@ -100,7 +100,7 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set cksum "not-done" - if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { + if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { #some ansi layout/art relies on wrapping at the width-dimension to display properly #this includes cursor movements ie right arrow can move cursor to columns in lines below #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. @@ -111,7 +111,7 @@ tcl::namespace::eval punk::ansi::class { #if dimensions changed - the checksum won't have been done set o_rendered_what [$o_ansistringobj checksum] } else { - set o_rendered_what $cksum + set o_rendered_what $cksum } set o_render_dimensions $dimensions } @@ -127,8 +127,8 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set o_dimensions $dimensions - - + + set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } @@ -185,12 +185,12 @@ tcl::namespace::eval punk::ansi::class { set lfvis [ansistring VIEW -lf 1 \n] set maplf [list \n "[a+ green bold reverse]${lfvis}[a]\n"] ;#a mapping to highlight newlines - set lines [split [$o_ansistringobj get] \n] + set lines [split [$o_ansistringobj get] \n] set rlines [lrange $lines 0 $x] - set chunk [::join $rlines \n] + set chunk [::join $rlines \n] append chunk \n if {$opt_minus ne "0"} { - set chunk [tcl::string::range $chunk 0 end-$opt_minus] + 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 marker "" @@ -212,7 +212,7 @@ tcl::namespace::eval punk::ansi::class { 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 + #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 renderheight [llength [split $rendered \n]] set chunkdisplay_lines [split $chunkdisplay \n] @@ -221,7 +221,7 @@ tcl::namespace::eval punk::ansi::class { #the input chunk lines are often much longer than the output.. resulting in main content being way up the screen. It's often impractical to view more than the tail of the chunkdisplay. textblock::join -- $rendered $chunkdisplay_block } - + method checksum {} { return [$o_ansistringobj checksum] } @@ -237,7 +237,7 @@ tcl::namespace::eval punk::ansi::class { -lf 0\ -vt 0\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -267,7 +267,7 @@ tcl::namespace::eval punk::ansi::class { method viewchars {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -295,7 +295,7 @@ tcl::namespace::eval punk::ansi::class { method viewstyle {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -338,20 +338,20 @@ tcl::namespace::eval punk::ansi::class { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ansi { - variable PUNKARGS + variable PUNKARGS #*** !doctools #[subsection {Namespace punk::ansi}] - #[para] Core API functions for punk::ansi + #[para] Core API functions for punk::ansi #[list_begin definitions] - #old-school ansi graphics - C0 control glyphs. - variable cp437_map + #old-school ansi graphics - C0 control glyphs. + variable cp437_map #for cp437 images we need to map these *after* splitting ansi, to single-width unicode chars #It would also probably be problematic to map \u000A to the glyph - as this is the newline - it included in the map anyway for completeness. The caller may have to manually carve that or other specific c0 controls out of the map to use it depending on the situation(?) #Layout for cp437 won't be right if you don't at least set width of control-chars to 1 - but also some images specifically use these glyphs - #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too + #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too #by mapping these we can display regardless. - #nul char - no cp437 image but commonly used as space in ansi graphics. + #nul char - no cp437 image but commonly used as space in ansi graphics. #(This is a potential conflict because we use nul as a filler to mean empty column in overtype rendering) REVIEW tcl::dict::set cp437_map \u0000 " " ;#space tcl::dict::set cp437_map \u0001 \u263A ;#smiley @@ -377,11 +377,11 @@ tcl::namespace::eval punk::ansi { tcl::dict::set cp437_map \u0015 \u00A7 ;#Section Sign tcl::dict::set cp437_map \u0016 \u25AC ;#Heavy horizontal? tcl::dict::set cp437_map \u0017 \u21A8 ;#updown arrow 2 ? - tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow - tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow - tcl::dict::set cp437_map \u001A \u2192 ;#right arrow - tcl::dict::set cp437_map \u001B \u2190 ;#left arrow - tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner + tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow + tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow + tcl::dict::set cp437_map \u001A \u2192 ;#right arrow + tcl::dict::set cp437_map \u001B \u2190 ;#left arrow + tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner tcl::dict::set cp437_map \u001D \u2194 ;#left-right arrow tcl::dict::set cp437_map \u001E \u25B2 ;#up arrow triangle tcl::dict::set cp437_map \u001F \u25BC ;#down arrow triangle @@ -396,7 +396,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics c \u240c ;#symbol for FF tcl::dict::set map_special_graphics d \u240d ;#symbol for CR tcl::dict::set map_special_graphics e \u240a ;#symbol for LF - tcl::dict::set map_special_graphics f \u00b0 ;#degree sign + tcl::dict::set map_special_graphics f \u00b0 ;#degree sign tcl::dict::set map_special_graphics g \u00b1 ;#plus-minus sign tcl::dict::set map_special_graphics h \u2424 ;#symbol for NL tcl::dict::set map_special_graphics i \u240b ;#symbol for VT @@ -408,8 +408,8 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics o \u23ba ;#horizontal scan line-1 tcl::dict::set map_special_graphics p \u23bb ;#horizontal scan line-3 tcl::dict::set map_special_graphics q \u2500 ;#light horizontal - box drawing - tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 - tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 + tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 + tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 tcl::dict::set map_special_graphics t \u251c ;#light vertical and right - box drawing tcl::dict::set map_special_graphics u \u2524 ;#light vertical and left - box drawing tcl::dict::set map_special_graphics v \u2534 ;#light up and horizontal - box drawing @@ -419,10 +419,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics z \u2265 ;#greater than or equal tcl::dict::set map_special_graphics "\{" \u03c0 ;#greek small letter pi tcl::dict::set map_special_graphics "|" \u2260 ;#not equal to - tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign + tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign tcl::dict::set map_special_graphics ~ \u00b7 ;#middle dot - #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control + #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control variable test "blah\033\[1;33mETC\033\[0;mOK" @@ -451,14 +451,14 @@ tcl::namespace::eval punk::ansi { 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\\ \u009c] ;#note mix of 1 and 2-byte terminals + #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\\ \u009c] ;#note mix of 1 and 2-byte terminals tcl::dict::set escape_terminals DCS [list \007 \033\\ \u009c] tcl::dict::set escape_terminals MISC [list \007 \033\\ \u009c] - #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) + #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) #This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows? - #review - there doesn't seem to be an \x1b#7 + #review - there doesn't seem to be an \x1b#7 # https://espterm.github.io/docs/VT100%20escape%20codes.html #self-contained 2 byte ansi escape sequences - review more? @@ -479,9 +479,9 @@ tcl::namespace::eval punk::ansi { #comparitive test (performance) string-append vs 2-object (with existing splits) append proc test_cat1 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -492,13 +492,13 @@ tcl::namespace::eval punk::ansi { $s2 destroy #$s1 append \033\[31mX ;#redX - return $s1 + return $s1 } proc test_cat2 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -513,12 +513,12 @@ tcl::namespace::eval punk::ansi { # -------------------------------------- - #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? + #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? #In testing old ansi graphics files available on the web, some files need encoding {utf-8 cp437} some just cp437 proc readfile {fname {encoding cp437}} { - #todo + #todo #1- look for BOM - read according to format given by BOM - #2- assume utf-8 + #2- assume utf-8 #3- if errors - assume cp437? if {[llength $encoding] == 1} { @@ -605,7 +605,7 @@ tcl::namespace::eval punk::ansi { Defaults to /src/testansi - where projectbase is determined from the current directory. " - @values -min 0 -max -1 + @values -min 0 -max -1 files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help\ "List of filenames - leave empty to display 4 defaults" } ""] @@ -620,7 +620,7 @@ tcl::namespace::eval punk::ansi { set fnames [dict get $argd values files] #assumes fixed column widths e.g 80col images will fit in 82-width frames (common standard for old ansi art) (of arbitrary height) - #todo - review dependency on punk::repo ? + #todo - review dependency on punk::repo ? package require textblock package require punk::repo package require punk::console @@ -630,13 +630,13 @@ tcl::namespace::eval punk::ansi { puts stderr "Ensure ansi test files exist: $fnames" #error "punk::ansi::example Cannot find example files" } - set termsize [punk::console:::get_size] + set termsize [punk::console:::get_size] set termcols [dict get $termsize columns] set margin 4 ;#review set freewidth [expr {$termcols-$margin}] if {$freewidth < $colwidth} { puts stderr "[a+ red bold]punk::ansi::example freewidth: $freewidth < colwidth: $colwidth TRUNCATING IMAGES[a]" - set colwidth $freewidth + set colwidth $freewidth } set per_row [expr {$freewidth / $colwidth}] @@ -655,7 +655,7 @@ tcl::namespace::eval punk::ansi { #set img [join [lines_as_list -line trimline -block trimtail [ansicat $filepath]] \n] #-line trimline will wreck some images set img [join [lines_as_list -block trimtail [ansicat $filepath]] \n] - lappend pics [tcl::dict::create filename $f pic $img status ok] + lappend pics [tcl::dict::create filename $f pic $img status ok] } } @@ -670,13 +670,13 @@ tcl::namespace::eval punk::ansi { foreach picinfo $pics { set subtitle "" if {[tcl::dict::get $picinfo status] ne "ok"} { - set subtitle [tcl::dict::get $picinfo status] + set subtitle [tcl::dict::get $picinfo status] } set title [tcl::dict::get $picinfo filename] set fr [textblock::frame -checkargs 0 -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] - # -- --- --- --- + # -- --- --- --- #we need the max height of a row element to use join_basic instead of join below - # -- --- --- --- + # -- --- --- --- set fr_height [textblock::height $fr] lappend row $fr lappend rowh $fr_height @@ -691,8 +691,8 @@ tcl::namespace::eval punk::ansi { set rowmax $fr_height lset maxheights end $rowmax } - } - # -- --- --- --- + } + # -- --- --- --- if {$i % $per_row == 0} { lappend rowlist $row @@ -718,9 +718,9 @@ tcl::namespace::eval punk::ansi { if {$h < $maxheight} { #add blank lines to bottom of shorter images so join_basic can be used. #textblock::join of ragged-height images would work and remove the need for all the height calculation - #.. but it requires much more processing + #.. but it requires much more processing append i [string repeat \n$blankline [expr {$maxheight - $h}]] - } + } lappend adjusted_row $i } append result [textblock::join_basic -- {*}$adjusted_row] \n @@ -746,12 +746,12 @@ tcl::namespace::eval punk::ansi { #b) DEVICE CONTROL STRING (DCS) #c) OPERATING SYSTEM COMMAND (OSC) #d) PRIVACY MESSAGE (PM) - #e) START OF STRING (SOS) + #e) START OF STRING (SOS) # #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ - #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. + #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. #todo - review - printing_length calculations affected by whether terminal honours PMs or not. detect and accomodate. #review - can terminals handle SGR codes within a PM? #Wezterm will hide PM,SOS,APC - but not any part following an SGR code - i.e it seems to terminate hiding before the ST (apparently at the ) @@ -779,7 +779,7 @@ tcl::namespace::eval punk::ansi { #candidate for zig/c implementation? proc stripansi2 {text} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters join [::punk::ansi::ta::split_at_codes $text] "" } @@ -793,7 +793,7 @@ tcl::namespace::eval punk::ansi { #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - #set re {\033\(0[^\033]*\033\(B} + #set re {\033\(0[^\033]*\033\(B} #set re {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} #set re2 {\033\(0(.*)\033\(B} ;#capturing @@ -806,9 +806,9 @@ tcl::namespace::eval punk::ansi { #don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this. - set re_g0_open_or_close {\x1b\(0|\x1b\(B} + set re_g0_open_or_close {\x1b\(0|\x1b\(B} set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text] - set out {} + set out {} set g0_on 0 foreach {other g} $parts { if {$g0_on} { @@ -838,7 +838,7 @@ tcl::namespace::eval punk::ansi { #That will either stop us matching - so no conversion - or risk converting parts of the ansi codes #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - set re {\033\(0[^\033]*\033\(B} + set re {\033\(0[^\033]*\033\(B} set re2 {\033\(0(.*)\033\(B} ;#capturing #box sample @@ -902,10 +902,10 @@ tcl::namespace::eval punk::ansi { #Note that SYN (\016) seems to put terminals in a state #where alternate graphics are not processed. #an ETB (\017) needs to be sent to get alt graphics working again. - #It isn't known what software utilises SYN/ETB within altg sequences + #It isn't known what software utilises SYN/ETB within altg sequences # (presumably to alternate between the charsets within a graphics-on/graphics-off section) #but as modern emulators seem to react to it, we should handle it. - #REVIEW - this mapping not fully understood + #REVIEW - this mapping not fully understood #used by groptim variable grforw variable grback @@ -938,10 +938,10 @@ tcl::namespace::eval punk::ansi { proc ansistrip_gx {text} { #e.g "\033(0" - select VT100 graphics for character set G0 - #e.g "\033(B" - reset + #e.g "\033(B" - reset #e.g "\033)0" - select VT100 graphics for character set G1 #e.g "\033)X" - where X is any char other than 0 to reset ?? - + #return [convert_g0 $text] return [tcl::string::map [list \x1b(0 "" \x1b(B "" \x1b)0 "" \x1b)X ""] $text] } @@ -953,7 +953,7 @@ tcl::namespace::eval punk::ansi { #CSI m = SGR (Select Graphic Rendition) #leave map unindented - used both as a dict and for direct display variable SGR_setting_map { -reset 0 bold 1 dim 2 italic 3 noitalic 23 +reset 0 bold 1 dim 2 italic 3 noitalic 23 underline 4 doubleunderline 21 nounderline 24 blink 5 fastblink 6 noblink 25 reverse 7 noreverse 27 hide 8 nohide 28 strike 9 nostrike 29 normal 22 defaultfg 39 defaultbg 49 overline 53 nooverline 55 @@ -967,26 +967,26 @@ Black 40 Red 41 Green 42 Yellow 43 Blue brightblack 90 brightred 91 brightgreen 92 brightyellow 93 brightblue 94 brightpurple 95 brightcyan 96 brightwhite 97 Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblue 104 Brightpurple 105 Brightcyan 106 Brightwhite 107 } - variable SGR_map ;#public - part of interface - review + variable SGR_map ;#public - part of interface - review set SGR_map [tcl::dict::merge $SGR_colour_map $SGR_setting_map] #we use prefixes e.g web-white and/or x11-white #Only a leading capital letter will indicate the colour target is background vs lowercase for foreground - #In the map key-lookup context the colour names will be canonically lower case + #In the map key-lookup context the colour names will be canonically lower case #We should be case insensitive in the non-prefix part ie after determining fg/bg target from first letter of the prefix - #e.g Web-Lime or Web-lime are ok and are targeting background + #e.g Web-Lime or Web-lime are ok and are targeting background #foreground target examples: web-Lime web-LIME web-DarkSalmon web-Darksalmon #specified in decimal - but we should also accept hex format directly in a+ function e.g #00FFFF for aqua - variable WEB_colour_map + variable WEB_colour_map #use the totitle format as the canonical lookup key #don't use leading zeros - keep compatible with earlier tcl and avoid octal issue - # -- --- --- + # -- --- --- #css 1-2.0 HTML 3.2-4 Basic colours eg web-silver for fg Web-silver for bg # variable WEB_colour_map_basic tcl::dict::set WEB_colour_map_basic white 255-255-255 ;# #FFFFFF - tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 + tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 tcl::dict::set WEB_colour_map_basic gray 128-128-128 ;# #808080 tcl::dict::set WEB_colour_map_basic black 0-0-0 ;# #000000 tcl::dict::set WEB_colour_map_basic red 255-0-0 ;# #FF0000 @@ -1001,7 +1001,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_basic navy 0-0-128 ;# #000080 tcl::dict::set WEB_colour_map_basic fuchsia 255-0-255 ;# #FF00FF tcl::dict::set WEB_colour_map_basic purple 128-0-128 ;# #800080 - # -- --- --- + # -- --- --- #Pink colours variable WEB_colour_map_pink tcl::dict::set WEB_colour_map_pink mediumvioletred 199-21-133 ;# #C71585 @@ -1010,7 +1010,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_pink hotpink 255-105-180 ;# #FF69B4 tcl::dict::set WEB_colour_map_pink lightpink 255-182-193 ;# #FFB6C1 tcl::dict::set WEB_colour_map_pink pink 255-192-203 ;# #FFCOCB - # -- --- --- + # -- --- --- #Red colours variable WEB_colour_map_red tcl::dict::set WEB_colour_map_red darkred 139-0-0 ;# #8B0000 @@ -1022,7 +1022,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_red salmon 250-128-114 ;# #FA8072 tcl::dict::set WEB_colour_map_red darksalmon 233-150-122 ;# #E9967A tcl::dict::set WEB_colour_map_red lightsalmon 255-160-122 ;# #FFA07A - # -- --- --- + # -- --- --- #Orange colours variable WEB_colour_map_orange tcl::dict::set WEB_colour_map_orange orangered 255-69-0 ;# #FF4500 @@ -1030,7 +1030,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_orange darkorange 255-140-0 ;# #FF8C00 tcl::dict::set WEB_colour_map_orange coral 255-127-80 ;# #FF7F50 tcl::dict::set WEB_colour_map_orange orange 255-165-0 ;# #FFA500 - # -- --- --- + # -- --- --- #Yellow colours variable WEB_colour_map_yellow tcl::dict::set WEB_colour_map_yellow darkkhaki 189-183-107 ;# #BDB76B @@ -1044,7 +1044,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_yellow lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 tcl::dict::set WEB_colour_map_yellow lemonchiffon 255-250-205 ;# #FFFACD tcl::dict::set WEB_colour_map_yellow lightyellow 255-255-224 ;# #FFFFE0 - # -- --- --- + # -- --- --- #Brown colours #maroon as above variable WEB_colour_map_brown @@ -1064,7 +1064,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_brown bisque 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown blanchedalmond 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown cornsilk 255-248-220 ;# #FFF8DC - # -- --- --- + # -- --- --- #Purple, violet, and magenta colours variable WEB_colour_map_purple tcl::dict::set WEB_colour_map_purple indigo 75-0-130 ;# #4B0082 @@ -1074,7 +1074,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple darkslateblue 72-61-139 ;# #9400D3 tcl::dict::set WEB_colour_map_purple blueviolet 138-43-226 ;# #8A2BE2 tcl::dict::set WEB_colour_map_purple darkorchid 153-50-204 ;# #9932CC - tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF + tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF tcl::dict::set WEB_colour_map_purple magenta 255-0-255 ;# #FF00FF - same as fuchsia tcl::dict::set WEB_colour_map_purple slateblue 106-90-205 ;# #6A5ACD tcl::dict::set WEB_colour_map_purple mediumslateblue 123-104-238 ;# #7B68EE @@ -1085,7 +1085,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD tcl::dict::set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8 tcl::dict::set WEB_colour_map_purple lavender 230-230-250 ;# #E6E6FA - # -- --- --- + # -- --- --- #Blue colours variable WEB_colour_map_blue tcl::dict::set WEB_colour_map_blue midnightblue 25-25-112 ;# #191970 @@ -1103,7 +1103,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_blue lightsteelblue 176-196-222 ;# #B0C4DE tcl::dict::set WEB_colour_map_blue lightblue 173-216-230 ;# #ADD8E6 tcl::dict::set WEB_colour_map_blue powderblue 176-224-230 ;# #B0E0E6 - # -- --- --- + # -- --- --- #Cyan colours #teal as above variable WEB_colour_map_cyan @@ -1114,11 +1114,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_cyan mediumturquoise 72-209-204 ;# #48D1CC tcl::dict::set WEB_colour_map_cyan turquoise 64-224-208 ;# #40E0D0 tcl::dict::set WEB_colour_map_cyan aqua 0-255-255 ;# #00FFFF - tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua + tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua tcl::dict::set WEB_colour_map_cyan aquamarine 127-255-212 ;# #7FFFD4 tcl::dict::set WEB_colour_map_cyan paleturquoise 175-238-238 ;# #AFEEEE tcl::dict::set WEB_colour_map_cyan lightcyan 224-255-255 ;# #E0FFFF - # -- --- --- + # -- --- --- #Green colours variable WEB_colour_map_green tcl::dict::set WEB_colour_map_green darkgreen 0-100-0 ;# #006400 @@ -1141,7 +1141,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_green lightgreen 144-238-144 ;# #90EE90 tcl::dict::set WEB_colour_map_green greenyellow 173-255-47 ;# #ADFF2F tcl::dict::set WEB_colour_map_green palegreen 152-251-152 ;# #98FB98 - # -- --- --- + # -- --- --- #White colours variable WEB_colour_map_white tcl::dict::set WEB_colour_map_white mistyrose 255-228-225 ;# #FFE4E1 @@ -1161,7 +1161,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_white snow 255-250-250 ;# #FFFAFA tcl::dict::set WEB_colour_map_white ivory 255-255-240 ;# #FFFFF0 tcl::dict::set WEB_colour_map_white white 255-255-255 ;# #FFFFFF - # -- --- --- + # -- --- --- #Gray and black colours variable WEB_colour_map_gray tcl::dict::set WEB_colour_map_gray black 0-0-0 ;# #000000 @@ -1202,8 +1202,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #Xterm colour names (256 colours) - #lists on web have duplicate names - #these have been renamed here in a systematic way: + #lists on web have duplicate names + #these have been renamed here in a systematic way: #They are suffixed with a dash and a letter e.g second deepskyblue4 -> deepskyblue4-b, third deepskyblue4 -> deepskyblue4-c #presumably the xterm colour names are not widely used or are used for reverse lookup from rgb to get an approximate name in the case of dupes? #Review! @@ -1215,10 +1215,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95) #Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway. #The xterm names are boringly unimaginative - and also have some oddities such as: - # DarkSlateGray1 which looks much more like cyan.. + # DarkSlateGray1 which looks much more like cyan.. # The greyxx names are spelt with an e - but the darkslategrayX variants use an a. Perhaps that's because they are more cyan than grey and the a is a hint? # there is no gold or gold2 - but there is gold1 and gold3 - #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. + #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. set xterm_names [list\ black\ @@ -1500,7 +1500,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {!$did_rename} { - error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" + error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" } } incr cidx @@ -1510,7 +1510,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #colour_hex2ansidec - #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) + #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) #we want to support arbitrary rgb values specified in hex - so a table of 16M+ is probably not a great idea #hex zero-padded - canonically upper case but mixed or lower accepted #dict for {k v} $WEB_colour_map { @@ -1539,7 +1539,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable SGR_map return $SGR_map } - + proc colourmap1 {args} { set opts {-bg Web-white -forcecolour 0} foreach {k v} $args { @@ -1603,7 +1603,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } package require textblock set clist [list] - set fg "black" + set fg "black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "black"} { @@ -1647,14 +1647,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::get $opts -forcecolour]} { set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 0} {$i <=15} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? + set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? if {[llength $row]== 8} { lappend rows $row set row [list] @@ -1686,7 +1686,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } set out "" - set fg "web-black" + set fg "web-black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "web-black"} { @@ -1694,7 +1694,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set fg "web-black" } - set br "\n" + set br "\n" } else { set br "" } @@ -1716,10 +1716,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set out "" #use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-black" + set fg "web-black" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 16} {$i <=231} {incr i} { @@ -1892,10 +1892,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_hseps 0 -show_edge 0 for {set i 232} {$i <=255} {incr i} { @@ -1955,7 +1955,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray] switch -- $groups { "" - * { - set show_groups $all_groupnames + set show_groups $all_groupnames } ? { return "Web group names: $all_groupnames" @@ -1996,7 +1996,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] } - $t configure -frametype {} + $t configure -frametype {} $t configure_column 0 -headers [list "[tcl::string::totitle $g] colours"] $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] @@ -2106,7 +2106,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST" set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST" set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST" - set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" + set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" append out "${indent}$undercurly $underdotted" \n append out "${indent}$underdashed" \n append out "${indent}$underline_c" \n @@ -2115,7 +2115,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out "${indent}If a fallback to standard underline is required, underline should be added along with extended codes such as underlinedotted, underlinedouble etc" \n append out "${indent}e.g cyan with curly yellow underline or fallback all cyan underlined \[a+ cyan undercurly underline undt-yellow\]text\[a] -> [a+ {*}$fc cyan undercurly underline undt-yellow]text$RST" \n append out "[a+ {*}$fc web-white]Standard SGR colours and attributes $RST" \n - set settings_applied $SGR_setting_map + set settings_applied $SGR_setting_map set strmap [list] #safe jumptable test #dict for {k v} $SGR_setting_map {} @@ -2139,7 +2139,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try package require textblock - append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n + append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n set bgname "Web-white" @@ -2287,7 +2287,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::exists $TERM_colour_map $tail]} { set descr [tcl::dict::get $TERM_colour_map $tail] } else { - set descr "UNKNOWN colour for term" + set descr "UNKNOWN colour for term" } } $t add_row [list $i $descr $s [ansistring VIEW $s]] @@ -2303,11 +2303,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t add_row [list $i $descr $s [ansistring VIEW $s]] } - rgb- - Rgb- - RGB- - - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - + rgb- - Rgb- - RGB- - + rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - - rgb# - Rgb# - RGB# - + RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - + rgb# - Rgb# - RGB# - und# - und- { set cont [string range $i end-11 end] switch -- $cont { @@ -2430,7 +2430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #REVIEW! note that OSC 4 can change the 256 color pallette - #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ + #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ # (or with colour name instead of rgb #HHHHHH on for example wezterm) #Q: If we can't detect OSC 4 - how do we know when to invalidate/clear at least the 256 color portion of the cache? @@ -2492,13 +2492,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set linelen $thislen } else { append line "$ansi$key$RST " - incr linelen $thislen + incr linelen $thislen } } if {[tcl::string::length $line]} { lappend lines $line } - return [join $lines \n] + return [join $lines \n] } #PUNKARGS doc performed below, after we create the proc @@ -2506,10 +2506,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun a+] [opt {ansicode...}]] #[para]Returns the ansi code to apply those from the supplied list - without any reset being performed first - #[para] e.g to set foreground red and bold + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #function name part of cache-key because a and a+ return slightly different results (a has leading reset) @@ -2538,7 +2538,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set args [lremove $args $fcpos] } - set t [list] + set t [list] set e [list] ;#extended codes needing to go in own escape sequence foreach i $args { set f4 [tcl::string::range $i 0 3] @@ -2560,7 +2560,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] switch -- $cont { -contrasting { set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] @@ -2592,7 +2592,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] switch -- $cont { -contrasting { set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] @@ -2629,13 +2629,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu unde { #TODO - fix # extended codes with colon suppress normal SGR attributes when in same escape sequence on terminal that don't support the extended codes. - # need to emit in + # need to emit in switch -- $i { underline { lappend t 4 ;#underline } underlinedefault { - lappend t 59 + lappend t 59 } underextendedoff { #lremove any existing 4:1 etc @@ -2689,7 +2689,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -2749,10 +2749,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a+ $args'" } @@ -2763,19 +2763,19 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a+ $args'" } } } - rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - + rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { #decimal rgb foreground/background - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx set cont [string range $i end-11 end] switch -- $cont { @@ -2832,8 +2832,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx #https://wezfurlong.org/wezterm/escape-sequences.html#csi-582-underline-color-rgb set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set RGB [lrange [tcl::string::map [list - { } , { } {;} { }] $rgbspec] 0 2] @@ -2854,7 +2854,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend e "58:2::$rgbfinal" } "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] #set rgb [join [::scan $hex6 %2X%2X%2X] {:}] set RGB [::scan $hex6 %2X%2X%2X] @@ -2880,10 +2880,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -2894,7 +2894,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -2906,7 +2906,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -2927,10 +2927,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #the performance penalty must not be placed on the standard colour_enabled path. #This is punk. Colour is the happy path despite the costs. - #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. - #As no_color doesn't strip all ansi - the motivation for it should not generally be + #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. + #As no_color doesn't strip all ansi - the motivation for it should not generally be if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -2940,7 +2940,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -2994,12 +2994,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 0-255 int values for red, green and blue. rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 web- Web- - + The acceptable values for and can be queried using punk::ansi::a? term and punk::ansi::a? web - + Example to set foreground red and background cyan followed by a reset: set str \"[a+ red Cyan]sample text[a]\" " @@ -3009,11 +3009,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun a] [opt {ansicode...}]] #[para]Returns the ansi code to reset any current settings and apply those from the supplied list - #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text - #[para] e.g to set foreground red and bold + #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #It's important to put the functionname in the cache-key because a and a+ return slightly different results @@ -3041,7 +3041,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set args [lremove $args $fcpos] } - set t [list] + set t [list] set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence foreach i $args { set f4 [tcl::string::range $i 0 3] @@ -3052,7 +3052,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground web colour set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] set rgb [tcl::string::map { - ;} $rgbdash] lappend t "38;2;$rgb" } else { @@ -3093,7 +3093,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend t 4 ;#underline } underlinedefault { - lappend t 59 + lappend t 59 } underextendedoff { #lremove any existing 4:1 etc @@ -3147,7 +3147,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -3207,10 +3207,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a $args'" } @@ -3221,10 +3221,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a $args'" } @@ -3232,7 +3232,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 { #decimal rgb foreground - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] lappend t "38;2;$rgb" @@ -3256,14 +3256,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend t "48;2;$rgb" } und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set rgb [tcl::string::map [list - {:} , {:}] $rgbspec] lappend e "58:2::$rgb" } "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] set rgb [join [::scan $hex6 %2X%2X%2X] {:}] lappend e "58:2::$rgb" @@ -3274,10 +3274,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -3288,7 +3288,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -3300,7 +3300,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -3318,9 +3318,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - + if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -3330,7 +3330,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -3431,7 +3431,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun reset]] #[para]reset console - return "\x1bc" + return "\x1bc" } proc reset_soft {} { #*** !doctools @@ -3450,7 +3450,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun reset_colour]] #[para]reset colour only - return "\x1b\[0m" + return "\x1b\[0m" } # -- --- --- --- --- @@ -3578,7 +3578,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu Sequence is of the form: ESCY - This sequence will generally not be understood by terminals + This sequence will generally not be understood by terminals that are not in vt52 mode (e.g DECANM unset). } @values -min 2 -max 2 @@ -3605,7 +3605,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu proc move_emit {row col data args} { #*** !doctools #[call [fun move_emit] [arg row] [arg col] [arg data] [opt {row col data...}]] - #[para]Return an ansi string representing a move to row col with data appended + #[para]Return an ansi string representing a move to row col with data appended #[para]row col data can be repeated any number of times to return a string representing the output of the data elements at all those points #[para]Compare to punk::console::move_emit which calls this function - but writes it to stdout #[para]punk::console::move_emit_return will also return the cursor to the original position @@ -3773,13 +3773,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return \x1b\[3l } - #DECSNM + #DECSNM #Note this can invert the enclosed section including any already reversed by SGR 7 - depending on terminal support. - #e.g + #e.g #set test [a+ reverse]aaa[a+ noreverse]bbb # - $test above can't just be reversed by putting another [a+ reverse] in front of it. # - but the following will work (even if underlying terminal doesn't support ?5 sequences) - #overtype::renderspace -width 20 [enable_inverse]$test + #overtype::renderspace -width 20 [enable_inverse]$test proc enable_inverse {} { return \x1b\[?5h } @@ -3818,7 +3818,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # \x1b\[?7\;1\$y # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - + #https://wiki.tau.garden/dec-modes/ #(DEC,xterm,contour,mintty,kitty etc) #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking @@ -3837,7 +3837,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # mouse_urxvt 1015\ # mouse_sgr_pixel 1016\ #] - variable decmode_data { + variable decmode_data { 1 { {origin DEC description "DECCKM - Cursor Keys Mode" names {DECCKM cursor_keys}} } @@ -3864,7 +3864,7 @@ In VT52 mode - use \x1b< to exit. {origin "xterm" description "X10 compatibility mouse" names {SET_X10_MOUSE mouse_tracking} note { Escape sequence on button press only. CSI M CbCxCy (6 chars) -Coords limited to 223 (=255 - 32) +Coords limited to 223 (=255 - 32) } } {origin DEC description "DECINLM - Interlace Mode (obsolete?)" names {DECINLM}} @@ -3925,7 +3925,7 @@ to 223 (=255 - 32) 2004 { {origin "xterm" description "Set bracketed paste mode" names {bracketed_paste}} } - 2027 { + 2027 { {origin Contour description "Grapheme Cluster Processing" names {grapheme_clusters}} } } @@ -3936,7 +3936,7 @@ to 223 (=255 - 32) foreach nm $names { dict set decmode_names $nm $code } - } + } } @@ -3960,12 +3960,12 @@ to 223 (=255 - 32) #Alt screen buffer - smcup/rmcup ti/te #Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty) - #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. + #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. #see: https://xn--rpa.cc/irl/term.html #1049 (introduced by xterm in 1998?) considered the more modern version? #1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence #1049 - includes save cursor,switch to alt screen, clear screen - #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) + #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) #SMCUP # \x1b7 (save cursor) # \x1b\[?47h (switch) @@ -3973,10 +3973,10 @@ to 223 (=255 - 32) #RMCUP # \x1b\[?47l (switch back) # \x1b8 (restore cursor) - + #1047 - clear screen on the way out (ony if actually on alt screen) proc enable_alt_screen {} { - #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? + #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? return \x1b\[?1049h } proc disable_alt_screen {} { @@ -4114,13 +4114,13 @@ to 223 (=255 - 32) #[para]Use punk::console::get_cursor_pos or punk::console::get_cursor_pos_list instead. #[para]These functions will emit the code - but read it in from stdin so that it doesn't display, and then return the row and column as a colon-delimited string or list respectively. #[para]The punk::ansi::cursor_pos function is used by punk::console::get_cursor_pos and punk::console::get_cursor_pos_list - return \033\[6n + return \033\[6n } - + proc cursor_pos_extended {} { #includes page e.g ^[[47;3;1R #(but not on all terminals - some (freebsd?) will report as per 6n e.g ^[[74;3R) - return \033\[?6n + return \033\[?6n } @@ -4128,7 +4128,7 @@ to 223 (=255 - 32) #REVIEW - vt100 accepts decimal values 132-126 and 160-255 ("in the current GL or GR in-use table") #some modern terminals accept and display characters outside this range - but this needs investigation. #in a modern unicode era - the restricted range doesn't make a lot of sense - but we need to see what terminal emulators actually do. - #e.g what happens with double-width? + #e.g what happens with double-width? #this wrapper accepts a char rather than a decimal value proc fill_rect {char t l b r} { set dec [scan $char %c] @@ -4169,7 +4169,7 @@ to 223 (=255 - 32) } - #alternative to string terminator is \007 - + #alternative to string terminator is \007 - proc titleset {windowtitle} { #*** !doctools #[call [fun titleset] [arg windowtitles]] @@ -4181,7 +4181,7 @@ to 223 (=255 - 32) return \x1bS$windowtitle\r } #titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title - #no cross-platform ansi-only mechanism ? + #no cross-platform ansi-only mechanism ? proc test_decaln {} { #Screen Alignment Test @@ -4189,13 +4189,13 @@ to 223 (=255 - 32) #(doesn't work on many terminals - seems to work in FreeBSD 13.2 and wezterm on windows) return \x1b#8 } - + #length of text for printing characters only #- unicode and other non-printing chars and combining sequences should be handled by the ansifreestring_width call at the end. #certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names #review - is there an existing library or better method? printing to a terminal and querying cursor position is relatively slow and terminals lie. #Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first - #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. + #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. proc printing_length {line} { #string last faster than string first for long strings anyway if {[tcl::string::last \n $line] >= 0} { @@ -4203,7 +4203,7 @@ to 223 (=255 - 32) } #what if line has \v (vertical tab) ie more than one logical screen line? - #review - detect ansi moves and warn/error? They would invalidate this algorithm + #review - detect ansi moves and warn/error? They would invalidate this algorithm #for a string with ansi moves - we would need to use the overtype::renderline function (which is a bit heavier) #arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review #the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char @@ -4237,7 +4237,7 @@ to 223 (=255 - 32) } #NOTE - this is non-destructive backspace as it occurs in text blocks - and is likely different to the sequence coming from a terminal or editor which generally does a destructive backspace - #e.g + #e.g #This means for example that abc\b has a length of 3. Trailing or leading backslashes have no effect #set bs [format %c 0x08] @@ -4260,16 +4260,16 @@ to 223 (=255 - 32) } #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner - #build an output + #build an output set idx 0 set outchars [list] set outsizes [list] # -- - #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code + #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code #this is difficult/risky to maintain - hence the lsearch and grapheme-replacement above #we could reasonably do it with backspace - but cr is more difficult #note that \x08 \b etc won't work to create a compiled switch statement even with unbraced (separate argument) form of switch statement. - #set bs "" + #set bs "" #set cr ? # -- foreach c $chars { @@ -4283,10 +4283,10 @@ to 223 (=255 - 32) set idx 0 } default { - #set nxt [llength $outchars] + #set nxt [llength $outchars] if {$idx < [llength $outchars]} { #overstrike? - should usually have no impact on width - width taken as last grapheme in that column - #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. lset outchars $idx $c } else { @@ -4338,7 +4338,7 @@ to 223 (=255 - 32) #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) if {[string length $text] < 2} {return $text} if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] @@ -4358,7 +4358,7 @@ to 223 (=255 - 32) #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } set parts [punk::ansi::ta::split_codes $text] #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" @@ -4369,9 +4369,9 @@ to 223 (=255 - 32) proc ansistripraw {text} { #*** !doctools #[call [fun ansistripraw] [arg text] ] - #[para]Return a string with ansi codes stripped out + #[para]Return a string with ansi codes stripped out #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. - #[para]ie instead of a horizontal line you may see: qqqqqq + #[para]ie instead of a horizontal line you may see: qqqqqq if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] @@ -4403,7 +4403,7 @@ tcl::namespace::eval punk::ansi { # name (one not found in xterm's tables) ends processing of the # list of names. proc xtgetcap {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -4412,7 +4412,7 @@ tcl::namespace::eval punk::ansi { return "\x1bP+q$payload\x1b\\" } proc xtgetcap2 {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -4432,8 +4432,8 @@ tcl::namespace::eval punk::ansi { #review - separate namespace for functions that operate on multiple or embedded? proc is_sgr {code} { - #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline - #we will accept and pass through the less common colon separator (ITU Open Document Architecture) + #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline + #we will accept and pass through the less common colon separator (ITU Open Document Architecture) #Terminals should generally ignore it if they don't use it regexp {\033\[[0-9;:]*m$} $code } @@ -4450,7 +4450,7 @@ tcl::namespace::eval punk::ansi { return 1 } } - return 0 + return 0 } #pure SGR reset with no other functions proc is_sgr_reset {code} { @@ -4458,8 +4458,8 @@ tcl::namespace::eval punk::ansi { #[call [fun is_sgr_reset] [arg code]] #[para]Return a boolean indicating whether this string has a trailing pure SGR reset #[para]Note that if the reset is not the very last item in the string - it will not be detected. - #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. - + #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. + #todo 8-bit csi regexp {\x1b\[0*m$} $code } @@ -4469,7 +4469,7 @@ tcl::namespace::eval punk::ansi { #if an SGR code has a reset in it - we don't need to carry forward any previous SGR codes #it generally only makes sense for the reset to be the first parameter - otherwise the code has ineffective portions #However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. - #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. + #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. #Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg colour twice in same code proc has_sgr_leadingreset {code} { @@ -4477,7 +4477,7 @@ tcl::namespace::eval punk::ansi { #[call [fun has_sgr_leadingreset] [arg code]] #[para]The reset must be the very first item in code to be detected. Trailing strings/codes ignored. set params "" - #we need non-greedy + #we need non-greedy if {[regexp {^\033\[([^m]*)m} $code _match params]} { #must match trailing m to be the type of reset we're looking for set plist [split $params ";"] @@ -4506,7 +4506,7 @@ tcl::namespace::eval punk::ansi { #regexp {\x1b\(B|\x1b\)B} $code regexp {\x1b(?:\(B|\)B)} $code } - #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through + #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through #This is not order-preserving if non-sgr codes are present as they are tacked on to the end even if they initially were before all SGR codes variable codestate_empty @@ -4514,11 +4514,11 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty rst "" ;#0 (or empty) tcl::dict::set codestate_empty intensity "" ;#1 bold, 2 dim, 22 normal tcl::dict::set codestate_empty italic "" ;#3 on 23 off - tcl::dict::set codestate_empty underline "" ;#4 on 24 off + tcl::dict::set codestate_empty underline "" ;#4 on 24 off #nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5 #4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions - #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines + #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines tcl::dict::set codestate_empty underextended "" ;#4:0 for no extended underline 4:1 etc for underline styles #tcl::dict::set codestate_empty undersingle "" #tcl::dict::set codestate_empty underdouble "" @@ -4550,10 +4550,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty superscript "" ;#73 tcl::dict::set codestate_empty subscript "" ;#74 tcl::dict::set codestate_empty nosupersub "" ;#75 - # -- + # -- tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 - tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 + tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 #misnomer should have been sgr_merge_args ? :/ @@ -4562,7 +4562,7 @@ tcl::namespace::eval punk::ansi { if {[llength $args] == 0} { return "" } elseif {[llength $args] == 1} { - return [lindex $args 0] + return [lindex $args 0] } sgr_merge $args } @@ -4610,7 +4610,7 @@ tcl::namespace::eval punk::ansi { set did_reset 0 #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? - #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? + #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? #we will output 7bit merge of the SGRs even if some or all were 8bit CSi #As at 2024 - 7bit are widely supported 8bit seem to be often ignored by pseudoterminals #auto-detecting and emitting 8bit only if any are present in our input doesn't seem like a good idea - as sgr_merge_list is only seeing a subset of the data - so any auto-decision at this level will just introduce indeterminism. @@ -4644,10 +4644,10 @@ tcl::namespace::eval punk::ansi { #some codes have additional parameters - e.g rgb colours so we need to jump forward in the parameter list sometimes. for {set i 0} {$i < [llength $plist]} {incr i} { set p [lindex $plist $i] - set paramsplit [split $p :] - #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters + set paramsplit [split $p :] + #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters #e.g see https://github.com/mintty/mintty/wiki/Tips#text-attributes-and-rendering - #this may have originated with kitty? + #this may have originated with kitty? #windows terminal seems to be implementing it too #however, they can be completely repurposed - so we probably need to specifically support them.. REVIEW. @@ -4682,7 +4682,7 @@ tcl::namespace::eval punk::ansi { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines #e.g hyper on windows if {[llength $paramsplit] == 1} { - tcl::dict::set codestate underline 4 + tcl::dict::set codestate underline 4 } else { switch -- [lindex $paramsplit 1] { 0 { @@ -4691,10 +4691,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended } 1 { - tcl::dict::set codestate underextended 4:1 + tcl::dict::set codestate underextended 4:1 } 2 { - tcl::dict::set codestate underextended 4:2 + tcl::dict::set codestate underextended 4:2 } 3 { tcl::dict::set codestate underextended "4:3" @@ -4716,7 +4716,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate reverse 7 } 8 { - tcl::dict::set codestate hide 8 + tcl::dict::set codestate hide 8 } 9 { tcl::dict::set codestate strike 9 @@ -4738,7 +4738,7 @@ tcl::namespace::eval punk::ansi { } 23 { #? wikipedia mentions blackletter - review - tcl::dict::set codestate italic 23 + tcl::dict::set codestate italic 23 } 24 { tcl::dict::set codestate underline 24 ;#off @@ -4766,11 +4766,11 @@ tcl::namespace::eval punk::ansi { 38 { #256 colour or rgb #check if subparams supplied as colon separated - if {[tcl::string::first : $p] < 0} { + if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4780,9 +4780,9 @@ tcl::namespace::eval punk::ansi { } } } else { - #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space + #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space #we should only need to pass it all through for the terminal to understand - #review + #review tcl::dict::set codestate fg $p } } @@ -4798,7 +4798,7 @@ tcl::namespace::eval punk::ansi { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4818,7 +4818,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate proportional 50 ;#off - see 26 } 51 - 52 { - tcl::dict::set codestate frame_or_circle 51 + tcl::dict::set codestate frame_or_circle 51 } 53 { tcl::dict::set codestate overline 53 ;#not supported in terminals? pass through anyway @@ -4830,13 +4830,13 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate overline 55; #off } 58 { - #nonstandard + #nonstandard #256 colour or rgb if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4905,11 +4905,11 @@ tcl::namespace::eval punk::ansi { } } - } + } default { lappend othercodes $c } - } + } } @@ -4920,7 +4920,7 @@ tcl::namespace::eval punk::ansi { #dict for {k v} $codestate {} tcl::dict::for {k v} $codestate { switch -- $v { - "" { + "" { } default { switch -- $k { @@ -5028,7 +5028,7 @@ tcl::namespace::eval punk::ansi { tcl::namespace::eval punk::ansi::ta { #*** !doctools #[subsection {Namespace punk::ansi::ta}] - #[para] text ansi functions + #[para] text ansi functions #[para] based on but not identical to the Perl Text Ansi module: #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm #[list_begin definitions] @@ -5036,7 +5036,7 @@ tcl::namespace::eval punk::ansi::ta { variable PUNKARGS - #handle both 7-bit and 8-bit csi + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position #CSI @@ -5058,7 +5058,7 @@ tcl::namespace::eval punk::ansi::ta { #non-greedy by excluding ST terminators variable re_esc_osc1 {(?:\x1b\])(?:[^\007]*)\007} #variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\} ;#somewhat wrong - we want to exclude the ST - not other esc sequences - variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} + variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} variable re_esc_osc3 {(?:\u009d)(?:[^\u009c]*)?\u009c} variable re_osc_open {(?:\x1b\]|\u009d).*} @@ -5070,7 +5070,7 @@ tcl::namespace::eval punk::ansi::ta { #ESC Y move, ESC b foreground colour #ESC F - gr-on ESC G - gr-off variable re_vt52_open {(?:\x1bY|\x1bb|\x1bF)} - #\x1bc vt52 bgcolour conflict ?? + #\x1bc vt52 bgcolour conflict ?? #if we don't split on altgraphics too and separate them out - it's easy to get into a horrible mess variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} @@ -5078,7 +5078,7 @@ tcl::namespace::eval punk::ansi::ta { variable re_g0_close {(?:\x1b\(B)} # DCS "ESC P" or "0x90" is also terminated by ST - set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} #ST terminators [list \007 \033\\ \u009c] #regex to capture the start of string/privacy message/application command block including the contents and string terminator (ST) @@ -5087,7 +5087,7 @@ tcl::namespace::eval punk::ansi::ta { #even if terminals generally don't support that - it's quite possible for an ansi code to get nested this way - and we'd prefer it not to break our splits #Just checking for \x1b will terminate the match too early #we also need to track the start of ST terminated code and not add it for replay (in the ansistring functions) - #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) + #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) #keep our 8bit/7bit start-end codes separate variable re_ST {(?:\x1bP|\x1bX|\x1b\^|\x1b_)(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007)|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)} @@ -5104,12 +5104,12 @@ tcl::namespace::eval punk::ansi::ta { #variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} #NOTE - the literal # char can cause problems in expanded syntax - even though it's within a bracketed section. \# seems to work though. - #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| + #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| #https://freemint.github.io/tos.hyp/en/VT_52_terminal.html #what to with ESC c vs vt52 ESC c (background colour) ??? #we probably need to use a separate re_ansi_detect for vt52 - #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes + #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes #ie - when DECANM is on - VT52 codes are *not* processed #todo - ansi mode and cursor key mode set ? @@ -5129,8 +5129,8 @@ tcl::namespace::eval punk::ansi::ta { - variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" - + variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" + #may be same as detect - kept in case detect needs to diverge #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect @@ -5142,7 +5142,7 @@ tcl::namespace::eval punk::ansi::ta { } lappend PUNKARGS [list -dynamic 0 { - @id -id ::punk::ansi::ta::detect + @id -id ::punk::ansi::ta::detect @cmd -name punk::ansi::ta::detect -help\ "Return a boolean indicating whether Ansi codes were detected in text. Important caveat: @@ -5151,9 +5151,9 @@ tcl::namespace::eval punk::ansi::ta { (one example is if a list element contains an unbalanced brace) This can cause square brackets that form part of the ansi to be backslash escaped - and the function can fail to match it as an Ansi code. - " + " @values -min 1 - text -type string + text -type string } ] #*** !doctools @@ -5187,8 +5187,8 @@ tcl::namespace::eval punk::ansi::ta { proc detect_g0 {text} [string map [list [list $re_g0_group]] { regexp $text }] - #note - micro optimisation of inlining gives us *almost* nothing extra. - #left in place for a few such as detect/detect_g0 as we want them as fast as possible + #note - micro optimisation of inlining gives us *almost* nothing extra. + #left in place for a few such as detect/detect_g0 as we want them as fast as possible # in general the technique doesn't seem particularly worthwhile for this set of functions. #the performance is dominated by the complexity of the regexp proc detect2 {text} { @@ -5211,8 +5211,8 @@ tcl::namespace::eval punk::ansi::ta { #[call [fun detect_csi] [arg text]] #[para]Return a boolean indicating whether an Ansi Control Sequence Introducer (CSI) was detected in text #[para]The csi is often represented in code as \x1b or \033 followed by a left bracket [lb] - #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation - #[para]There is also a multi-byte escape sequence \u009b + #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation + #[para]There is also a multi-byte escape sequence \u009b #[para]This is less commonly used but is also detected here #[para](This function is not in perl ta) variable re_csi_open @@ -5240,7 +5240,7 @@ tcl::namespace::eval punk::ansi::ta { #*** !doctools #[call [fun length] [arg text]] #[para]Return the character length after stripping ansi codes - not the printing length - + #we can use ansistripraw to avoid g0 conversion - as the length should remain the same tcl::string::length [ansistripraw $text] } @@ -5259,11 +5259,11 @@ tcl::namespace::eval punk::ansi::ta { proc split_at_codes {str} [string map [list $re_ansi_split] { #variable re_ansi_split #punk::ansi::internal::splitx $str ${re_ansi_split} - punk::ansi::ta::Do_split_at_codes $str {} + punk::ansi::ta::Do_split_at_codes $str {} }] #it is faster to split this function out than to inline it into split_at_codes in tcl 8.7 - something to do with the use of the variable vs argument for the regexp #literal inlining of the re in the main proc-body was slower too - but inlining it into the wrapper seems to work (a tiny bit) - #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - + #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - # - but in aggregate for something like textblock::periodic - we can get a bit over 5% faster (e.g 136ms vs 149ms) proc Do_split_at_codes {str regexp} { if {$str eq ""} { @@ -5342,12 +5342,12 @@ tcl::namespace::eval punk::ansi::ta { lappend list [tcl::string::range $str $start end] return $list }] - - # -- --- --- --- --- --- + + # -- --- --- --- --- --- #Split $text to a list containing alternating ANSI colour codes and text. #ANSI colour codes are always on the second element, fourth, and so on. #(ie plaintext on even list-indices ansi on odd indices) - #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) + #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) # Example: #split_codes "" # => "" #split_codes "a" # => "a" @@ -5361,7 +5361,7 @@ tcl::namespace::eval punk::ansi::ta { variable re_ansi_split_multi return [_perlish_split $re_ansi_split_multi $text] } - #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) + #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds) #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. @@ -5413,16 +5413,16 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] - incr start + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] + incr start } else { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] } if {$start >= [tcl::string::length $text]} { @@ -5437,20 +5437,20 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] - incr start + 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 $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] #? if {$start >= [tcl::string::length $text]} { @@ -5467,22 +5467,22 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::index $text $matchStart] - incr start + yield [tcl::string::index $text $matchStart] + incr start if {$start >= [tcl::string::length $text]} { break } continue } yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::range $text $matchStart $matchEnd] + yield [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] #? if {$start >= [tcl::string::length $text]} { @@ -5495,7 +5495,7 @@ tcl::namespace::eval punk::ansi::ta { proc _ws_split {text} { regexp -all -inline {(?:\S+)|(?:\s+)} $text } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #*** !doctools #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] @@ -5532,7 +5532,7 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- if {[llength $args] < 1} { error {usage: ?-width ? ?-height ? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring} @@ -5632,7 +5632,7 @@ tcl::namespace::eval punk::ansi::class { method rendernext {} { upvar ${o_ns_from}::o_ansisplits from_ansisplits upvar ${o_ns_from}::o_elements from_elements - upvar ${o_ns_from}::o_splitindex from_splitindex + upvar ${o_ns_from}::o_splitindex from_splitindex #if {![llength $from_ansisplits]} {$o_from_ansistring eval_in {my MakeSplit}} ;#!!todo - a better way to keep this method semi hidden but call from a 'friend' if {![llength $from_ansisplits]} { @@ -5658,7 +5658,7 @@ tcl::namespace::eval punk::ansi::class { set process_splitindex [lindex $from_splitindex $eidx] ;#which from_ansisplits index the first unrendered element belongs to set elementinfo [lindex $from_elements $eidx] - lassign $elementinfo type_rendered item + lassign $elementinfo type_rendered item #we don't expect type to change should be all graphemes (type 'g') or a single code (type 'sgr','other' etc) #review - we may want to store more info for graphemes e.g g0 g1 g2 for zero-wide 1-wide 2-wide ? #if so - we should report a list of the grapheme types that were rendered in a pt block @@ -5674,7 +5674,7 @@ tcl::namespace::eval punk::ansi::class { set e_splitindex $process_splitindex while {$e_splitindex == $process_splitindex && $eidx < [llength $from_elements]} { append newtext $item - lappend o_rendereditems $elementinfo + lappend o_rendereditems $elementinfo incr rendercount incr eidx @@ -5684,8 +5684,8 @@ tcl::namespace::eval punk::ansi::class { } } else { #while not g ? render however many ansi sequences are in a row? - set newtext $item - lappend o_rendereditems $elementinfo + set newtext $item + lappend o_rendereditems $elementinfo incr rendercount } @@ -5703,7 +5703,7 @@ tcl::namespace::eval punk::ansi::class { if {![tcl::string::length $overtext]} { continue } - #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] + #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] } } #renderspace equivalent? channel based? @@ -5714,7 +5714,7 @@ tcl::namespace::eval punk::ansi::class { } } - #name all with prefix class_ for rendertype detection + #name all with prefix class_ for rendertype detection oo::class create class_cp437 { superclass base_renderer } @@ -5733,7 +5733,7 @@ tcl::namespace::eval punk::ansi::class { #this is the main state we keep of the split apart string #we use the punk::ansi::ta::split_codes_single function which produces a list with zero, or an odd number elements always beginning and ending with plaintext - variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes + variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes variable o_ansisplits ;#store our plaintext/ansi-code splits so we don't keep re-running the regexp to split @@ -5750,7 +5750,7 @@ tcl::namespace::eval punk::ansi::class { variable o_elements ;#elements contains entry for each grapheme/control + each ansi code variable o_sgrstacks ;#list of ansi sgr codes that will be merged later. Entries deliberately repeat if no change from previous entry. Later scans look for difference between n and n-1 when deciding where to apply codes. variable o_gx0states ;#0|1 for alternate graphics gx0 - variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. + variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. # -- -- constructor {string} { @@ -5763,7 +5763,7 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- #we choose not to generate an internal split-state for the initial string - which may potentially be large. @@ -5772,7 +5772,7 @@ tcl::namespace::eval punk::ansi::class { set o_count "" ;#o_count first updated when string appended or a method causes MakeSplit to run (or by count method if constructor argument was empty string) - set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. + set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. set o_ptlist [list] #o_ansisplits and o_ptlist should only remain empty if an empty string was passed to the contructor, or no methods have yet triggered the initial string to have it's internal state built. @@ -5786,7 +5786,7 @@ tcl::namespace::eval punk::ansi::class { #empty if no render methods used # -- - set o_renderer "" + set o_renderer "" set o_renderout "" ;#class_ansistring # -- @@ -5810,18 +5810,18 @@ tcl::namespace::eval punk::ansi::class { method show_state {{verbose 0}} { #show some state info - without updating anything - #only use 'my' methods that don't update the state e.g has_ansi + #only use 'my' methods that don't update the state e.g has_ansi set result "" if {![llength $o_ansisplits]} { append result "No internal splits. " append result \n "has ansi : [my has_ansi]" - append result \n "Tcl string length raw string: [tcl::string::length $o_string]" + append result \n "Tcl string length raw string: [tcl::string::length $o_string]" } else { append result \n "has ansi : [my has_ansi]" - append result \n "ansisplit list len: [llength $o_ansisplits]" + append result \n "ansisplit list len: [llength $o_ansisplits]" append result \n "plaintext list len: [llength $o_ptlist]" append result \n "cached count : $o_count" - append result \n "Tcl string length raw string : [tcl::string::length $o_string]" + append result \n "Tcl string length raw string : [tcl::string::length $o_string]" append result \n "Tcl string length plaintext parts: [tcl::string::length [join $o_ptlist ""]]" if {[llength $o_ansisplits] %2 == 0} { append result \n -------------------------------------------------- @@ -5860,10 +5860,10 @@ tcl::namespace::eval punk::ansi::class { #private method method MakeSplit {} { #The split with each code as it's own element is more generally useful. - set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; + set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; set o_ptlist [list] set codestack [list] - set gx0_state 0 ;#default off + set gx0_state 0 ;#default off set current_split_index 0 ;#incremented for each pt block, incremented for each code if {$o_count eq ""} { set o_count 0 @@ -5878,7 +5878,7 @@ tcl::namespace::eval punk::ansi::class { incr o_count } #after handling the pt block - incr the current_split_index - incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry + incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry #we will only get an empty code at the very end of ansisplits (ansisplits is length 0 or odd length - always with pt at start and pt at end) if {$code ne ""} { lappend o_sgrstacks $codestack @@ -5914,7 +5914,7 @@ tcl::namespace::eval punk::ansi::class { } } #assertion every grapheme and every individual code has been added to o_elements - #every element has an entry in o_sgrstacks + #every element has an entry in o_sgrstacks #every element has an entry in o_gx0states assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} } @@ -5925,7 +5925,7 @@ tcl::namespace::eval punk::ansi::class { method strippedlength {} { if {![llength $o_ansisplits]} {my MakeSplit} #review - return [string length [join $o_ptlist ""]] + return [string length [join $o_ptlist ""]] } #returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already method stripped {} { @@ -5938,13 +5938,13 @@ tcl::namespace::eval punk::ansi::class { method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function return [tcl::string::length [regsub -all $re_diacritics $plaintext ""]] } - #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! + #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! method count {} { if {$o_count eq ""} { #only initial string present @@ -5977,7 +5977,7 @@ tcl::namespace::eval punk::ansi::class { #channels for stream in/out.. these are vaguely analogous to the input/output between a shell and a PTY Slave - but this is not intended to be a full pseudoterminal #renderstream_to_render (private?) - # write end held by outer ansistring? read end by inner render ansistring ? + # write end held by outer ansistring? read end by inner render ansistring ? #renderstream_from_render (public?) method rendertypes {} { @@ -5991,7 +5991,7 @@ tcl::namespace::eval punk::ansi::class { } set rtypes [my rendertypes] if {$rtype ni $rtypes} { - error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" + error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" } #if {$o_renderout eq ""} { # set o_renderout [punk::ansi::class::class_ansistring new ""] @@ -6022,7 +6022,7 @@ tcl::namespace::eval punk::ansi::class { } if {$rw eq $o_renderwidth} { return $o_renderwidth - } + } #re-render if needed? puts stderr "renderwidth todo? re-render?" @@ -6034,7 +6034,7 @@ tcl::namespace::eval punk::ansi::class { method render_state {} { #? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary #but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split. - #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work + #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work } method renderbuf {} { #get the underlying renderobj - if any @@ -6071,7 +6071,7 @@ tcl::namespace::eval punk::ansi::class { return [dict create graphemes $grapheme_count other $other_count] } method rendernext {} { - #render next available pt/code chunk only - not to end of available input + #render next available pt/code chunk only - not to end of available input if {$o_renderer eq ""} { my rendertype $o_rendertype ;#review - proper way to initialise rendering } @@ -6111,7 +6111,7 @@ tcl::namespace::eval punk::ansi::class { } #analagous to Tcl string append - #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient + #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient method append {args} { set catstr [join $args ""] if {$catstr eq ""} { @@ -6122,19 +6122,19 @@ tcl::namespace::eval punk::ansi::class { #ansi-free additions #if no initial internal-split - generate it without first appending our additions - as we can more efficiently append them to the internal state if {![llength $o_ansisplits]} { - #initialise o_count because we need to add to it. + #initialise o_count because we need to add to it. #The count method will do this by calling Makesplit only if it needs to. (which will create ansisplits for anything except empty string) my count } append o_string $catstr;# only append after updating using my count above if {![llength $o_ptlist]} { - #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits + #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits #even though we can use lset to add to a list - we can't for empty lappend o_ptlist $catstr #assertion - if o_ptlist is empty so is o_ansisplits lappend o_ansisplits $catstr } else { - lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] + lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] $catstr] } set last_codestack [lindex $o_sgrstacks end] @@ -6156,16 +6156,16 @@ tcl::namespace::eval punk::ansi::class { #set combined_plaintext [join $o_ptlist ""] #set o_count [my DoCount $combined_plaintext] assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} - return $o_string + return $o_string } else { - #update each element of internal state incrementally without reprocessing what is already there. + #update each element of internal state incrementally without reprocessing what is already there. append o_string $catstr - set newsplits [punk::ansi::ta::split_codes_single $catstr] + set newsplits [punk::ansi::ta::split_codes_single $catstr] set ptnew "" set codestack [lindex $o_sgrstacks end] set gx0_state [lindex $o_gx0states end] - set current_split_index [lindex $o_splitindex end] - #first pt must be merged with last element of o_ptlist + set current_split_index [lindex $o_splitindex end] + #first pt must be merged with last element of o_ptlist set new_pt_list [list] foreach {pt code} $newsplits { lappend new_pt_list $pt @@ -6216,7 +6216,7 @@ tcl::namespace::eval punk::ansi::class { #if {$o_count eq ""} { # #we have splits - but didn't count graphemes? - # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts + # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts #} else { # incr o_count [my DoCount $ptnew] #} @@ -6227,7 +6227,7 @@ tcl::namespace::eval punk::ansi::class { return $o_string } - #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. + #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. #This is 'often'? likely to be true - We don't have grapheme cluster support yet anyway. review. method appendobj {args} { if {![llength $o_ansisplits]} { @@ -6272,7 +6272,7 @@ tcl::namespace::eval punk::ansi::class { set firstnewidx [lindex $new_splitindex 0] set diffidx [expr {$lastidx - $firstnewidx}] ;#may be negative foreach v $new_splitindex { - lappend o_splitindex [expr {$v + $diffidx}] + lappend o_splitindex [expr {$v + $diffidx}] } incr o_count $new_count @@ -6323,7 +6323,7 @@ tcl::namespace::eval punk::ansi::class { set arrow_lr \u2194 set arrow_du \u2195 #2024 - there is no 4-arrow symbol or variations (common cursor and window icon) in unicode - despite requests and argument from the community that this has been in use for decades. - #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. + #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. #don't split into lines first - \n is valid within ST sections set output "" @@ -6338,7 +6338,7 @@ tcl::namespace::eval punk::ansi::class { set c1 [tcl::string::index $code 0] set c1c2 [tcl::string::range $code 0 1] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[ 7CSI\ \x9b 8CSI\ @@ -6346,9 +6346,9 @@ tcl::namespace::eval punk::ansi::class { \x1b\( 7GFX\ \x9d 8OSC\ \x1b 7ESC\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - #we leave the tail of the code unmapped for now + #we leave the tail of the code unmapped for now switch -- $leadernorm { 7CSI - 7OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] @@ -6401,7 +6401,7 @@ tcl::namespace::eval punk::ansi::class { H - f { set params [tcl::string::range $codenorm 4 end-1] lassign [split $params {;}] row col - #lassign $matchinfo _match row col + #lassign $matchinfo _match row col set displaycode [ansistring VIEW $code] if {$col eq ""} { #row only move @@ -6423,7 +6423,7 @@ tcl::namespace::eval punk::ansi::class { append output ${unk}[ansistring VIEW -lf 1 $code]$RST } } - } + } 7GFX { switch -- [tcl::string::index $codenorm 4] { "0" { @@ -6456,7 +6456,7 @@ tcl::namespace::eval punk::ansi::class { #set splits [punk::ansi::ta::split_codes_single $string] set output "" set codestack [list] - set gx_stack [list] ;#not actually a stack + set gx_stack [list] ;#not actually a stack set cursor_saved "" foreach {pt code} $o_ansisplits { if {[llength $args]} { @@ -6482,13 +6482,13 @@ tcl::namespace::eval punk::ansi::class { #cursor_restore set codestack [list $cursor_saved] } else { - #leave SGR stack as is + #leave SGR stack as is if {[punk::ansi::codetype::is_gx_open $code]} { set gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess } elseif {[punk::ansi::codetype::is_gx_close $code]} { set gx_stack [list] - } - } + } + } } } return $output @@ -6500,24 +6500,24 @@ tcl::namespace::eval punk::ansi { proc stripansi3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - #using detect costs us a couple of uS - but saves time on plain text + #using detect costs us a couple of uS - but saves time on plain text #we should probably leave this for caller - otherwise it ends up being called more than necessary - #if {![::punk::ansi::ta::detect $text]} { + #if {![::punk::ansi::ta::detect $text]} { # return $text #} #alternate graphics codes are not the norm - # - so save a few uS in the common case by only calling convert_g0 if we detect + # - so save a few uS in the common case by only calling convert_g0 if we detect if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] proc stripansiraw3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { #join [::punk::ansi::ta::split_at_codes $text] "" - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] } @@ -6533,7 +6533,7 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::namespace::ensemble create tcl::namespace::export length trim trimleft trimright INDEX COUNT VIEW VIEWCODES VIEWSTYLE INDEXABSOLUTE INDEXCOLUMNS COLUMNINDEX NEW #todo - expose _splits_ methods so caller can work efficiently with the splits themselves - #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single + #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single #\UFFFD - replacement char or \U2426 @@ -6647,7 +6647,7 @@ tcl::namespace::eval punk::ansi::ansistring { variable debug_visuals #modern (c0 seem to have more terminal/font support - C1 can show 8bit c1 codes - but also seems to be limited support) - + #Goal is not to map every control character? #Map of which elements we want to convert - done this way so we can see names of control's that are included: - ease of maintenance compared to just creating the tcl::string::map directly #ETX -ctrl-c @@ -6729,10 +6729,10 @@ tcl::namespace::eval punk::ansi::ansistring { #we'll hack in some stuff as needed - may override some of the visuals_c1 which is usually just empty/substitute glyphs #Being repurposed - these could potentially be confused with actual characters depending on the debugging context #To minimize potential confusion - we'll use a longer replacement sequence - which is not ideal from the perspective of terminal column layout debugging - #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator + #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator #(review - BOM should use different brackets to c1?) - #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. + #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. #for 8-bit controls - we will standardize on a fixed width of 4 bracketing with: #\u2987 and \u2988 from Miscellaneous Mathematical Symbols-B (D or fractional-moon shaped brackets) #\u2987 - Z Notation Left Image Bracket @@ -6750,7 +6750,7 @@ tcl::namespace::eval punk::ansi::ansistring { #unicode Tags block brackets set obt \u2993 ;set cbt \u2994 - #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now + #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now #set visuals_c1 [tcl::dict::create\ # BPH [list \x82 "${ob8}\ue022 $cb8"]\ # NBH [list \x83 "${ob8}\ue023 $cb8"]\ @@ -6826,10 +6826,10 @@ tcl::namespace::eval punk::ansi::ansistring { set vis [format %c $asciidec] if {[dict exists $map_c0 $vis]} { set vis [dict get $map_c0 $vis] - } + } tcl::dict::set visuals_tags TAG$asciidec [list [format %c $i] "${obt}$vis${cbt}"] } - + set hack [tcl::dict::create] tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) @@ -6840,13 +6840,13 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::dict::set hack SOS [list \x98 "${ob8}\u2380 $cb8"] ;#Insertion Symbol from Miscellaneous Technical - 1 wide + pad tcl::dict::set hack ST [list \x9c "${ob8}\u2383 $cb8"] ;#Emphasis Symbol from Miscellaneous Technical - 1 wide + pad (graphically related to \u2380) tcl::dict::set hack CSI [list \x9b "${ob8}\u2386 $cb8"] ;#Enter Symbol from Miscellaneous Technical - 1 wide + pad - tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) + tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) tcl::dict::set hack PM [list \x9e "${ob8}PM$cb8"] tcl::dict::set hack APC [list \x9f "${ob8}\U1f534$cb8"] ;#bright red ball from Miscellaneoust Symbols and Pictographs - 2 wide (APC also noted as a potential security risk) set debug_visuals [tcl::dict::merge $visuals_c0 $visuals_c1 $hack $visuals_tags] - #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient + #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient proc NEW {string} { punk::ansi::class::class_ansistring new $string } @@ -6894,8 +6894,8 @@ tcl::namespace::eval punk::ansi::ansistring { # -lf 2, -vt 2 and -ff 2 are useful for CRM mode (Show Control Character Mode) in the terminal - where a newline is expected to display after the character. - set visuals_opt $debug_visuals - set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] + set visuals_opt $debug_visuals + set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] if {$opt_esc} { tcl::dict::set visuals_opt ESC [list \x1b \u241b] @@ -6949,7 +6949,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #The implementation of viewcodes,viewstyle is more efficiently done in an object for the case where repeated calls of various methods can re-use the internal splits. - #for oneshots here - there is only minor overhead to use and destroy the object here. + #for oneshots here - there is only minor overhead to use and destroy the object here. proc VIEWCODES {args} { set string [lindex $args end] if {$string eq ""} { @@ -6961,7 +6961,7 @@ tcl::namespace::eval punk::ansi::ansistring { $ansistr destroy return $result } - #an attempt to show the codes and colour/style of the *input* + #an attempt to show the codes and colour/style of the *input* #ie we aren't looking at the row/column positioning - but we do want to keep track of cursor attribute saves and restores proc VIEWSTYLE {args} { set string [lindex $args end] @@ -6993,16 +6993,16 @@ tcl::namespace::eval punk::ansi::ansistring { #stripping diacritics only makes sense if we are counting them as combiners and also treating unicode grapheme combinations as single entities. #as Our ansistring INDEX function returns the character with diacritics, and will ultimately return grapheme clusters as a single element - we strip theme here as not counted. #todo - combiners/diacritics? just map them away here? - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set string [regsub -all $re_diacritics $string ""] - #we want length to return number of glyphs.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs.. not screen width. Has to be consistent with index function tcl::string::length [ansistrip $string] } #included as a test/verification - slightly slower. #grapheme split version may end up being used once it supports unicode grapheme clusters proc count2 {string} { - #we want count to return number of glyphs.. not screen width. Has to be consistent with index function + #we want count to return number of glyphs.. not screen width. Has to be consistent with index function return [llength [punk::char::grapheme_split [ansistrip $string]]] } @@ -7077,7 +7077,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc - #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. + #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. proc trimleft {string args} { set intext 0 set out "" @@ -7103,19 +7103,19 @@ tcl::namespace::eval punk::ansi::ansistring { } proc trim {string} { #make sure we do our ansi-scanning split only once - so use list-based trim operations - #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length + #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length #we save a single function call by calling both here rather than _splits_trim join [_splits_trimright [_splits_trimleft [split_codes $string]]] "" } - #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index + #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index proc INDEX {string index} { #*** !doctools #[call [fun index] [arg string] [arg index]] #[para]Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes) #[para]Returns the character (with applied ansi effect) at position index #[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output. - #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) + #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) #[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them. #[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards. #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index. @@ -7194,8 +7194,8 @@ tcl::namespace::eval punk::ansi::ansistring { } #any pt could be empty if using split_codes_single (or just first and last pt if split_codes) - set low -1 - set high -1 + set low -1 + set high -1 set pt_index -2 set pt_found -1 set char "" @@ -7209,8 +7209,8 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { set graphemes [punk::char::grapheme_split $pt] - set low [expr {$high + 1}] ;#last high - #incr high [tcl::string::length $pt] + set low [expr {$high + 1}] ;#last high + #incr high [tcl::string::length $pt] incr high [llength $graphemes] } @@ -7220,14 +7220,14 @@ tcl::namespace::eval punk::ansi::ansistring { set char [lindex $graphemes $index-$low] break } - + if {[punk::ansi::codetype::is_sgr_reset $code]} { - #we can throw away previous codestack + #we can throw away previous codestack set codestack [list] } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { set codestack [list $code] } else { - #may have partial resets + #may have partial resets #sgr_merge_list will handle at end #we don't apply non SGR codes to our output. This is probably what is wanted - but should be reviewed. #Review - consider if any other types of code make sense to retain in the output in this context. @@ -7244,8 +7244,8 @@ tcl::namespace::eval punk::ansi::ansistring { } } - #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi - #return empty string for each index that is out of range + #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi + #return empty string for each index that is out of range #review - this is possibly too slow to be very useful as is. # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string #see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. @@ -7326,11 +7326,11 @@ tcl::namespace::eval punk::ansi::ansistring { #we now have numeric or empty string indices - but haven't fully checked they are within the underlying payload length if {[join $testindices ""] eq ""} { - #don't calc ansistring length if no indices to check + #don't calc ansistring length if no indices to check return $testindices } if {$payload_len == -1} { - set payload_len [punk::ansi::ansistring::length $string] + set payload_len [punk::ansi::ansistring::length $string] } set indices [list] foreach ti $testindices { @@ -7356,7 +7356,7 @@ tcl::namespace::eval punk::ansi::ansistring { #single-width grapheme will return pair of integers of equal value #doulbe-width grapheme will return a pair of consecutive indices proc INDEXCOLUMNS {string idx} { - #There is an index per grapheme - whether it is 1 or 2 columns wide + #There is an index per grapheme - whether it is 1 or 2 columns wide set index [lindex [INDEXABSOLUTE $string $idx] 0] if {$index eq ""} { return "" @@ -7377,7 +7377,7 @@ tcl::namespace::eval punk::ansi::ansistring { foreach ptline $ptlines { set graphemes [punk::char::grapheme_split $ptline] if {$ptlineindex > 0} { - #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column + #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column #zero width set low [expr {$high + 1}] set lowc [expr {$highc + 1}] @@ -7393,7 +7393,7 @@ tcl::namespace::eval punk::ansi::ansistring { set lowc 0 set highc 0 } - set low [expr {$high + 1}] ;#last high + set low [expr {$high + 1}] ;#last high set lowc [expr {$highc + 1}] set high [expr {$low + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $ptline] -1}] @@ -7435,7 +7435,7 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { if {[tcl::string::last \n $pt] < 0} { set graphemes [punk::char::grapheme_split $pt] - set lowindex [expr {$highindex + 1}] ;#last high + set lowindex [expr {$highindex + 1}] ;#last high set lowc [expr {$highc + 1}] set highindex [expr {$lowindex + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $pt] -1}] @@ -7527,7 +7527,7 @@ namespace eval punk::ansi::colour { #https://sourceforge.net/p/irrational-numbers/code/HEAD/tree/pkgs/Colors/trunk/colors.tcl#l159 - # classic formula for luminance (0.0 .. 100.0) + # classic formula for luminance (0.0 .. 100.0) proc luminance {R G B} { return [expr {(0.3*$R + 0.59*$G + 0.11*$B)/255.0}] } @@ -7536,9 +7536,9 @@ namespace eval punk::ansi::colour { proc contrasting {R G B} { set lum [luminance $R $G $B] if {$lum < 0.597} { - set lum 0.9 + set lum 0.9 } else { - set lum 0.2 + set lum 0.2 } lassign [RGB2hsl $R $G $B] h s l return [hsl2RGB $h $s $lum] @@ -7569,11 +7569,11 @@ namespace eval punk::ansi::colour { } foreach c {R G B} { - if {$T($c) < [expr {1.0/6.0}]} { + if {$T($c) < (1.0/6.0)} { set T($c) [expr {$P+($Q-$P)*6.0*$T($c)}] } elseif {$T($c) < 0.5} { set T($c) $Q - } elseif {$T($c) < [expr {2.0/3.0}]} { + } elseif {$T($c) < (2.0/3.0)} { set T($c) [expr {$P+($Q-$P)*(2.0/3.0-$T($c))*6.0}] } else { set T($c) $P @@ -7585,7 +7585,7 @@ namespace eval punk::ansi::colour { } proc RGB2hsl { R G B } { set r [expr {$R/255.0}] - set g [expr {$G/255.0}] + set g [expr {$G/255.0}] set b [expr {$B/255.0}] set max $r @@ -7611,7 +7611,7 @@ namespace eval punk::ansi::colour { } set L [expr {($max+$min)/2}] - + if { $L == 0.0 || $max == $min } { set S 0.0 } elseif { $L <= 0.5 } { @@ -7651,7 +7651,7 @@ namespace eval punk::ansi::colour { set Bmax 1 } set L [expr {($min + $max) / 2.0}] - set H 0.0 + set H 0.0 set S 0.0 #REVIEW - java allows floating point division by 0.0 - producing positive infinity, negative infinity or NaN #This makes the original java algorithm a little more obscure @@ -7757,9 +7757,9 @@ tcl::namespace::eval punk::ansi::internal { } proc printing_length_addchar {i c} { - upvar outchars outc + upvar outchars outc upvar outsizes outs - set nxt [llength $outc] + set nxt [llength $outc] if {$i < $nxt} { lset outc $i $c } else { @@ -7801,10 +7801,10 @@ namespace eval ::punk::args::register { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ansi [tcl::namespace::eval punk::ansi { variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.0.tm index 74a3ffc8..25b01d81 100644 --- a/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/bootsupport/modules/punk/args-0.1.0.tm @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::args 0 0.1.0] #[copyright "2024"] #[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] #[require punk::args] #[keywords module proc args arguments parse] #[description] -#[para]Utilities for parsing proc args +#[para]Utilities for parsing proc args # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -53,8 +53,8 @@ # @cmd -help "do some stuff with files e.g dofilestuff " # @opts -type string # #comment lines ok -# -directory -default "" -# -translation -default binary +# -directory -default "" +# -translation -default binary # #setting -type none indicates a flag that doesn't take a value (solo flag) # -nocomplain -type none # @values -min 1 -max -1 @@ -62,26 +62,26 @@ # # puts "translation is [dict get $opts -translation]" # foreach f [dict values $values] { -# puts "doing stuff with file: $f" +# puts "doing stuff with file: $f" # } # } #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values #[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. #[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. #[para]e.g the result from the punk::args call above may be something like: #[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments #[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments #[example { # proc dofilestuff {category args} { # lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary +# -directory -default "" +# -translation -default binary # -nocomplain -type none -# @values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 # } $args]] leaders opts values @@ -89,16 +89,16 @@ # puts "$category fileB: [dict get $values fileB]" # } #}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 #[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, #[para] or an additional call could be made to punk::args e.g #[example { # punk::args::get_dict { -# category -choices {cat1 cat2 cat3} +# category -choices {cat1 cat2 cat3} # another_leading_arg -type boolean # } [list $category $another_leading_arg] -#}] +#}] #*** !doctools #[subsection Notes] @@ -111,8 +111,8 @@ # proc test_switch {args} { # set opts [dict create\\ # -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ +# -frametype "heavy"\\ +# -show_edge 1\\ # -show_seps 0\\ # -x a\\ # -y b\\ @@ -173,12 +173,12 @@ #[enum]The tcllib set of TEPAM modules (pure tcl) #[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. #[list_end] -#[para] (* c implementation planned/proposed) +#[para] (* c implementation planned/proposed) #[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. #[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences #[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. #[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. #[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. #[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. @@ -188,7 +188,7 @@ #All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 #as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. #(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) #ensembles: array binary clock dict info namespace string @@ -221,7 +221,7 @@ package require Tcl 8.6- tcl::namespace::eval punk::args::register { #*** !doctools #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register + #[para] cooperative namespace punk::args::register #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. #[list_begin definitions] @@ -257,15 +257,15 @@ tcl::namespace::eval punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args { - + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - tcl::namespace::export {[a-z]*} + tcl::namespace::export {[a-z]*} variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} variable id_cache_rawdef [tcl::dict::create] variable id_cache_spec [tcl::dict::create] - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) variable argdata_cache [tcl::dict::create] @@ -273,7 +273,7 @@ tcl::namespace::eval punk::args { #*** !doctools #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args + #[para] Core API functions for punk::args #[list_begin definitions] #todo - some sort of punk::args::cherrypick operation to get spec from an existing set @@ -283,10 +283,10 @@ tcl::namespace::eval punk::args { #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix #e.g - # -corner -aliases {-corners} + # -corner -aliases {-corners} # -centre -aliases {-center -middle} #We mightn't want the prefix to be longer just because of an alias #we should get -co -ce and -m from the above as abbreviations @@ -301,10 +301,10 @@ tcl::namespace::eval punk::args { Returns a dictionary representing the argument specifications. The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. + @id -id value from the supplied definition. This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. This can be used purely for documentation or called within a function to parse a mix of leading values, switches/flags and trailing values. @@ -325,7 +325,7 @@ tcl::namespace::eval punk::args { text if they are properly braced or double quoted and Tcl escaping for inner quotes or unbalanced braces is maintained. The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for + (\\ at the end of the line) can be used to continue the set of arguments for a leading word. Leading words beginning with the @ character are directives controlling argument parsing and help display. @@ -347,13 +347,13 @@ tcl::namespace::eval punk::args { -body (text to replace autogenerated arg info) %B%@doc%N% ?opt val...? options: -name -url - %B%@seealso%N% ?opt val...? + %B%@seealso%N% ?opt val...? options: -name -url (for footer - unimplemented) Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults + to use with the @leaders @opts @values directives to set defaults for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be + These directives should occur in exactly this order - but can be repeated with custom argument lines interspersed. An @id line can only appear once and should be the first item. @@ -365,17 +365,17 @@ tcl::namespace::eval punk::args { Custom arguments are defined by using any word at the start of a line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so + (except that adding an additionl @ escapes this restriction so that @@somearg becomes an argument named @somearg) custom leading args, switches/options (names starting with -) and trailing values also take options: - -type + -type defaults to string. If no other restrictions - are specified, choosing string does the least validation. + are specified, choosing string does the least validation. recognised types: - none + none (used for switches only. Indicates this is a 'solo' flag ie accepts no value) int|integer @@ -400,14 +400,14 @@ tcl::namespace::eval punk::args { -default -multiple (for leaders & values defines whether subsequent received values are stored agains the same - argument name - only applies to final leader or value) + argument name - only applies to final leader or value) (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - no necessarily contiguously) + flag to appear multiple times - no necessarily contiguously) -choices {} A list of allowable values for an argument. The -default value doesn't have to be in the list. If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted + It will only be used for validation if the -choicerestricted option is set to false. -choicerestricted Whether values not specified in -choices or -choicegroups are @@ -421,7 +421,7 @@ tcl::namespace::eval punk::args { These choices should match exactly a choice entry in one of the settings -choices or -choicegroups. These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. + choice argument must be entered to select the choice. -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name. @@ -446,7 +446,7 @@ tcl::namespace::eval punk::args { " -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} are re-evaluated on each call. If the definition is being used not just as documentation, but is also used within the function to parse args, e.g using punk::args::get_by_id, @@ -463,7 +463,7 @@ tcl::namespace::eval punk::args { Using multiple text arguments may be useful to mix curly-braced and double-quoted strings to have finer control over interpolation when defining arguments. (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) + from existing definitions (by id) for re-use of argument specifications and help text) e.g the following definition passes 2 blocks as text arguments definition { @@ -486,7 +486,7 @@ tcl::namespace::eval punk::args { #Items that don't begin with * or - are value definitions v1 -type integer -default 0 thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" " }]] @@ -519,7 +519,7 @@ tcl::namespace::eval punk::args { -multiple 0\ -regexprepass {}\ -validationtransform {}\ - ] + ] set valspec_defaults [tcl::dict::create\ -type string\ -optional 0\ @@ -618,7 +618,7 @@ tcl::namespace::eval punk::args { variable argdefcache_unresolved - set cache_key $args + set cache_key $args #ideally we would use a fast hash algorithm to produce a short key with low collision probability. #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) #review - check if there is a built-into-tcl way to do this quickly @@ -668,8 +668,8 @@ tcl::namespace::eval punk::args { foreach a $textargs { lappend normargs [tcl::string::map {\r\n \n} $a] } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + set optionspecs [join $normargs \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 @@ -692,7 +692,7 @@ tcl::namespace::eval punk::args { #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices #default to 1 for convenience - #checks with no default + #checks with no default #-minsize -maxsize -range @@ -729,13 +729,13 @@ tcl::namespace::eval punk::args { #ansi colours can stop info complete from working (contain square brackets) #review - when exactly are ansi codes allowed/expected in record lines. # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket if {$has_punkansi} { set test_complete [punk::ansi::ansistrip $recordsofar] } else { - #review + #review #we only need to strip enough to stop interference with 'info complete' set test_complete [string map [list \x1b\[ ""] $recordsofar] } @@ -743,7 +743,7 @@ tcl::namespace::eval punk::args { #append linebuild [string trimleft $rawline] \n if {$in_record} { #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) @@ -761,7 +761,7 @@ tcl::namespace::eval punk::args { set in_record 1 regexp {(\s*).*} $rawline _all lastindent #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " + #puts "indent from rawline:$rawline " append linebuild $rawline \n } } else { @@ -769,14 +769,14 @@ tcl::namespace::eval punk::args { #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left if {[tcl::string::first "$lastindent " $rawline] == 0} { set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline + append linebuild $trimmedline } elseif {[tcl::string::first $lastindent $rawline] == 0} { set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline + append linebuild $trimmedline } else { append linebuild $rawline } - lappend records $linebuild + lappend records $linebuild set linebuild "" } } @@ -793,7 +793,7 @@ tcl::namespace::eval punk::args { #(common case of no leaders specified) set opt_any 0 set val_min 0 - set val_max -1 ;#-1 for no limit + set val_max -1 ;#-1 for no limit set DEF_definition_id $id #form_defs @@ -805,14 +805,14 @@ tcl::namespace::eval punk::args { set refs [dict create] set record_type "" - set record_number -1 ;# + set record_number -1 ;# foreach rec $records { set trimrec [tcl::string::trim $rec] switch -- [tcl::string::index $trimrec 0] { "" - # {continue} } incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict if {[llength $record_values] % 2 != 0} { #todo - avoid raising an error - store invalid defs keyed on id error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" @@ -853,19 +853,19 @@ tcl::namespace::eval punk::args { set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] + set form_ids_active [lindex $record_form_ids 0] } } foreach fid $record_form_ids { if {![dict exists $F $fid]} { if {$firstword eq "@form"} { - #only @form directly supplies keys + #only @form directly supplies keys dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] } else { dict set F $fid [New_command_form $fid] } } else { - #update form with current record opts, except -form + #update form with current record opts, except -form if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } } } @@ -912,7 +912,7 @@ tcl::namespace::eval punk::args { #global reference dict - independent of forms #ignore refs without an -id #store all keys except -id - #complete overwrite if refid repeated later on + #complete overwrite if refid repeated later on if {[dict exists $at_specs -id]} { dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] } @@ -938,7 +938,7 @@ tcl::namespace::eval punk::args { set doc_info [dict get $copyfrom doc_info] } foreach fid $record_form_ids { - #only use elements with matching form id? + #only use elements with matching form id? #probably this feature mainly useful for _default anyway so that should be ok #cooperative doc sets specified in same file could share via known form ids too #todo argdisplay_info by fid @@ -964,7 +964,7 @@ tcl::namespace::eval punk::args { # {4 anykeys {3 by}} # {5 anykeys {1 .. 1 to 3 by}} # }\ - # -fallback 1 + # -fallback 1 # ... # @parser -synopsis "start 'count' count ??'by'? step?"\ # -arities { @@ -976,7 +976,7 @@ tcl::namespace::eval punk::args { # 1 # {3 anykeys {1 by}} # } - # + # # see also after manual # @form -arities {1} # @form -arities { @@ -990,9 +990,9 @@ tcl::namespace::eval punk::args { if {[dict exists $at_specs -form]} { set idlist [dict get $at_specs -form] if {$idlist eq "*"} { - #* only applies to form ids that exist at the time + #* only applies to form ids that exist at the time set idlist [dict keys $F] - } + } set form_ids_active $idlist } #new form keys already created if they were needed (done for all records that have -form ) @@ -1001,7 +1001,7 @@ tcl::namespace::eval punk::args { set package_info [dict merge $package_info $at_specs] } cmd { - #allow arbitrary - review + #allow arbitrary - review set cmd_info [dict merge $cmd_info $at_specs] } doc { @@ -1009,7 +1009,7 @@ tcl::namespace::eval punk::args { } argdisplay { #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing set argdisplay_info [dict merge $argdisplay_info $at_specs] } opts { @@ -1063,8 +1063,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1154,8 +1154,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1246,8 +1246,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1315,12 +1315,12 @@ tcl::namespace::eval punk::args { foreach fid $record_form_ids { if {[dict get $F $fid argspace] eq "leaders"} { set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader + tcl::dict::set argdef_values -ARGTYPE leader #lappend leader_names $argname set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] if {$argname ni $temp_leadernames} { lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames } else { error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" } @@ -1330,7 +1330,7 @@ tcl::namespace::eval punk::args { } } else { set record_type value - tcl::dict::set argdef_values -ARGTYPE value + tcl::dict::set argdef_values -ARGTYPE value set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] lappend temp_valnames $argname tcl::dict::set F $fid VAL_NAMES $temp_valnames @@ -1370,7 +1370,7 @@ tcl::namespace::eval punk::args { tcl::dict::set spec_merged -type int } bool - boolean { - tcl::dict::set spec_merged -type bool + tcl::dict::set spec_merged -type bool } char - character { tcl::dict::set spec_merged -type char @@ -1386,7 +1386,7 @@ tcl::namespace::eval punk::args { } lappend opt_solos $argname } else { - #-solo only valid for flags + #-solo only valid for flags error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } } @@ -1444,7 +1444,7 @@ tcl::namespace::eval punk::args { set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id } else { if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] } else { puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" } @@ -1464,10 +1464,10 @@ tcl::namespace::eval punk::args { if {$is_opt} { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } else { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } tcl::dict::set F $fid ARG_INFO $argname $spec_merged #review existence of -default overriding -optional @@ -1496,7 +1496,7 @@ tcl::namespace::eval punk::args { } } } - } ;# end foreach fid record_form_ids + } ;# end foreach fid record_form_ids } ;# end foreach rec $records @@ -1527,9 +1527,9 @@ tcl::namespace::eval punk::args { #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } @@ -1547,17 +1547,17 @@ tcl::namespace::eval punk::args { #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - #in the above case we have no unique total_arity + #in the above case we have no unique total_arity #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" + #e.g given the invalid command "after cancel" # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from + #e.g commandline completion could show list of synopsis entries to select from set form_info [dict create] dict for {fid fdict} $F { @@ -1619,7 +1619,7 @@ tcl::namespace::eval punk::args { #return raw definition list as created with 'define' # - possibly with unresolved dynamic parts proc raw_def {id} { - variable id_cache_rawdef + variable id_cache_rawdef set realid [real_id $id] if {![dict exists $id_cache_rawdef $realid]} { return "" @@ -1632,8 +1632,8 @@ tcl::namespace::eval punk::args { variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} variable resolved_def_TYPE_CHOICEGROUPS { directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} } lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { @@ -1643,35 +1643,35 @@ tcl::namespace::eval punk::args { uses the 'spec' form to build a response in definition format. Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with + of tight coupling to the other function that should be done with care. Note that the directives @leaders @opts @values may appear multiple times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for + follow. When retrieving these - there is only a single result for each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before + When retrieving -types * each of these will be positioned before the arguments of that type - but this doesn't mean there was a single leading directive for this argument type in the source definition. Each argument has already had its complete specification recorded in its own result. - + When manually specifying -types, the order @leaders then @opts then @values must be maintained - but if they are placed before their corresponding arguments, they will not affect the retrieved arguments as these arguments are already fully spec'd. The defaults from the source can be removed by adding @leaders, @opts @values to the -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the + Each argument can have members of its spec overridden using the -override dictionary. " @leaders -min 0 -max 0 @opts -form -default 0 -help\ - "Ordinal index or name of command form" + "Ordinal index or name of command form" #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} -antiglobs -default {} -type list -help\ "Glob patterns for directive or argument/flags to be suppressed" @@ -1687,7 +1687,7 @@ tcl::namespace::eval punk::args { path for a command name" pattern -type string -optional 1 -default * -multiple 1 -help\ "glob-style patterns for retrieving value or switch - definitions. + definitions. If -type is * and pattern is * the entire definition including directive lines will be returned in line form. @@ -1698,8 +1698,8 @@ tcl::namespace::eval punk::args { will be returned. if -type is another directive such as @id, @doc etc the - patterns are ignored. - + patterns are ignored. + " }]] } @@ -1718,7 +1718,7 @@ tcl::namespace::eval punk::args { return } set patterns [list] - + #a definition id must not begin with "-" ??? review for {set i 0} {$i < [llength $args]} {incr i} { set a [lindex $args $i] @@ -1730,7 +1730,7 @@ tcl::namespace::eval punk::args { dict set opts $a [lindex $args $i] } else { set id [lindex $args $i] - set patterns [lrange $args $i+1 end] + set patterns [lrange $args $i+1 end] break } if {$i == [llength $args]-1} { @@ -1781,7 +1781,7 @@ tcl::namespace::eval punk::args { #set arg_info [dict get $specdict ARG_INFO] set arg_info [dict get $specdict FORMS $formname ARG_INFO] set argtypes [dict create leaders leader opts option values value] - + set opt_antiglobs [dict get $opts -antiglobs] set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] set suppressed_directives [list] @@ -1822,7 +1822,7 @@ tcl::namespace::eval punk::args { } } foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] + set dshort [string range $directive 1 end] if {"$directive" in $included_directives} { if {[dict exists $opt_override $directive]} { append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" @@ -1832,8 +1832,8 @@ tcl::namespace::eval punk::args { } } #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" switch -- $directive { @leaders {set defaults_key leaderspec_defaults} @opts {set defaults_key optspec_defaults} @@ -1925,7 +1925,7 @@ tcl::namespace::eval punk::args { } proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef + variable id_cache_rawdef set realid [real_id $id] if {$realid ne ""} { set speclist [tcl::dict::get $id_cache_rawdef $realid] @@ -1971,7 +1971,7 @@ tcl::namespace::eval punk::args { set deflist [raw_def $id] if {[dict exists $rawdef_cache $deflist -dynamic]} { return [dict get $rawdef_cache $deflist -dynamic] - } + } return [rawdef_is_dynamic $deflist] #@dynamic only has meaning as 1st element of a def in the deflist } @@ -2042,7 +2042,7 @@ tcl::namespace::eval punk::args { if {[tcl::dict::exists $aliases $id]} { return 1 } - variable id_cache_rawdef + variable id_cache_rawdef tcl::dict::exists $id_cache_rawdef $id } proc set_alias {alias id} { @@ -2061,7 +2061,7 @@ tcl::namespace::eval punk::args { } proc real_id {id} { - variable id_cache_rawdef + variable id_cache_rawdef variable aliases if {[tcl::dict::exists $aliases $id]} { set id [tcl::dict::get $aliases $id] @@ -2126,7 +2126,7 @@ tcl::namespace::eval punk::args { } append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" return $result } @@ -2136,7 +2136,7 @@ tcl::namespace::eval punk::args { if {[set gposn [lsearch $nslist {}]] >= 0} { lset nslist $gposn :: } - upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::NAMESPACES registered ;#list upvar ::punk::args::register::loaded_packages loaded_packages ;#list upvar ::punk::args::register::loaded_info loaded_info ;#dict upvar ::punk::args::register::scanned_packages scanned_packages ;#list @@ -2149,7 +2149,7 @@ tcl::namespace::eval punk::args { #e.g - gets called for each subcommand of an ensemble (could be many) # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- + # -- --- --- --- --- --- # common-case fast-path if {[llength $loaded_packages] == [llength $registered]} { @@ -2157,7 +2157,7 @@ tcl::namespace::eval punk::args { #assert - if all are registered - then all have been scanned ( return {} } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set unscanned [punklib_ldiff $registered $scanned_packages] if {[llength $unscanned]} { @@ -2191,7 +2191,7 @@ tcl::namespace::eval punk::args { dict lappend namespace_docpackages $documentedns $pkgns } lappend seen_documentedns $documentedns - } + } } } set ts_end [clock microseconds] @@ -2218,7 +2218,7 @@ tcl::namespace::eval punk::args { set docns ${pkgns}::argdoc if {[namespace exists $docns]} { if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns + lappend needed $docns } } if {[dict exists $namespace_docpackages $pkgns]} { @@ -2247,7 +2247,7 @@ tcl::namespace::eval punk::args { set epath [namespace path] set pkgns [namespace parent] if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail + namespace path [list {*}$epath $pkgns] ;#add to tail } } @@ -2259,7 +2259,7 @@ tcl::namespace::eval punk::args { namespace eval $evalns [list punk::args::define {*}$definitionlist] incr def_count } - } + } #process list of 2-element lists if {[info exists ${pkgns}::PUNKARGS_aliases]} { @@ -2322,7 +2322,7 @@ tcl::namespace::eval punk::args { # -------------------------------------- - #test of Get_caller + #test of Get_caller lappend PUNKARGS [list { @id -id ::punk::args::test1 @values -min 0 -max 0 @@ -2357,16 +2357,16 @@ tcl::namespace::eval punk::args { @cmd -name punk::args::arg_error -help\ "Generates a table (by default) of usage information for a command. A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept + switches and for subcommands or argument/switch values that accept a defined set of choices. These prefixes match the mechanism used to validate arguments (based on tcl::prefix::match). - This function is called during the argument parsing process + This function is called during the argument parsing process (if the definition is not only being used for documentation) It is also called by punk::args::usage which is in turn called by the punk::ns introspection facilities which creates on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. + oo objects where a manually defined one isn't present. " @leaders -min 2 -max 2 msg -type string -help\ @@ -2399,21 +2399,21 @@ tcl::namespace::eval punk::args { proc arg_error {msg spec_dict args} { #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. + #may be desirable to reduce overhead on catches. #consider per-namespace or namespace-tree configurability. #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. + #to resource availability etc - so the slower error generation time may not always be a problem. #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling #code which has no use for the enhanced error info. #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system #todo #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #todo - document unnamed leaders and unnamed values where -min and/or -max specified #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} #only |?-x?|string|... is shown in the output table. #should be something like: @@ -2435,7 +2435,7 @@ tcl::namespace::eval punk::args { namespace import ::punk::ansi::a ::punk::ansi::a+ } } - #limit colours to standard 16 so that themes can apply to help output + #limit colours to standard 16 so that themes can apply to help output variable arg_error_isrunning if {$arg_error_isrunning} { error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" @@ -2448,7 +2448,7 @@ tcl::namespace::eval punk::args { set arg_error_isrunning 1 set badarg "" - set returntype table ;#table as string + set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error set scheme error dict for {k v} $args { @@ -2487,14 +2487,14 @@ tcl::namespace::eval punk::args { } info - error {} default { - set scheme na + set scheme na } } #hack some basics for now. #for coloured schemes - use bold as well as brightcolour in case colour off. array set CLR {} set CLR(errormsg) [a+ brightred] - set CLR(title) "" + set CLR(title) "" set CLR(check) [a+ brightgreen] set CLR(solo) [a+ brightcyan] set CLR(choiceprefix) [a+ underline] @@ -2503,20 +2503,20 @@ tcl::namespace::eval punk::args { set CLR(cmdname) [a+ brightwhite] set CLR(groupname) [a+ bold] set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] switch -- $scheme { nocolour { set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] + set CLR(title) [a+ bold] set CLR(check) "" set CLR(solo) "" set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] + set CLR(cmdname) [a+ bold] set CLR(linebase_header) "" set CLR(linebase) "" - set CLR(ansibase_body) "" + set CLR(ansibase_body) "" } info { set CLR(errormsg) [a+ brightred bold] @@ -2525,8 +2525,8 @@ tcl::namespace::eval punk::args { set CLR(choiceprefix) [a+ brightgreen bold] set CLR(groupname) [a+ cyan bold] set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] } error { set CLR(errormsg) [a+ brightred bold] @@ -2535,8 +2535,8 @@ tcl::namespace::eval punk::args { set CLR(choiceprefix) [a+ brightgreen bold] set CLR(groupname) [a+ cyan bold] set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] } na { } @@ -2547,7 +2547,7 @@ tcl::namespace::eval punk::args { set RST "\x1b\[m" set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error #e.g list_as_table # use basic colours here to support terminals without extended colours @@ -2629,8 +2629,8 @@ tcl::namespace::eval punk::args { } if {$use_table} { set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col if {!$is_custom_argdisplay} { lappend blank_header_col "" @@ -2708,9 +2708,9 @@ tcl::namespace::eval punk::args { $t add_row [list "" $argdisplay_body] } else { if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header + lappend errlines $argdisplay_header } - lappend errlines {*}$argdisplay_body + lappend errlines {*}$argdisplay_body } } else { @@ -2719,18 +2719,18 @@ tcl::namespace::eval punk::args { set A_BADARG $CLR(badarg) set greencheck $CLR(check)\u2713$RST ;#green tick set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space } else { - set A_PREFIXEND $RST + set A_PREFIXEND $RST } set opt_names [list] - set opt_names_display [list] + set opt_names_display [list] if {[llength [dict get $spec_dict OPT_NAMES]]} { if {![catch {package require punk::trie}]} { set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] @@ -2752,14 +2752,14 @@ tcl::namespace::eval punk::args { lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] lappend opt_names $c - } + } } else { set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names + set opt_names_display $opt_names } } set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { # if {![string match -* $argname]} { @@ -2773,8 +2773,8 @@ tcl::namespace::eval punk::args { # set trailing_val_names $leading_val_names # set leading_val_names {} #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names #display options first then values foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { @@ -2788,7 +2788,7 @@ tcl::namespace::eval punk::args { set default "" } set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] + set allchoices_originalcase [list] set choices [Dict_getdef $arginfo -choices {}] set choicegroups [Dict_getdef $arginfo -choicegroups {}] set choicemultiple [dict get $arginfo -choicemultiple] @@ -2799,7 +2799,7 @@ tcl::namespace::eval punk::args { set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck + set multiple $greencheck set is_multiple 1 } else { set multiple "" @@ -2865,11 +2865,11 @@ tcl::namespace::eval punk::args { set idents [dict get [$trie shortest_idents ""] scanned] if {[dict get $arginfo -nocase]} { #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents + set actual_idents $idents foreach ch $allchoices_originalcase { if {![dict exists $idents $ch]} { #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict + #The actual testing is done in get_dict dict set actual_idents $ch [dict get $idents [string tolower $ch]] } } @@ -2899,12 +2899,12 @@ tcl::namespace::eval punk::args { append cdisplay \n [dict get $choicelabeldict $c] } dict lappend formattedchoices $groupname $cdisplay - } + } } } errM]} { #this failure can happen if -nocase is true and there are ambiguous entries #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" + puts stderr "prefix marking failed\n$errM" #append help "\n " [join [dict get $arginfo -choices] "\n "] if {[dict size $choicelabeldict]} { dict for {groupname clist} $choicegroups { @@ -2917,9 +2917,9 @@ tcl::namespace::eval punk::args { } } } else { - set formattedchoices $choicegroups + set formattedchoices $choicegroups } - + } } set choicetable_objects [list] @@ -2932,7 +2932,7 @@ tcl::namespace::eval punk::args { } if {$numcols > 0} { if {$use_table} { - #risk of recursing + #risk of recursing #TODO -title directly in list_as_table set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] lappend choicetable_objects $choicetableobj @@ -3053,7 +3053,7 @@ tcl::namespace::eval punk::args { -ansibase_body $CLR(ansibase_body)\ -ansibase_header $CLR(ansibase_header)\ -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) + -ansiborder_body $CLR(ansiborder) $t configure -maxwidth 80 ;#review if {$returntype ne "tableobject"} { @@ -3073,7 +3073,7 @@ tcl::namespace::eval punk::args { } set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) if {$use_table} { #assert returntype is one of table, tableobject @@ -3081,7 +3081,7 @@ tcl::namespace::eval punk::args { if {$returntype eq "tableobject"} { if {[info object isa object $t]} { set result $t - } + } } } else { set result $errmsg @@ -3109,8 +3109,8 @@ tcl::namespace::eval punk::args { IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. " -return -default table -choices {string table tableobject} } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { @@ -3136,7 +3136,7 @@ tcl::namespace::eval punk::args { @values -min 1 id arglist -type list -help\ - "list containing arguments to be parsed as per the + "list containing arguments to be parsed as per the argument specification identified by the supplied id." }] @@ -3154,7 +3154,7 @@ tcl::namespace::eval punk::args { #consider #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withid $id #parse ?-flag val?... -- $arglist withdef $def ?$def?... #an experiment.. ideally we'd like arglist at the end? @@ -3179,15 +3179,15 @@ tcl::namespace::eval punk::args { form1: parse $arglist ?-flag val?... withid $id form2: parse $arglist ?-flag val?... withdef $def ?$def? see punk::args::define" - @form -form {withid withdef} + @form -form {withid withdef} @leaders -min 1 -max 1 arglist -type list -optional 0 -help\ "Arguments to parse - supplied as a single list" - @opts + @opts -form -type list -default * -help\ "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a + Forms are the orthogonal sets of arguments a command can take - usually described in 'synopsis' entries." #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance @@ -3206,16 +3206,16 @@ tcl::namespace::eval punk::args { @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" withdef -type literal -help\ "The literal value 'withdef'" - + #todo - make -dynamic obsolete - use @dynamic directive instead def -type string -multiple 1 -optional 0 -help\ "Each remaining argument is a block of text defining argument definitions. - As a special case, -dynamic may be + As a special case, -dynamic may be specified as the 1st 2 arguments. These are treated as an indicator to punk::args about how to process the definition." - + }] proc parse {args} { set tailtype "" ;#withid|withdef @@ -3225,7 +3225,7 @@ tcl::namespace::eval punk::args { set parseargs [lindex $args 0] set tailargs [lrange $args 1 end] - set split [lsearch -exact $tailargs withid] + set split [lsearch -exact $tailargs withid] if {$split < 0} { set split [lsearch -exact $tailargs withdef] if {$split < 0} { @@ -3240,7 +3240,7 @@ tcl::namespace::eval punk::args { set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" + error "punk::args::parse Even number of -flag val pairs required after arglist" } set defaultopts [dict create\ -form {*}\ @@ -3253,7 +3253,7 @@ tcl::namespace::eval punk::args { } default { #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" } } } @@ -3312,7 +3312,7 @@ tcl::namespace::eval punk::args { } else { set arglist $a set got_arglist 1 - set tailtype [lindex $args $i+1] + set tailtype [lindex $args $i+1] if {$tailtype eq "withid"} { if {[llength $args] != $i+3} { error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" @@ -3335,7 +3335,7 @@ tcl::namespace::eval punk::args { } #assert tailtype eq withid|withdef if {$tailtype eq "withid"} { - #assert $id was provided + #assert $id was provided return "parse [llength $arglist] args withid $id, options:$opts" } else { #assert llength deflist >=1 @@ -3356,8 +3356,8 @@ tcl::namespace::eval punk::args { #see arg_error regarding considerations around unhappy-path performance #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? #can the above be made completely unambiguous for arbitrary arglist?? #e.g what if arglist = withdef and the first $def is also withdef ? @@ -3373,11 +3373,11 @@ tcl::namespace::eval punk::args { #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values #[para]Each optionspec line defining a flag must be of the form: #[para]-optionname -key val -key2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional #[para]Each optionspec line defining a positional argument is of the form: #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. #[arg_def list rawargs] @@ -3386,13 +3386,13 @@ tcl::namespace::eval punk::args { #[list_end] #[para] - #consider line-processing example below for which we need info complete to determine record boundaries + #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { # @opts # -opt1 -default {} # -opt2 -default { # etc - # } + # } # @values -multiple 1 #} $args @@ -3402,7 +3402,7 @@ tcl::namespace::eval punk::args { #if definition has been seen before, #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] # ----------------------------------------------- @@ -3415,7 +3415,7 @@ tcl::namespace::eval punk::args { set flagsreceived [list] ;#for checking if required flags satisfied #secondary purpose: #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. - #-default value must not be appended to if argname not yet in flagsreceived + #-default value must not be appended to if argname not yet in flagsreceived #todo: -minmultiple -maxmultiple ? @@ -3440,9 +3440,9 @@ tcl::namespace::eval punk::args { } if {$ridx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] + set leader_posn_name [lindex $LEADER_NAMES $ridx] if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 + set is_multiple 1 } } elseif {$ridx > [llength $LEADER_NAMES]-1} { #beyond names - retain name if -multiple was true @@ -3468,7 +3468,7 @@ tcl::namespace::eval punk::args { if {$leader_posn_name ne ""} { #there is a named leading positional for this position #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name incr ridx continue @@ -3480,7 +3480,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader + #optional leader #most adhoc arg processing will allocate based on number of args rather than matching choice values first #(because a choice value could be a legitimate data value) @@ -3501,19 +3501,19 @@ tcl::namespace::eval punk::args { if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { break } else { - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { #required if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional + #already accepted at least one value - requirement satisfied - now equivalent to optional if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { break - } + } } #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -3522,8 +3522,8 @@ tcl::namespace::eval punk::args { if {$ridx > $LEADER_MIN} { break } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -3553,7 +3553,7 @@ tcl::namespace::eval punk::args { #assert - rawargs has been reduced by leading positionals set leaders [list] - set arglist {} + set arglist {} set post_values {} #val_min, val_max #puts stderr "rawargs: $rawargs" @@ -3565,7 +3565,7 @@ tcl::namespace::eval punk::args { set vals_total_possible [llength $rawargs] set vals_remaining_possible $vals_total_possible } else { - set vals_total_possible $val_max + set vals_total_possible $val_max set vals_remaining_possible $vals_total_possible } for {set i 0} {$i <= $maxidx} {incr i} { @@ -3573,7 +3573,7 @@ tcl::namespace::eval punk::args { set remaining_args_including_this [expr {[llength $rawargs] - $i}] #lowest val_min is 0 if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here + # if current arg is -- it will pass through as a value here set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] break @@ -3586,7 +3586,7 @@ tcl::namespace::eval punk::args { if {$val_max != -1} { #finite max number of vals if {$remaining_args_including_this == $val_max} { - #assume it's a value. + #assume it's a value. set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] } else { @@ -3626,7 +3626,7 @@ tcl::namespace::eval punk::args { tcl::dict::lappend opts $fullopt $flagval } } else { - tcl::dict::set opts $fullopt $flagval + tcl::dict::set opts $fullopt $flagval } #incr i to skip flagval incr vals_remaining_possible -2 @@ -3664,21 +3664,21 @@ tcl::namespace::eval punk::args { } if {$opt_any} { set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS if {[tcl::dict::get $argstate $a -type] ne "none"} { if {[tcl::dict::get $argstate $a -multiple]} { tcl::dict::lappend opts $a $newval } else { - tcl::dict::set opts $a $newval + tcl::dict::set opts $a $newval } if {[incr i] > $maxidx} { arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a } incr vals_remaining_possible -2 } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none if {[tcl::dict::get $argstate $a -multiple]} { if {![tcl::dict::exists $opts $a]} { tcl::dict::set opts $a 1 @@ -3702,7 +3702,7 @@ tcl::namespace::eval punk::args { } } } else { - #not flaglike + #not flaglike set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] break @@ -3759,9 +3759,9 @@ tcl::namespace::eval punk::args { } set validx 0 - set in_multiple "" + set in_multiple "" set valnames_received [list] - set values_dict $val_defaults + set values_dict $val_defaults set num_values [llength $values] foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { @@ -3775,9 +3775,9 @@ tcl::namespace::eval punk::args { } else { tcl::dict::lappend values_dict $valname $val } - set in_multiple $valname + set in_multiple $valname } else { - tcl::dict::set values_dict $valname $val + tcl::dict::set values_dict $valname $val } lappend valnames_received $valname } else { @@ -3826,14 +3826,14 @@ tcl::namespace::eval punk::args { } } - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. - #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? @@ -3841,10 +3841,10 @@ tcl::namespace::eval punk::args { #struct::set difference {x} {a b} #normal interp 0.18 u2 vs safe interp 9.4us #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" #} #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { @@ -3907,7 +3907,7 @@ tcl::namespace::eval punk::args { } #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels @@ -3930,7 +3930,7 @@ tcl::namespace::eval punk::args { } #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - + switch -- [tcl::dict::get $thisarg -ARGTYPE] { leader { @@ -3973,7 +3973,7 @@ tcl::namespace::eval punk::args { if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } + } #----------------------------------- set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list @@ -3997,14 +3997,14 @@ tcl::namespace::eval punk::args { set choice_exact_match 0 if {$c_check in $allchoices} { #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check + set chosen $c_check set choice_in_list 1 set choice_exact_match 1 } elseif {$v_test in $choices_test} { #assert - if we're here, nocase must be true #we know choice is present as full-length match except for case #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #we don't set choice_exact_match - because we will need to override the optimistic existing val below #review foreach avail [lsort -unique $allchoices] { if {[string match -nocase $c $avail]} { @@ -4014,7 +4014,7 @@ tcl::namespace::eval punk::args { #assert chosen will always get set set choice_in_list 1 } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. #in this block we can treat empty result from prefix match as a non-match if {$nocase} { @@ -4033,7 +4033,7 @@ tcl::namespace::eval punk::args { set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] + set choice_in_list [expr {$chosen ne ""}] } else { set chosen $bestmatch set choice_in_list 1 @@ -4057,7 +4057,7 @@ tcl::namespace::eval punk::args { } #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { + if {$choice_in_list && !$choice_exact_match} { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { if {$is_multiple} { set existing [tcl::dict::get [set $dname] $argname] @@ -4091,7 +4091,7 @@ tcl::namespace::eval punk::args { # lset existing $idx $v_test # tcl::dict::set $dname $argname $existing #} else { - # tcl::dict::set $dname $argname $v_test + # tcl::dict::set $dname $argname $v_test #} lappend vlist_validate $c lappend vlist_check_validate $c_check @@ -4186,10 +4186,10 @@ tcl::namespace::eval punk::args { string - ansistring - globstring { #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail @@ -4197,7 +4197,7 @@ tcl::namespace::eval punk::args { set pass_quick_list_e [list] set pass_quick_list_e_check [list] set remaining_e $vlist - set remaining_e_check $vlist_check + set remaining_e_check $vlist_check #review - order of -regexprepass and -regexprefail in original rawargs significant? #for now -regexprepass always takes precedence if {$regexprepass ne ""} { @@ -4225,7 +4225,7 @@ tcl::namespace::eval punk::args { } switch -- $type { ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi #.. so we need to look at the original values in $vlist not $vlist_check #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? @@ -4271,7 +4271,7 @@ tcl::namespace::eval punk::args { } } int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive if {[tcl::dict::exists $thisarg -range]} { lassign [tcl::dict::get $thisarg -range] low high if {"$low$high" ne ""} { @@ -4290,7 +4290,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } - #highside unspecified - check only low + #highside unspecified - check only low if {$e_check < $low} { arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname } @@ -4300,7 +4300,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } - #high and low specified + #high and low specified if {$e_check < $low || $e_check > $high} { arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname } @@ -4312,7 +4312,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname } - } + } } } double { @@ -4465,7 +4465,7 @@ tcl::namespace::eval punk::args { set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] if {[llength $receivednames]} { #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] set i -1 set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] } else { @@ -4474,15 +4474,15 @@ tcl::namespace::eval punk::args { #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) #(e.g using 'dict exists $received -flag') # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements + #It is actually a list of paired elements return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] } #proc sample1 {p1 args} { # #*** !doctools # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" + # #[para]Description of sample1 + # return "ok" #} @@ -4513,14 +4513,14 @@ tcl::namespace::eval punk::args::lib { tcl::namespace::path [list [tcl::namespace::parent]] #*** !doctools #[subsection {Namespace punk::args::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 + # #[para]Description of utility1 + # return 1 #} proc flatzip {l1 l2} { @@ -4540,8 +4540,8 @@ tcl::namespace::eval punk::args::lib { lsearch -all [lrepeat $count 0] * } } - - + + #experiment with equiv of js template literals with ${expression} in templates #e.g tstr {This is the value of x in calling scope ${$x} !} #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} @@ -4552,7 +4552,7 @@ tcl::namespace::eval punk::args::lib { "A rough equivalent of js template literals Substitutions: - \$\{$varName\} + \$\{$varName\} \$\{[myCommand]\} (when -allowcommands flag is given)" -allowcommands -default 0 -type none -help\ @@ -4569,7 +4569,7 @@ tcl::namespace::eval punk::args::lib { -paramindents -default line -choices {none line position} -choicelabels { line\ " Use leading whitespace in - the line in which the + the line in which the placeholder occurs." position\ " Use the position in @@ -4578,21 +4578,21 @@ tcl::namespace::eval punk::args::lib { none\ " No indents applied to subsequent placeholder value - lines. This will usually - result in text awkwardly + lines. This will usually + result in text awkwardly ragged unless the source code has also been aligned with the left margin or the value has been manually padded." } -help\ - "How indenting is done for subsequent lines in a + "How indenting is done for subsequent lines in a multi-line placeholder substitution value. The 1st line or a single line value is always placed at the placeholder. - paramindents are performed after the main + paramindents are performed after the main template has been indented/undented. (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) + unicode double-wide or grapheme cluster widths) " #choicelabels indented by 1 char is clearer for -return string - and reasonable in table -return -default string -choices {dict list string args}\ @@ -4603,7 +4603,7 @@ tcl::namespace::eval punk::args::lib { 'errors'" string\ " Return a single result - being the string with + being the string with placeholders substituted." list\ " Return a 2 element list. @@ -4636,7 +4636,7 @@ tcl::namespace::eval punk::args::lib { For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. contained variables in that case should be braced or whitespace separated, or the variable name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" @values -min 0 -max 1 templatestring -help\ "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} @@ -4645,19 +4645,19 @@ tcl::namespace::eval punk::args::lib { It can contain commands in square brackets if -allowcommands is true e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - Escape sequences such as \\n and unicode escapes are processed within placeholders. + Escape sequences such as \\n and unicode escapes are processed within placeholders. " }] proc tstr {args} { #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only + # - we use punk::args within the unhappy path only #set argd [punk::args::get_by_id ::punk::lib::tstr $args] #set templatestring [dict get $argd values templatestring] #set opt_allowcommands [dict get $argd opts -allowcommands] #set opt_return [dict get $argd opts -return] #set opt_eval [dict get $argd opts -eval] - + set templatestring [lindex $args end] set arglist [lrange $args 0 end-1] set opts [dict create\ @@ -4773,7 +4773,7 @@ tcl::namespace::eval punk::args::lib { } if {$opt_eval} { if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] + lappend params [string cat \$\{ $expression \}] dict set errors [expr {[llength $params]-1}] $result } else { set result [string map [list \n "\n$leader"] $result] @@ -4790,7 +4790,7 @@ tcl::namespace::eval punk::args::lib { if {$opt_return eq "dict"} { return [dict create template $textchunks params $params errors $errors] - } + } if {[dict size $errors]} { set einfo "" dict for {i e} $errors { @@ -4828,7 +4828,7 @@ tcl::namespace::eval punk::args::lib { set lastline [string range $pt $lastline_posn+1 end] } if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent + regexp {(\s*).*} $lastline _all lastindent } else { #position #TODO - detect if there are grapheme clusters @@ -4847,8 +4847,8 @@ tcl::namespace::eval punk::args::lib { } } else { append out $pt $param - } - append lastline $param + } + append lastline $param } } return $out @@ -4859,9 +4859,9 @@ tcl::namespace::eval punk::args::lib { proc tstr_test_one {args} { set argd [punk::args::get_dict { @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. - example: + example: set id 2 - tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] } @values -min 2 -max 2 @@ -4882,8 +4882,8 @@ tcl::namespace::eval punk::args::lib { } set chars [split $templatestring ""] set in_placeholder 0 - set tchars "" - set echars "" + set tchars "" + set echars "" set parts [list] set i 0 foreach ch $chars { @@ -4912,7 +4912,7 @@ tcl::namespace::eval punk::args::lib { } else { append echars $ch } - } + } } incr i } @@ -4932,7 +4932,7 @@ tcl::namespace::eval punk::args::lib { } set list [list] set start 0 - #ideally re should allow curlies within but we will probably need a custom parser to do it + #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 {\$\{(?:(?!\$\{).)*\}} @@ -4945,14 +4945,14 @@ tcl::namespace::eval punk::args::lib { #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 + 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] + 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]} { @@ -4967,7 +4967,7 @@ tcl::namespace::eval punk::args::lib { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { - lappend result "" + lappend result "" } else { lappend result $prefix[string trimright $line] } @@ -5009,7 +5009,7 @@ tcl::namespace::eval punk::args::lib { #hacky proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be + #leader usually whitespace - but doesn't have to be if {$text eq ""} { return "" } @@ -5044,7 +5044,7 @@ tcl::namespace::eval punk::args::lib { } return [join $result \n] } - #A version of textutil::string::longestCommonPrefixList + #A version of textutil::string::longestCommonPrefixList proc longestCommonPrefix {items} { if {[llength $items] <= 1} { return [lindex $items 0] @@ -5061,9 +5061,9 @@ tcl::namespace::eval punk::args::lib { } set n [string length $min] set prefix "" - set i -1 + set i -1 while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c + append prefix $c } return $prefix } @@ -5099,7 +5099,7 @@ tcl::namespace::eval punk::args::package { " -package_about_namespace -type string -optional 0 -help\ "Namespace containing the package about procedures - Must contain " + Must contain " -return\ -type string\ -default table\ @@ -5140,7 +5140,7 @@ tcl::namespace::eval punk::args::package { set pkgname [${pkgns}::package_name] set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] + set all_topics [${pkgns}::about_topics] if {![dict exists $received topic]} { set topics $all_topics } else { @@ -5214,7 +5214,7 @@ tcl::namespace::eval punk::args::package { #can't do this here? - as there is circular dependency with punk::lib #tcl::namespace::eval punk::args { # foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist +# punk::args::define {*}$deflist # } # set PUNKARGS "" #} @@ -5227,7 +5227,7 @@ lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::p tcl::namespace::eval punk::args::system { #*** !doctools #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #dict get value with default wrapper for tcl 8.6 if {[info commands ::tcl::dict::getdef] eq ""} { @@ -5240,11 +5240,11 @@ tcl::namespace::eval punk::args::system { } } } else { - #we pay a minor perf penalty for the wrap + #we pay a minor perf penalty for the wrap interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef } - #name to reflect maintenance - home is punk::lib::ldiff + #name to reflect maintenance - home is punk::lib::ldiff proc punklib_ldiff {fromlist removeitems} { if {[llength $removeitems] == 0} {return $fromlist} set result {} @@ -5260,12 +5260,12 @@ tcl::namespace::eval punk::args::system { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/punk/assertion-0.1.0.tm b/src/bootsupport/modules/punk/assertion-0.1.0.tm index 8ad0af62..80f4b14d 100644 --- a/src/bootsupport/modules/punk/assertion-0.1.0.tm +++ b/src/bootsupport/modules/punk/assertion-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::assertion 0 0.1.0] #[copyright "2024"] #[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] -#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] +#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] #[require punk::assertion] #[keywords module assertion assert debug] #[description] @@ -99,9 +99,9 @@ tcl::namespace::eval punk::assertion::class { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin +#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin tcl::namespace::eval punk::assertion::primary { - #tcl::namespace::export {[a-z]*} + #tcl::namespace::export {[a-z]*} tcl::namespace::export assertActive assertInactive proc assertActive {expr args} { @@ -112,7 +112,7 @@ tcl::namespace::eval punk::assertion::primary { if {![tcl::string::is boolean -strict $res]} { return -code error "invalid boolean expression: $expr" } - + if {$res} {return} if {[llength $args]} { @@ -130,9 +130,9 @@ tcl::namespace::eval punk::assertion::primary { } tcl::namespace::eval punk::assertion::secondary { - tcl::namespace::export * + tcl::namespace::export * #we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want. - proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] + proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] proc assertInactive args {} } @@ -151,7 +151,7 @@ tcl::namespace::eval punk::assertion { } do_ns_import #puts --------BBB - rename assertActive assert + rename assertActive assert } @@ -162,20 +162,20 @@ tcl::namespace::eval punk::assertion { #*** !doctools #[subsection {Namespace punk::assertion}] - #[para] Core API functions for punk::assertion + #[para] Core API functions for punk::assertion #[list_begin definitions] #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]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" #} #like tcllib's control::assert - we are limited to the same callback for all namespaces. @@ -218,7 +218,7 @@ tcl::namespace::eval punk::assertion { if {$on_off} { #Enable it in calling namespace if {"assert" eq $info_command} { - #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) + #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] @@ -243,7 +243,7 @@ tcl::namespace::eval punk::assertion { } return 1 } else { - #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace + #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] if {[tcl::string::match ::punk::assertion::* $assertorigin]} { @@ -303,8 +303,8 @@ tcl::namespace::eval punk::assertion { return 0 } } else { - #no assert command reachable - #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path + #no assert command reachable + #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" return 0 } @@ -327,14 +327,14 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::assertion::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 + # #[para]Description of utility1 + # return 1 #} @@ -352,7 +352,7 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::eval punk::assertion::system { #*** !doctools #[subsection {Namespace punk::assertion::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #Maintenance - snarfed from punk::ns to reduce dependencies - punk::ns::nsprefix is the master version #nsprefix/nstail are string functions - they do not concern themselves with what namespaces are present in the system @@ -375,7 +375,7 @@ tcl::namespace::eval punk::assertion::system { proc nstail {nspath args} { #normalize the common case of :::: set nspath [tcl::string::map [list :::: ::] $nspath] - set mapped [tcl::string::map [list :: \u0FFF] $nspath] + set mapped [tcl::string::map [list :: \u0FFF] $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] @@ -411,11 +411,11 @@ tcl::namespace::eval punk::assertion::system { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::assertion [tcl::namespace::eval punk::assertion { variable pkg punk::assertion variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/punk/cap-0.1.0.tm b/src/bootsupport/modules/punk/cap-0.1.0.tm index 68d3252e..2ede3723 100644 --- a/src/bootsupport/modules/punk/cap-0.1.0.tm +++ b/src/bootsupport/modules/punk/cap-0.1.0.tm @@ -26,7 +26,7 @@ #[para]punk::cap provides management of named capabilities and the provider packages and handler packages that implement a pluggable capability. #[para]see also [uri https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/pluginmgr/pluginmgr.md {tcllib pluginmgr}] for an alternative which uses safe interpreters #[subsection Concepts] -#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API +#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API # #[para][term {capability handler}] - a package/namespace which may provide validation and standardised ways of looking up provider data # registered (or not) using register_capabilityname @@ -49,7 +49,7 @@ package require oolib # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::cap { - variable pkgcapsdeclared [tcl::dict::create] + variable pkgcapsdeclared [tcl::dict::create] variable pkgcapsaccepted [tcl::dict::create] variable caps [tcl::dict::create] namespace eval class { @@ -71,8 +71,8 @@ tcl::namespace::eval punk::cap { #*** !doctools #[call class::interface_caphandler.registry [method pkg_register] [arg pkg] [arg capname] [arg capdict] [arg fullcapabilitylist]] #handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid - #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. - return 1 ;#default to permit + #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. + return 1 ;#default to permit } method pkg_unregister {pkg} { #*** !doctools @@ -106,9 +106,9 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.registration { #*** !doctools # [enum] CLASS [class interface_cappprovider.registration] - # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. + # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. # [para]If your package namespace is mypackages::providerpkg then the object command would be at mypackages::providerpkg::capsystem::capprovider.registration - # [para]Example code for your provider package to evaluate within its namespace: + # [para]Example code for your provider package to evaluate within its namespace: # [example { #namespace eval capsystem { # if {[info commands capprovider.registration] eq ""} { @@ -133,7 +133,7 @@ tcl::namespace::eval punk::cap { #[para] This method must be overridden by your provider using oo::objdefine cappprovider.registration as in the example above. # There must be at least one 2-element list in the result for the provider to be registerable. #[para]The first element of the list is the capabilityname - which can be custom to your provider/handler packages - or a well-known name that other authors may use/implement. - #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. + #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. error "interface_capprovider.registration not implemented by provider" } #*** !doctools @@ -142,11 +142,11 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.provider { #*** !doctools - # [enum] CLASS [class interface_capprovider.provider] - # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] + # [enum] CLASS [class interface_capprovider.provider] + # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] # [example { - # namespace eval mypackages::providerpkg { - # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg + # namespace eval mypackages::providerpkg { + # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg # } # }] # [list_begin definitions] @@ -229,7 +229,7 @@ tcl::namespace::eval punk::cap { #Not all capability names have to be registered. #A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated handler. - #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. + #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. #we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. proc register_capabilityname {capname capnamespace} { #puts stderr "REGISTER_CAPABILITYNAME $capname $capnamespace" @@ -243,10 +243,10 @@ tcl::namespace::eval punk::cap { } } #allow register of existing capname iff there is no current handler - #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package - #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers + #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package + #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers if {[set hdlr [capability_get_handler $capname]] ne ""} { - puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" + puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" return } #assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. @@ -295,14 +295,14 @@ tcl::namespace::eval punk::cap { if {$count == 0} { set pkgposn [lsearch $providers $pkg] if {$pkgposn >= 0} { - set updated_providers [lreplace $providers $posn $posn] + set updated_providers [lreplace $providers $posn $posn] tcl::dict::set caps $capname providers $updated_providers } } } } - + } } proc capability_exists {capname} { @@ -328,7 +328,7 @@ tcl::namespace::eval punk::cap { if {[tcl::dict::exists $caps $capname]} { return [tcl::dict::get $caps $capname handler] } - return "" + return "" } proc call_handler {capname args} { if {[set handler [capability_get_handler $capname]] eq ""} { @@ -461,7 +461,7 @@ tcl::namespace::eval punk::cap { #todo! proc unregister_package {pkg {capname *}} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] @@ -471,7 +471,7 @@ tcl::namespace::eval punk::cap { set capabilitylist [dict get $pkgcapsdeclared $pkg] foreach c $capabilitylist { set do_unregister 1 - lassign $c capname _capdict + lassign $c capname _capdict set cap_info [dict get $caps $capname] set pkglist [dict get $cap_info providers] set posn [lsearch $pkglist $pkg] @@ -479,9 +479,9 @@ tcl::namespace::eval punk::cap { if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { #review # it seems not useful to allow the callback to block this unregister action - #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter - #vetoing unregister would make this more complex for no particular advantage - #if per dataset deregistration required this should probably be a separate thing + #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter + #vetoing unregister would make this more complex for no particular advantage + #if per dataset deregistration required this should probably be a separate thing $capreg pkg_unregister $pkg $capname } set pkglist [lreplace $pkglist $posn $posn] @@ -510,7 +510,7 @@ tcl::namespace::eval punk::cap { } } proc pkgcaps {} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable pkgcapsaccepted set result [dict create] foreach {pkg capsdeclared} $pkgcapsdeclared { @@ -522,7 +522,7 @@ tcl::namespace::eval punk::cap { dict set result $pkg accepted $accepted } return $result - } + } proc capability {capname} { variable caps @@ -565,14 +565,14 @@ tcl::namespace::eval punk::cap { #[subsection {Namespace punk::cap::advanced}] #[para] punk::cap::advanced API. Functions here are generally not the preferred way to interact with punk::cap. #[para] In some cases they may allow interaction in less safe ways or may allow use of features that are unavailable in the base namespace. - #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. + #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. #[list_begin definitions] proc promote_provider {pkg} { #*** !doctools # [call advanced::[fun promote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. #[para] #[para] promote/demote doesn't always make a lot of sense .. should preferably be configurable per capapbility for multicap provider pkgs #[para]The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded @@ -615,7 +615,7 @@ tcl::namespace::eval punk::cap { #*** !doctools # [call advanced::[fun demote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { @@ -677,11 +677,11 @@ tcl::namespace::eval punk::cap { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap [namespace eval punk::cap { variable version variable pkg punk::cap - set version 0.1.0 + set version 0.1.0 variable README.md [string map [list %pkg% $pkg %ver% $version] { # punk capabilities system ## pkg: %pkg% version: %ver% diff --git a/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm b/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm index 8fdce944..4a19666b 100644 --- a/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm +++ b/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm @@ -43,10 +43,10 @@ namespace eval punk::cap::handlers::caphandler { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { variable pkg punk::cap::handlers::caphandler variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index 5624ec58..60764f07 100644 --- a/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -23,7 +23,7 @@ package require punk::repo # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #register using: -# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates +# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates #By convention and for consistency, we don't register here during package loading - but require the calling app to do it. # (even if it tends to be done immediately after package require anyway) @@ -67,11 +67,11 @@ namespace eval punk::cap::handlers::templates { #for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called - #for template pathtype absolute - we can do the same. - #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. + #for template pathtype absolute - we can do the same. + #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. #adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time. - #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - + #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - #but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly. switch -- $pathtype { adhoc { @@ -95,7 +95,7 @@ namespace eval punk::cap::handlers::templates { } else { set tm_exists [file exists $tmfile] } - if {![file exists $tmfile]} { + if {!$tm_exists} { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" flush stderr return 0 @@ -128,7 +128,7 @@ namespace eval punk::cap::handlers::templates { } set extended_capdict $capdict - dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? + dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? } currentproject { if {[file pathtype $path] ne "relative"} { @@ -140,7 +140,7 @@ namespace eval punk::cap::handlers::templates { set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor } shellproject { if {[file pathtype $path] ne "relative"} { @@ -150,7 +150,7 @@ namespace eval punk::cap::handlers::templates { set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review set projectinfo [punk::repo::find_repos $shellbase] set projectbase [dict get $projectinfo closest] - + set extended_capdict $capdict dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase @@ -170,7 +170,7 @@ namespace eval punk::cap::handlers::templates { set projectbase [dict get $projectinfo closest] set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } absolute { @@ -188,7 +188,7 @@ namespace eval punk::cap::handlers::templates { #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict - dict set extended_capdict resolved_path $normpath + dict set extended_capdict resolved_path $normpath dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } @@ -199,7 +199,7 @@ namespace eval punk::cap::handlers::templates { } # -- --- --- --- --- --- --- ---- --- - # update package internal data + # update package internal data # -- --- --- --- --- --- --- ---- --- upvar ::punk::cap::handlers::templates::provider_info_$cname provider_info @@ -208,13 +208,13 @@ namespace eval punk::cap::handlers::templates { } if {![info exists provider_info] || $extended_capdict ni [dict get $provider_info $pkg]} { #this checks for duplicates from the same provider - but not if other providers already added the path - #review - + #review - dict lappend provider_info $pkg $extended_capdict } # -- --- --- --- --- --- --- ---- --- - # instantiation of api at punk::cap::handlers::templates::api_$capname + # instantiation of api at punk::cap::handlers::templates::api_$capname # -- --- --- --- --- --- --- ---- --- set apicmd "::punk::cap::handlers::templates::api_$capname" if {[info commands $apicmd] eq ""} { @@ -227,12 +227,12 @@ namespace eval punk::cap::handlers::templates { upvar ::punk::cap::handlers::templates::handled_caps hcaps foreach capname $hcaps { set cname [string map {. _} $capname] - upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info + upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info dict unset my_provider_info $pkg #destroy api objects? } } - } + } } } @@ -293,7 +293,7 @@ namespace eval punk::cap::handlers::templates { set found_paths_absolute [list] - foreach pkg $providerpkg { + foreach pkg $providerpkg { set found_paths [list] #set acceptedlist [dict get [punk::cap::pkgcap $pkg $capabilityname] accepted] @@ -314,13 +314,13 @@ namespace eval punk::cap::handlers::templates { set module_projectroot [dict get $capdecl_extended projectbase] dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] } elseif {$pathtype eq "currentproject_multivendor"} { - set searchbase $startdir + set searchbase $startdir set pathinfo [punk::repo::find_repos $searchbase] set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { set deckbase [file join $pwd_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -349,7 +349,7 @@ namespace eval punk::cap::handlers::templates { } } } elseif {$pathtype eq "currentproject"} { - set searchbase $startdir + set searchbase $startdir set pathinfo [punk::repo::find_repos $searchbase] set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { @@ -369,7 +369,7 @@ namespace eval punk::cap::handlers::templates { if {$shell_projectroot ne ""} { set deckbase [file join $shell_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -471,19 +471,19 @@ namespace eval punk::cap::handlers::templates { return $folderdict } method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { + set argd [punk::args::get_dict { @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" @opts -anyopts 1 #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here -startdir -default "" @values -maxvalues -1 - } $args] + } $args] set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { set searchbase [pwd] } else { - set searchbase $opt_startdir + set searchbase $opt_startdir } set refdict [my get_itemdict_projectlayoutrefs {*}$args] @@ -502,7 +502,7 @@ namespace eval punk::cap::handlers::templates { # e.g ref may be @vendor+punks+othersample@sample-0.1 or layoutalias-1.1@vendor+punk+othersample@sample-0.1 #there must always be an @ before vendor or custom . There is either a template-name alias or empty string before this first @ #trim off first @ part - set tailats [join [lrange $atparts 1 end] @] + set tailats [join [lrange $atparts 1 end] @] # @ parts after the first are part of the path within the project_layouts structure set subpathlist [split $tailats +] if {[dict exists $refinfo sourceinfo projectbase]} { @@ -553,7 +553,7 @@ namespace eval punk::cap::handlers::templates { if {$vendor ne "_project"} { set itemname $vendor.$itemname } - return $itemname + return $itemname }}} } set arglist [concat $config $args] @@ -623,7 +623,7 @@ namespace eval punk::cap::handlers::templates { }}}\ -command_get_item_name {apply {{vendor basefolder itempath} { - set relativepath [punk::path::relative $basefolder $itempath] + set relativepath [punk::path::relative $basefolder $itempath] set dirs [file dirname $relativepath] if {$dirs eq "."} { set dirs "" @@ -636,7 +636,7 @@ namespace eval punk::cap::handlers::templates { } if {$vendor ne "_project"} { set tname ${vendor}.$tname - } + } return $tname }}} } @@ -645,11 +645,11 @@ namespace eval punk::cap::handlers::templates { } #shared algorithm for get_itemdict_* methods - #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search + #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { + set argd [punk::args::get_dict { @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" @cmd -name _get_itemdict @opts -anyopts 0 @@ -657,7 +657,7 @@ namespace eval punk::cap::handlers::templates { -templatefolder_subdir -optional 0 -command_get_items_from_base -optional 0 -command_get_item_name -optional 0 - -not -default "" -multiple 1 + -not -default "" -multiple 1 @values -maxvalues -1 globsearches -default * -multiple 1 } $args] @@ -697,12 +697,12 @@ namespace eval punk::cap::handlers::templates { set items_here [dict create] ;#maintain a list keyed on name for sorting within this base only foreach itempath $matches { set itemname [{*}$opt_command_get_item_name $vendor $basefolder $itempath] - dict set items_here $itemname [list item $itempath baseinfo $baseinfo] + dict set items_here $itemname [list item $itempath baseinfo $baseinfo] #lappend items [list item $itempath baseinfo $baseinfo] } set ordered_names [lsort [dict keys $items_here]] - #add to the outer items list - foreach nm $ordered_names { + #add to the outer items list + foreach nm $ordered_names { set iteminfo [dict get $items_here $nm] lappend items [list originalname $nm iteminfo $iteminfo] } @@ -715,8 +715,8 @@ namespace eval punk::cap::handlers::templates { set itempath [dict get $iteminfo item] set baseinfo [dict get $iteminfo baseinfo] if {![dict exists $seen_dict $oname]} { - dict set seen_dict $oname 1 - dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number + dict set seen_dict $oname 1 + dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number } else { set n [dict get $seen_dict $oname] incr n @@ -730,7 +730,7 @@ namespace eval punk::cap::handlers::templates { set result [dict create] set keys [lreverse [dict keys $itemdict]] foreach k $keys { - set maybe "" + set maybe "" foreach g $globsearches { if {[string match $g $k]} { set maybe $k @@ -745,7 +745,7 @@ namespace eval punk::cap::handlers::templates { break } } - } + } if {$maybe ne "" && $not eq ""} { dict set result $k [dict get $itemdict $k] } @@ -762,10 +762,10 @@ namespace eval punk::cap::handlers::templates { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { variable pkg punk::cap::handlers::templates variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/bootsupport/modules/punk/char-0.1.0.tm b/src/bootsupport/modules/punk/char-0.1.0.tm index 43dcd6b5..675f42b0 100644 --- a/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/bootsupport/modules/punk/char-0.1.0.tm @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_punk::char 0 0.1.0] #[copyright "2024"] #[titledesc {character-set and unicode utilities}] [comment {-- Name section and table of contents description --}] -#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] +#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] #[require punk::char] #[keywords module encodings] #[description] @@ -49,11 +49,11 @@ #*** !doctools #[item] [package {overtype}] -#[para] - +#[para] - #[item] [package {textblock}] -#[para] - +#[para] - #[item] [package console] -#[para] - +#[para] - package require Tcl 8.6- #dependency on tcllib not ideal for bootstrapping as punk::char is core to many features.. (textutil::wcswidth is therefore included in bootsupport/include_modules.config) review @@ -92,20 +92,20 @@ tcl::namespace::eval punk::char { #just the 7-bit ascii. use [page ascii] for the 8-bit layout proc ascii {} {return { 00 NUL 01 SOH 02 STX 03 ETX 04 EOT 05 ENQ 06 ACK 07 BEL - 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI + 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI 10 DLE 11 DC1 12 DC2 13 DC3 14 DC4 15 NAK 16 SYN 17 ETB - 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US - 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' - 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / - 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 - 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? - 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G - 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O - 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W - 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ - 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g - 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o - 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w + 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US + 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' + 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / + 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 + 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? + 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G + 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O + 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W + 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ + 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g + 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o + 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w 78 x 79 y 7a z 7b { 7c | 7d } 7e ~ 7f DEL }} @@ -124,7 +124,7 @@ tcl::namespace::eval punk::char { } elseif {[tcl::string::length $v] == 0} { set v " " } - append out "$k $v " + append out "$k $v " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -143,7 +143,7 @@ tcl::namespace::eval punk::char { set out "" append out [page dingbats] \n set unicode_dict [charset_dictget Dingbats] - + append out " " set i 1 tcl::dict::for {k charinfo} $unicode_dict { @@ -155,7 +155,7 @@ tcl::namespace::eval punk::char { } else { set displayv $char } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -205,7 +205,7 @@ tcl::namespace::eval punk::char { tcl::dict::lappend d $encname $mname } } - } + } foreach enc [lsort $encnames] { set mime_enc [${encmimens}::mapencoding $enc] if {$mime_enc ne ""} { @@ -236,7 +236,7 @@ tcl::namespace::eval punk::char { tailcall page $encname {*}$args } - #This will not display for example, c0 glyphs for cp437 + #This will not display for example, c0 glyphs for cp437 # we could use the punk::ansi::cp437_map dict - but while that might be what some expect to see - it would probably be too much magic for this function - which is intended to align more with what Tcl's encoding convertfrom/to actually does. # for nonprinting members of the page, 2 and 3 letter codes are used rather than unicode visualisation replacements or even unicode equivalent replacements known to be appropriate for the page proc page {encname args} { @@ -255,7 +255,7 @@ tcl::namespace::eval punk::char { #set d_ascii [pagedict_raw ascii] set d_ascii [basedict] - set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi + set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi #The results of this are best seen by comparing the ebcdic and ascii pages set d_page [pagedict_raw $encname] @@ -285,7 +285,7 @@ tcl::namespace::eval punk::char { set displayv $bytedisplay } else { if {[tcl::string::length $rawchar] == 0} { - set displayv " " + set displayv " " } else { #presumed 1 set displayv " $rawchar " @@ -294,7 +294,7 @@ tcl::namespace::eval punk::char { } } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % $cols == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -318,7 +318,7 @@ tcl::namespace::eval punk::char { set outchar [encoding convertfrom $encpage $ch] } else { #here we will use \0xFFFD instead of our replacement string ??? - as the name pagechar implies always returning a single character. REVIEW. - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -348,7 +348,7 @@ tcl::namespace::eval punk::char { #set outchar [encoding convertto $encpage [format %c $num]] set outchar [format %c $num] } else { - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -381,7 +381,7 @@ tcl::namespace::eval punk::char { } proc pagedict_raw {encname} { - variable invalid ;# ="???" + variable invalid ;# ="???" set encname [encname $encname] set d [tcl::dict::create] for {set i 0} {$i < 256} {incr i} { @@ -409,7 +409,7 @@ tcl::namespace::eval punk::char { tcl::dict::set d $k [tcl::dict::get $a128 $k] } else { # - tcl::dict::set d $k $invalid + tcl::dict::set d $k $invalid } if {$i <=32} { @@ -457,7 +457,7 @@ tcl::namespace::eval punk::char { } return $d } - + proc basedict {} { #this gives same result independent of current value of 'encoding system' set d [tcl::dict::create] @@ -529,10 +529,10 @@ tcl::namespace::eval punk::char { return $d } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- # encoding convertfrom & encoding convertto can be somewhat confusing to think about. (Need to think in reverse.) # e.g encoding convertto dingbats will output something that doesn't look dingbatty on screen. - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- #must use Tcl instead of tcl (at least for 8.6) if {![package vsatisfies [package present Tcl] 8.7-]} { proc encodable "s {enc [encoding system]}" { @@ -574,7 +574,7 @@ tcl::namespace::eval punk::char { } } } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- proc test_japanese {{encoding jis0208}} { #A very basic test of 2char encodings such as jis0208 set yatbun 日本 ;# encoding convertfrom jis0208 F|K\\ @@ -584,7 +584,7 @@ tcl::namespace::eval punk::char { set ebun [encoding convertto $encoding $bun] puts "$encoding encoded: ${eyat} ${ebun}" puts "reencoded: [encoding convertfrom $encoding $eyat] [encoding convertfrom $encoding $ebun]" - return $yatbun + return $yatbun } proc test_grave {} { set g [format %c 0x300] @@ -692,7 +692,7 @@ tcl::namespace::eval punk::char { #ESC ( B ESC ) B ASCII Set #ESC ( 0 ESC ) 0 Special Graphics #ESC ( 1 ESC ) 1 Alternate Character ROM Standard Character Set - #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic + #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Unicode character sets - some hardcoded - some loadable from data files @@ -700,7 +700,7 @@ tcl::namespace::eval punk::char { variable charinfo [tcl::dict::create] variable charsets [tcl::dict::create] - + # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Aggregate character sets (ones that pick various ranges from underlying unicode ranges) # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -741,7 +741,7 @@ tcl::namespace::eval punk::char { } # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # Unicode ranges + # Unicode ranges # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- tcl::dict::set charsets "greek" [list ranges [list {start 880 end 1023} {start 7936 end 8191}] description "Greek and Coptic" settype "other"] @@ -975,9 +975,9 @@ tcl::namespace::eval punk::char { variable charset_extents_rangenames ;# dict keyed on start,end pointing to list of 2-tuples {setname rangeindex_within_set} #build 2 indexes for each range.(charsets are not just unicode blocks so can have multiple ranges) #Note that a range could be as small as a single char (startpoint = endpoint) so there can be many ranges with same start and end if charsets use some of the same subsets. - #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict - #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key - #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key + #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict + #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key + #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key proc _build_charset_extents {} { variable charsets variable charset_extents_startpoints @@ -995,7 +995,7 @@ tcl::namespace::eval punk::char { set end [tcl::dict::get [lindex $ranges 0] end] if {![tcl::dict::exists $charset_extents_startpoints $start] || $end ni [tcl::dict::get $charset_extents_startpoints $start]} { #assertion if end wasn't in startpoits list - then start won't be in endpoints list - tcl::dict::lappend charset_extents_startpoints $start $end + tcl::dict::lappend charset_extents_startpoints $start $end tcl::dict::lappend charset_extents_endpoints $end $start } tcl::dict::lappend charset_extents_rangenames ${start},${end} [list $setname 1] @@ -1023,14 +1023,14 @@ tcl::namespace::eval punk::char { #no need to sort charset_extents_rangenames - lookup only done using dict methods return [tcl::dict::size $charset_extents_startpoints] } - _build_charset_extents ;#rebuilds for all charsets + _build_charset_extents ;#rebuilds for all charsets #nerdfonts are within the Private use E000 - F8FF range proc load_nerdfonts {} { variable charsets variable charinfo package require fileutil - set ver [package provide punk::char] + set ver [package provide punk::char] if {$ver ne ""} { set ifneeded [package ifneeded punk::char [package provide punk::char]] #puts stderr "punk::char ifneeded script: $ifneeded" @@ -1038,7 +1038,7 @@ tcl::namespace::eval punk::char { set basedir [file dirname [lindex $sourceinfo end]] } else { #review - will only work at package load time - set scr [info script] + set scr [info script] if {$scr eq ""} { error "load_nerdfonts unable to determine package folder" } @@ -1048,7 +1048,7 @@ tcl::namespace::eval punk::char { set fname [file join $pkg_data_dir nerd-fonts-glyph-list.txt] if {[file exists $fname]} { #puts stderr "load_nerdfonts loading $fname" - set data [fileutil::cat -translation binary $fname] + set data [fileutil::cat -translation binary $fname] set short_seen [tcl::dict::create] set current_set_range [tcl::dict::create] set filesets_loading [list] @@ -1066,7 +1066,7 @@ tcl::namespace::eval punk::char { dict unset charset $setname } set newrange [list start $dec end $dec] - tcl::dict::set current_set_range $setname $newrange + tcl::dict::set current_set_range $setname $newrange tcl::dict::set charsets $setname [list ranges [list $newrange] description "nerd fonts $rawsetname" settype "nerdfonts privateuse"] lappend filesets_loading $setname @@ -1080,13 +1080,13 @@ tcl::namespace::eval punk::char { #overwrite last ranges element set rangelist [lrange [tcl::dict::get $charsets $setname ranges] 0 end-1] lappend rangelist [tcl::dict::get $current_set_range $setname] - tcl::dict::set charsets $setname ranges $rangelist + tcl::dict::set charsets $setname ranges $rangelist } else { #new range for set tcl::dict::set current_set_range $setname start $dec tcl::dict::set current_set_range $setname end $dec set rangelist [tcl::dict::get $charsets $setname ranges] - lappend rangelist [tcl::dict::get $current_set_range $setname] + lappend rangelist [tcl::dict::get $current_set_range $setname] tcl::dict::set charsets $setname ranges $rangelist } @@ -1130,7 +1130,7 @@ tcl::namespace::eval punk::char { proc package_base {} { #assume punk::char is in .tm form and we can use the package provide statement to determine base location - #review + #review set pkgver [package present punk::char] set pkginfo [package ifneeded punk::char $pkgver] set tmfile [lindex $pkginfo end] @@ -1156,7 +1156,7 @@ tcl::namespace::eval punk::char { if {[tcl::dict::exists $dictValue {*}$keys]} { return [tcl::dict::get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } } @@ -1181,7 +1181,7 @@ tcl::namespace::eval punk::char { } puts "ok.. loading" set fd [open $file r] - fconfigure $fd -translation binary + chan configure $fd -translation binary set data [read $fd] close $fd set block_count 0 @@ -1193,7 +1193,7 @@ tcl::namespace::eval punk::char { if {[set pcolon [tcl::string::first ";" $ln]] > 0} { set lhs [tcl::string::trim [tcl::string::range $ln 0 $pcolon-1]] set name [tcl::string::trim [tcl::string::range $ln $pcolon+1 end]] - set lhsparts [split $lhs .] + set lhsparts [split $lhs .] set start [lindex $lhsparts 0] set end [lindex $lhsparts end] #puts "$start -> $end '$name'" @@ -1207,9 +1207,9 @@ tcl::namespace::eval punk::char { return $block_count } - #unicode scripts + #unicode scripts - #unicode UnicodeData.txt + #unicode UnicodeData.txt @@ -1225,8 +1225,8 @@ tcl::namespace::eval punk::char { # -- --- #A = Ambiguous - All characters that can be sometimes wide and sometimes narrow. (wide in east asian legacy sets, narrow in non-east asian usage) (private use chars considered ambiguous) #F = East Asian Full-width - #H = East Asian Half-width - #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na + #H = East Asian Half-width + #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na #Na = East Asian Narrow - all other characters that are always narrow and have explicit full-width counterparts (e.g includes all of ASCII) #W = East Asian Wide - all other characters that are always wide (Occur only in the context of Eas Asian Typography) # -- --- @@ -1304,7 +1304,7 @@ tcl::namespace::eval punk::char { set initial_fields $known_fields if {"testwidth" ni $opt_fields} { if {"testwidth" ni $opt_except} { - lappend opt_except testwidth + lappend opt_except testwidth } } if {"char" ni $opt_fields} { @@ -1369,13 +1369,13 @@ tcl::namespace::eval punk::char { #testwidth is one of the main ones likely to be worthwhile excluding as querying the console via ansi takes time set existing_testwidth "" if {[tcl::dict::exists $charinfo $dec_char testwidth]} { - set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] + set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] } if {$existing_testwidth eq ""} { #no cached data - do expensive cursor-position test (Note this might not be 100% reliable - terminals lie e.g if ansi escape sequence has set to wide printing.) set char [format %c $dec_char] set chwidth [char_info_testwidth $char] - + tcl::dict::set returninfo testwidth $chwidth #cache it. todo - -verify flag to force recalc in case font/terminal changed in some way? tcl::dict::set charinfo $dec_char testwidth $chwidth @@ -1387,10 +1387,10 @@ tcl::namespace::eval punk::char { set char [format %c $dec_char] tcl::dict::set returninfo char $char } - memberof { + memberof { #memberof takes in the order of a few hundred microseconds if a simple scan of all ranges is taken - possibly worthwhile caching/optimising #note that memberof is not just unicode blocks - but scripts and other non-contiguous sets consisting of multiple ranges - some of which may include ranges of a single character. (e.g WGL4) - #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. + #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. #We could potentially populate it using a side-thread - but it seems reasonable to just cache result after first use here. #some efficiency could also be gained by pre-calculating the extents for each charset which isn't a simple unicode block. (and perhaps sorting by max char) set memberof [list] @@ -1435,7 +1435,7 @@ tcl::namespace::eval punk::char { set splen [tcl::dict::size $charset_extents_startpoints] set eplen [tcl::dict::size $charset_extents_endpoints] set s [lsearch -bisect -integer $skeys $dec] - set s_at_or_below [lrange $skeys 0 $s] + set s_at_or_below [lrange $skeys 0 $s] set e_of_s [list] foreach sk $s_at_or_below { lappend e_of_s {*}[tcl::dict::get $charset_extents_startpoints $sk] @@ -1472,16 +1472,16 @@ tcl::namespace::eval punk::char { set eps [list] } - + return [tcl::dict::create startpoints $splen endpoints $eplen midpoint [expr {floor($eplen/2)}] posn $e lhs_endpoints_to_check "[llength $reduced_endpoints]/[llength $e_of_s]=[llength $sps]ranges" rhs_startpoints_to_check "[llength $reduced_startpoints]/[llength $s_of_e]=[llength $eps]"] } #for just a few extra sets such as wgl4 and unicode blocks loaded - this gives e.g 5x + better performance than the simple search above, and up to twice as slow for tcl 8.6 #performance biased towards lower numbered characters (which is not too bad in the context of unicode) #todo - could be tuned to perform better at end by assuming a fairly even distribution of ranges - and so searching startpoint ranges first for items left of middle, endpoint ranges first for items right of middle - #review with scripts loaded and more defined ranges.. + #review with scripts loaded and more defined ranges.. #This algorithm supports arbitrary overlapping ranges and ranges with same start & endpoints #Should be much better than O(n) for n sets except for pathological case of member of all or nearly-all intervals ? - #review - compare with 'interval tree' algorithms. + #review - compare with 'interval tree' algorithms. proc char_info_dec_memberof {dec} { variable charset_extents_startpoints variable charset_extents_endpoints @@ -1563,7 +1563,7 @@ tcl::namespace::eval punk::char { set matchcount 0 foreach glob $and_globs { if {[tcl::string::match -nocase $glob $s] || [tcl::string::match -nocase $glob $d]} { - incr matchcount + incr matchcount } } if {$matchcount == [llength $and_globs]} { @@ -1595,12 +1595,12 @@ tcl::namespace::eval punk::char { } - #non-overlapping unicode blocks + #non-overlapping unicode blocks proc char_blocks {{name_or_glob *}} { variable charsets #todo - more efficient datastructures? if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { if {[tcl::dict::get $charsets $name_or_glob settype] eq "block"} { return [tcl::dict::create $name_or_glob [tcl::dict::get $charsets $name_or_glob]] @@ -1630,7 +1630,7 @@ tcl::namespace::eval punk::char { proc charset_names {{name_or_glob *}} { variable charsets if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { return [list $name_or_glob] } @@ -1641,7 +1641,7 @@ tcl::namespace::eval punk::char { } } else { if {$name_or_glob eq "*"} { - return [lsort [tcl::dict::keys $charsets]] + return [lsort [tcl::dict::keys $charsets]] } #tcl::dict::keys $dict doesn't have option for case insensitive searches return [lsort [lsearch -all -inline -nocase [tcl::dict::keys $charsets] $name_or_glob]] @@ -1655,7 +1655,7 @@ tcl::namespace::eval punk::char { variable charsets #dictionary sorting of the keys is slow! - we should obviously store it in sorted order instead of sorting entire list on retrieval - or just sort results #set sortedkeys [lsort -increasing -dictionary [tcl::dict::keys $charsets]] ;#NOTE must use -dictionary to use -sorted flag below - set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] + set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] if {$namesearch eq "*"} { return $sortedkeys } @@ -1664,7 +1664,7 @@ tcl::namespace::eval punk::char { return [lsearch -all -inline -nocase $sortedkeys $namesearch] ;#no point using -sorted flag when -all is used } else { #return [lsearch -sorted -inline -nocase $sortedkeys $namesearch] ;#no globs - bails out earlier if -sorted? - return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs + return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs } } proc charsets {{namesearch *}} { @@ -1738,7 +1738,7 @@ tcl::namespace::eval punk::char { set opt_ansi [tcl::dict::get $opts -ansi] set opt_lined [tcl::dict::get $opts -lined] # -- --- --- --- - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} if {$opt_ansi} { set a1 [a BLACK white bold] @@ -1768,7 +1768,7 @@ tcl::namespace::eval punk::char { } set i 1 append out \n $prefix $charsetname - append out \n + append out \n set marker_line $prefix set line $prefix @@ -1847,7 +1847,7 @@ tcl::namespace::eval punk::char { } else { set charset_dict [charset_dictget $charsetname] } - + set col_items_short [list] set col_items_desc [list] tcl::dict::for {k inf} $charset_dict { @@ -1873,7 +1873,7 @@ tcl::namespace::eval punk::char { return $out } - #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria + #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria proc charset_calibrate {namesearch args} { variable charsets variable charinfo @@ -1909,7 +1909,7 @@ tcl::namespace::eval punk::char { set twidth [tcl::dict::get $charinfo $dec testwidth] } if {$twidth eq ""} { - #puts -nonewline stdout "." ;#this + #puts -nonewline stdout "." ;#this set width [char_info_testwidth $ch] ;#based on console test rather than unicode props tcl::dict::set charinfo $dec testwidth $width } else { @@ -1925,10 +1925,10 @@ tcl::namespace::eval punk::char { #maint warning - also in overtype! #intended for single grapheme - but will work for multiple - #cannot contain ansi or newlines + #cannot contain ansi or newlines #(a cache of ansifreestring_width calls - as these are quite regex heavy) #review - effective memory leak on longrunning programs if never cleared - #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner + #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner proc grapheme_width_cached {ch {key ""}} { variable grapheme_widths #if key eq "*" - we won't be able to clear that cache individually. Perhaps that's ok @@ -1975,7 +1975,7 @@ tcl::namespace::eval punk::char { # - compare with wcswidth returning -1 for entire string containing such in python,perl proc wcswidth {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) #Tcl initial evaluation stack size is 2000 (? review) #REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!! set chunksize 2000 @@ -1984,14 +1984,14 @@ tcl::namespace::eval punk::char { set startidx 0 set endidx [expr {$startidx + $chunksize -1}] for {set i 0} {$i < $chunks_required} {incr i} { - set chunk [tcl::string::range $string $startidx $endidx] + set chunk [tcl::string::range $string $startidx $endidx] set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] foreach c $codes { if {$c <= 255 && !($c < 31 || $c == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$c < 917504 || $c > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $c] @@ -2023,7 +2023,7 @@ tcl::namespace::eval punk::char { set graphemes [list] while {$i < [tcl::string::length $string]} { set aftercluster [tk::endOfCluster $string $i] - lappend graphemes [string range $string $i $aftercluster-1] + lappend graphemes [string range $string $i $aftercluster-1] set i $aftercluster } return $graphemes @@ -2052,15 +2052,15 @@ tcl::namespace::eval punk::char { } } incr width $gw - + #if {[string first \u200d $g] >=0} { - # incr width 2 + # incr width 2 #} else { # #other joiners??? # incr width [wcswidth_unclustered $g] #} } else { - incr width [wcswidth_unclustered $g] + incr width [wcswidth_unclustered $g] } set i $aftercluster } @@ -2071,8 +2071,8 @@ tcl::namespace::eval punk::char { scan $char %c dec if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - return 1 + #todo - compare with python or other lang wcwidth + return 1 } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars return [textutil::wcswidth_char $dec] ;#note textutil::wcswidth_char takes a decimal codepoint! @@ -2086,8 +2086,8 @@ tcl::namespace::eval punk::char { scan $c %c dec if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $dec] ;#takes decimal codepoint @@ -2105,7 +2105,7 @@ tcl::namespace::eval punk::char { # - compare with wcswidth returning -1 for entire string containing such in python,perl proc wcswidth_unclustered {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) #Tcl initial evaluation stack size is 2000 (? review) #we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!. set chunksize 2000 @@ -2114,14 +2114,14 @@ tcl::namespace::eval punk::char { set startidx 0 set endidx [expr {$startidx + $chunksize -1}] for {set i 0} {$i < $chunks_required} {incr i} { - set chunk [tcl::string::range $string $startidx $endidx] + set chunk [tcl::string::range $string $startidx $endidx] set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] foreach dec $codes { if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $dec] @@ -2141,8 +2141,8 @@ tcl::namespace::eval punk::char { proc wcswidth0 {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ - #TODO + #..but - 'scan' is horrible for 400K+ + #TODO set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]] set width 0 foreach dec $codes { @@ -2150,9 +2150,9 @@ tcl::namespace::eval punk::char { if {$dec < 917504 || $dec > 917631} { if {$dec <= 255} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth + #todo - compare with python or other lang wcwidth if {!($dec < 31 || $dec == 127)} { - incr width + incr width } } else { #TODO - various other joiners and non-printing chars @@ -2179,11 +2179,11 @@ tcl::namespace::eval punk::char { #prerequisites - no ansi escapes - no newlines - utf8 encoding assumed #review - what about \r \t \b ? #NO processing of \b - already handled in ansi::printing_length which then calls this - #this version breaks string into sequences of ascii vs unicode + #this version breaks string into sequences of ascii vs unicode proc ansifreestring_width {text} { #caller responsible for calling ansistrip first if text may have ansi codes - and for ensuring no newlines #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2204,11 +2204,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] # -- --- --- --- --- --- --- @@ -2221,10 +2221,10 @@ tcl::namespace::eval punk::char { #for now - strip them out #ZWNJ \u200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u200b zero width space + #ZWSP \u200b zero width space #\uFFEFBOM/ ZWNBSP and others that should be zero width - #todo - work out proper way to mark/group zero width. + #todo - work out proper way to mark/group zero width. #set text [tcl::string::map [list \u200b "" \u200c "" \u200d "" \uFFEF ""] $text] set text [tcl::string::map [list \u200b "" \u200c "" \u200d ""] $text] @@ -2241,7 +2241,7 @@ tcl::namespace::eval punk::char { #c1 controls - first section of the Latin-1 Supplement block - all non-printable from a utf-8 perspective #some or all of these may have a visual representation in other encodings e.g cp855 seems to have 1 width for them all - #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here + #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here #they should also be unlikely to be present in an ansi-free string (as is a precondition for use of this function) set text [regsub -all {[\u0080-\u009f]+} $text ""] @@ -2262,7 +2262,7 @@ tcl::namespace::eval punk::char { #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] #tcl pre 2023-11 - braced high unicode regexes don't work #fixed in bug-4ed788c618 2023-11 - #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only #maintain unicode as sequences - todo - scan for grapheme clusters #set uc_sequences [punk::ansi::ta::_perlish_split "(?:\[\u0100-\U10FFFF\])+" $text] @@ -2291,7 +2291,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2312,11 +2312,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #review @@ -2325,7 +2325,7 @@ tcl::namespace::eval punk::char { #ZWNJ \u0200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u0200b zero width space + #ZWSP \u0200b zero width space #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2343,10 +2343,10 @@ tcl::namespace::eval punk::char { } #review - wcswidth should detect these - set re_ascii_fullwidth {[\uFF01-\uFF5e]} + set re_ascii_fullwidth {[\uFF01-\uFF5e]} set doublewidth_char_count 0 - set zerowidth_char_count 0 + set zerowidth_char_count 0 #split just to get the standalone character widths - and then scan for other combiners (?) #review #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] @@ -2354,7 +2354,7 @@ tcl::namespace::eval punk::char { #fixed in bug-4ed788c618 2023-11 #set uc_sequences [regexp -all -inline -indices {[\u0100-\U10FFFF]} $text] #set uc_sequences [regexp -all -inline -indices "\[\u0100-\U10FFFF\]" $text] ;#e.g for string: \U0001f9d1abc\U001f525ab returns {0 0} {4 4} - set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only foreach c $uc_chars { if {[regexp $re_ascii_fullwidth $c]} { incr doublewidth_char_count @@ -2364,12 +2364,12 @@ tcl::namespace::eval punk::char { # b)- textutil::wcswidth_char seems to be east-asian-width based - and not a reliable indicator of 'character cells taken by the character when printed to the terminal' despite this statement in tclllib docs. #(character width is a complex context-dependent topic) # c) by checking for a cached console testwidth first - we make this function less deterministic/repeatable depending on whether console tests have been run. - # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here + # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here #Despite all this - the mechanism is hoped to give best effort consistency for terminals - #further work needed for combining emojis etc - which can't be done in a per character loop + #further work needed for combining emojis etc - which can't be done in a per character loop #todo - see if wcswidth does any of this. It is very slow for strings that include mixed ascii/unicode - so perhaps we can use a perlish_split # to process sequences of unicode. - #- and the user has the option to test character sets first if terminal position reporting gives better results + #- and the user has the option to test character sets first if terminal position reporting gives better results if {[char_info_is_testwidth_cached $c]} { set width [char_info_testwidth_cached $c] } else { @@ -2378,7 +2378,7 @@ tcl::namespace::eval punk::char { set width [textutil::wcswidth_char [scan $c %c]] } if {$width == 0} { - incr zerowidth_char_count + incr zerowidth_char_count } elseif {$width == 2} { incr doublewidth_char_count } @@ -2395,7 +2395,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2416,11 +2416,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2437,7 +2437,7 @@ tcl::namespace::eval punk::char { return [tcl::string::length $text] } - #slow when ascii mixed with unicode (but why?) + #slow when ascii mixed with unicode (but why?) return [punk::char::wcswidth $text] } #This shouldn't be called on text containing ansi codes! @@ -2516,11 +2516,11 @@ tcl::namespace::eval punk::char { return [format $fmt {*}$declist] } - #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) + #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) proc combiner_split {text} { #split into odd numbered list (or zero) in a similar way to punk::ansi::ta::_perlish_split # - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set graphemes [list] if {[tcl::string::length $text] == 0} { return {} @@ -2528,12 +2528,12 @@ tcl::namespace::eval punk::char { set list [list] set start 0 set strlen [tcl::string::length $text] - #make sure our regexes aren't non-greedy - or we may not have exit condition for loop + #make sure our regexes aren't non-greedy - or we may not have exit condition for loop #review while {$start < $strlen && [regexp -start $start -indices -- {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} $text match]} { lassign $match matchStart matchEnd #puts "->start $start ->match $matchStart $matchEnd" - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] } lappend list [tcl::string::range $text $start end] @@ -2547,7 +2547,7 @@ tcl::namespace::eval punk::char { #This is difficult in Tcl without unicode property based Character Classes in the regex engine #review - this needs to be performant - it is used a lot by punk terminal/ansi features #todo - trie data structures for unicode? - #for now we can at least combine diacritics + #for now we can at least combine diacritics #should also handle the ZWJ (and the variation selectors? eg \uFE0F) character which should account for emoji clusters #Note - emoji cluster could be for example 11 code points/41 bytes (family emoji with skin tone modifiers for each member, 3 ZWJs) #This still leaves a whole class of clusters.. korean etc unhandled :/ @@ -2560,7 +2560,7 @@ tcl::namespace::eval punk::char { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] lappend graphemes [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2575,7 +2575,7 @@ tcl::namespace::eval punk::char { set combiner_decs [scan $combiners [tcl::string::repeat %c [tcl::string::length $combiners]]] lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] lappend graphemes {*}$pt_decs - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[scan [lindex $csplits end] [tcl::string::repeat %c [tcl::string::length [lindex $csplits end]]]] @@ -2592,7 +2592,7 @@ tcl::namespace::eval punk::char { lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] } lappend graphemes {*}$pt_decs - } + } return $graphemes } proc grapheme_split2 {text} { @@ -2601,7 +2601,7 @@ tcl::namespace::eval punk::char { foreach {pt combiners} [lrange $csplits 0 end-1] { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2645,10 +2645,10 @@ tcl::namespace::eval punk::char { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::char [tcl::namespace::eval punk::char { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/punk/config-0.1.tm b/src/bootsupport/modules/punk/config-0.1.tm index fbce0905..ac70e97b 100644 --- a/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/bootsupport/modules/punk/config-0.1.tm @@ -32,7 +32,7 @@ tcl::namespace::eval punk::config { if {$exename ne ""} { set exefolder [file dirname $exename] #default file logs to logs folder at same level as exe if writable, or empty string - set log_folder [file normalize $exefolder/../logs] + set log_folder [file normalize $exefolder/../logs] ;#~2ms #tcl::dict::set startup scriptlib $exefolder/scriptlib #tcl::dict::set startup apps $exefolder/../../punkapps diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index a8884746..a3f5d95c 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -777,13 +777,13 @@ namespace eval punk::console { set extension [lindex [split $waitvar($callid) -] 1] if {$extension eq ""} { puts "blank extension $waitvar($callid)" - puts "->[set $waitvar($callid]<-" + puts "->[set $waitvar($callid)]<-" } puts stderr "get_ansi_response_payload Extending timeout by $extension" after cancel $timeoutid($callid) set total_elapsed [expr {[clock millis] - $tslaunch($callid)}] set last_elapsed [expr {[clock millis] - $lastvwait}] - set remaining [expr {$remaining - $last_elapsed}] + set remaining [expr {$remaining - $last_elapsed}] if {$remaining < 0} {set remaining 0} set newtime [expr {$remaining + $extension}] set timeoutid($callid) [after $newtime [list set $waitvarname timedout]] @@ -797,7 +797,7 @@ namespace eval punk::console { } } } - #response handler automatically removes it's own chan event + #response handler automatically removes it's own chan event chan event $input readable {} ;#explicit remove anyway - review if {$waitvar($callid) ne "timedout"} { @@ -814,7 +814,7 @@ namespace eval punk::console { #it *might* be ok to restore entire state on an input channel #(it's not always on all channels - e.g stdout has -winsize which is read-only) #Safest to only restore what we think we've modified. - fconfigure $input -blocking [dict get $previous_input_state -blocking] + chan configure $input -blocking [dict get $previous_input_state -blocking] @@ -828,10 +828,10 @@ namespace eval punk::console { set prefixdata [string range $input_read {*}$prefix_indices] if {!$ignoreok && $prefixdata ne ""} { #puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (responsedata=[ansistring VIEW -lf 1 $responsedata])" - lappend input_chunks_waiting($input) $prefixdata + lappend input_chunks_waiting($input) $prefixdata } - } else { - #timedout - or eof? + } else { + #timedout - or eof? if {!$ignoreok} { puts stderr "get_ansi_response_payload callid:$callid regex match '$capturingendregex' to input_read '[ansistring VIEW -lf 1 -vt 1 $input_read]' not found" lappend input_chunks_waiting($input) $input_read @@ -872,11 +872,11 @@ namespace eval punk::console { flush stdout #concat and supply to existing handler in single text block - review - #Note will only + #Note will only set waitingdata [join $input_chunks_waiting($input) ""] set input_chunks_waiting($input) [list] #after idle [list after 0 [list {*}$existing_handler $waitingdata]] - after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review + after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review unset waitingdata } else { #! todo? for now, emit a clue as to what's happening. @@ -942,7 +942,7 @@ namespace eval punk::console { #review - reading 1 byte at a time and repeatedly running the small capturing/completion regex seems a little inefficient... but we don't have a way to peek or put back chars (?) #review (we do have the punk::console::input_chunks_waiting($chan) array to cooperatively put back data - but this won't work for user scripts not aware of this) #review - timeout - what if terminal doesn't put data on stdin? error vs stderr report vs empty results - #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? + #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? #e.g what happens to mouse-events while user code is executing? #we may still need this handler if such a loop doesn't exist. proc ansi_response_handler_regex {chan callid endregex} { @@ -973,14 +973,14 @@ namespace eval punk::console { chan event $chan readable {} set waits($callid) ok } else { - # 30ms 16ms? + # 30ms 16ms? set tsnow [clock millis] set total_elapsed [expr {[set tslaunch($callid)] - $tsnow}] set last_elapsed [expr {[set tsclock($callid)] - $tsnow}] if {[string length $chunks($callid)] % 10 == 0 || $last_elapsed > 16} { if {$total_elapsed > 3000} { #REVIEW - #too long since initial read handler launched.. + #too long since initial read handler launched.. #is other data being pumped into stdin? Eventloop starvation? Did we miss our codes? #For now we'll stop extending the timeout. after cancel $::punk::console::ansi_response_timeoutid($callid) @@ -1009,7 +1009,7 @@ namespace eval punk::console { chan event $chan readable {} # Something else puts stderr "ansi_response_handler_regex Situation shouldn't be possible. No error and no bytes read on channel $chan but not chan blocked or EOF" - set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof + set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof } } } ;#end namespace eval internal @@ -1034,7 +1034,7 @@ namespace eval punk::console { if {$ansi_wanted <= 0} { return } - #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here + #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here #tailcall punk::ansi::a+ {*}$args ::punk::ansi::a+ {*}$args } @@ -1092,7 +1092,7 @@ namespace eval punk::console { } default { set ansi_wanted 2 - } + } default { error "punk::console::ansi expected 0|1|on|off|true|false|yes|no|default" } @@ -1133,9 +1133,9 @@ namespace eval punk::console { } #test - find a better place to set terminal type - variable is_vt52 0 + variable is_vt52 0 proc vt52 {{onoff {}}} { - #todo - return to colour state beforehand?. support 0-15 vt52 colours? + #todo - return to colour state beforehand?. support 0-15 vt52 colours? #we shouldn't have to trun off colour to enter vt52 - we should make punk::console emit correct codes variable is_vt52 if {$onoff eq ""} { @@ -1146,7 +1146,7 @@ namespace eval punk::console { } if {$is_vt52} { if {!$onoff} { - puts -nonewline "\x1b<" + puts -nonewline "\x1b<" set is_vt52 0 colour on } @@ -1156,7 +1156,7 @@ namespace eval punk::console { set is_vt52 1 colour off } else { - puts -nonewline "\x1b<" + puts -nonewline "\x1b<" #emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ } } @@ -1222,10 +1222,10 @@ namespace eval punk::console { return $onoff } else { if {$onoff} { - {*}[auto_execok stty] echo + {*}[auto_execok stty] echo return 1 } else { - {*}[auto_execok stty] -echo + {*}[auto_execok stty] -echo return 0 } } @@ -1259,7 +1259,7 @@ namespace eval punk::console { set expected [dict get $opts -expected_ms] set capturingregex {(((.*)))$} ;#capture entire response same as response-payload - set ts_start [clock millis] + set ts_start [clock millis] set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] set ts_end [clock millis] puts stderr $response @@ -1273,7 +1273,7 @@ namespace eval punk::console { # -- --- --- --- --- --- --- #get_ansi_response functions - #review - can these functions sensibly be used on channels not attached to the local console? + #review - can these functions sensibly be used on channels not attached to the local console? #ie can we default to {stdin stdout} but allow other channel pairs? # -- --- --- --- --- --- --- proc get_cursor_pos {{inoutchannels {stdin stdout}}} { @@ -1284,13 +1284,13 @@ namespace eval punk::console { #e.g \033\[46;1R set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} ;#must capture prefix,entire-response,response-payload - set request "\033\[6n" + set request "\033\[6n" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] #some terminals fail to respond properly to \x1b\[6n but do respond to \x1b\[?6n and vice-versa :/ - #todo - what? + #todo - what? #often terminals that fail will just put the raw request code on stdin - we could detect that and then #try the other? - + return $payload } proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} { @@ -1333,7 +1333,7 @@ namespace eval punk::console { proc get_device_attributes {{inoutchannels {stdin stdout}}} { #DA1 variable last_da1_result - #first element in result is the terminal's architectural class 61,62,63,64.. ? + #first element in result is the terminal's architectural class 61,62,63,64.. ? #for vt100 we get things like: "ESC\[?1;0c" #for vt102 "ESC\[?6c" @@ -1368,7 +1368,7 @@ namespace eval punk::console { proc get_tabstops {{inoutchannels {stdin stdout}}} { #DECTABSR \x1b\[2\$w #response example " ^[P2$u9/17/25/33/41/49/57/65/73/81^[\ " (where ^[ is \x1b) - #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} + #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} #set capturingregex {(.*)(\x1bP2$u((?:[0-9]+)*(?:\/[0-9]+)*)\x1b\\)$} set capturingregex {(.*)(\x1bP2\$u(.*)\x1b\\)$} set request "\x1b\[2\$w" @@ -1387,7 +1387,7 @@ namespace eval punk::console { #either terminal failed to report - or none set. set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } #We don't support none - default to 8 return 8 @@ -1397,7 +1397,7 @@ namespace eval punk::console { if {[llength $tslist] == 1} { set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } return 8 } else { @@ -1441,7 +1441,7 @@ namespace eval punk::console { set cell_size "" set cell_size_fallback 10x20 - #todo - change -inoutchannels to -terminalobject with prebuilt default + #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::define { @id -id ::punk::console::cell_size @@ -1450,7 +1450,7 @@ namespace eval punk::console { newsize -default "" -help\ "character cell pixel dimensions WxH or omit to query cell size." - } + } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] @@ -1462,11 +1462,11 @@ namespace eval punk::console { if {$cell_size eq ""} { #not set - try to query terminal's overall dimensions set pixeldict [punk::console::get_xterm_pixels $inoutchannels] - lassign $pixeldict _w sw _h sh + lassign $pixeldict _w sw _h sh if {[string is integer -strict $sw] && [string is integer -strict $sh]} { lassign [punk::console::get_size] _cols columns _rows rows #review - is returned size in pixels always a multiple of rows and cols? - set w [expr {$sw / $columns}] + set w [expr {$sw / $columns}] set h [expr {$sh / $rows}] set cell_size ${w}x${h} return $cell_size @@ -1511,7 +1511,7 @@ namespace eval punk::console { return [expr {$payload in {Z K M}}] } - #todo - determine cursor on/off state before the call to restore properly. + #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { lassign $inoutchannels in out #we can't reliably use [chan names] for stdin,stdout. There could be stacked channels and they may have a names such as file22fb27fe810 @@ -1521,7 +1521,7 @@ namespace eval punk::console { } else { if {$is_eof} { error "punk::console::get_size eof on output channel $out ([info level 1])" - } + } } #we don't need to care about the input channel if chan configure on the output can give us the info. #short circuit ansi cursor movement method if chan configure supports the -winsize value @@ -1529,7 +1529,7 @@ namespace eval punk::console { if {[dict exists $outconf -winsize]} { #this mechanism is much faster than ansi cursor movements #REVIEW check if any x-platform anomalies with this method? - #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least + #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least lassign [dict get $outconf -winsize] cols lines if {[string is integer -strict $cols] && [string is integer -strict $lines]} { return [list columns $cols rows $lines] @@ -1542,7 +1542,7 @@ namespace eval punk::console { } else { if {$is_eof} { error "punk::console::get_size eof on input channel $in ([info level 1])" - } + } } #keep out of catch - no point in even trying a restore move if we can't get start position - just fail here. @@ -1565,7 +1565,7 @@ namespace eval punk::console { puts -nonewline $out [$func_coff][$movefunc 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols puts -nonewline $out [$movefunc $start_row $start_col][$func_con];flush stdout - set result [list columns $cols rows $lines] + set result [list columns $cols rows $lines] } errM]} { puts -nonewline $out [$movefunc $start_row $start_col] puts -nonewline $out [$func_con] @@ -1578,7 +1578,7 @@ namespace eval punk::console { #faster than get_size when it is using ansi mechanism - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore proc get_size_cursorrestore {{inoutchannels {stdin stdout}}} { lassign $inoutchannels in out - #we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly + #we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly set outconf [chan configure $out] if {[dict exists $outconf -winsize]} { lassign [dict get $outconf -winsize] cols lines @@ -1592,8 +1592,8 @@ namespace eval punk::console { #This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::cursor_save_dec][punk::ansi::move 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols - puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out - set result [list columns $cols rows $lines] + puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out + set result [list columns $cols rows $lines] } errM]} { puts -nonewline $out [punk::ansi::cursor_restore_dec] puts -nonewline $out [punk::ansi::cursor_on] @@ -1611,14 +1611,14 @@ namespace eval punk::console { set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[18t" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] - lassign [split $payload {;}] rows cols + lassign [split $payload {;}] rows cols return [list columns $cols rows $rows] } proc get_xterm_pixels {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[4;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[14t" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] - lassign [split $payload {;}] height width + lassign [split $payload {;}] height width return [list width $width height $height] } @@ -1629,7 +1629,7 @@ namespace eval punk::console { set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } - #Terminals generally default to LNM being reset (off) ie enter key sends a lone + #Terminals generally default to LNM being reset (off) ie enter key sends a lone #Terminals tested on windows either don't respond to this query, or respond with 0 (meaning mode not understood) #I presume from this that almost nobody is using LNM 1 (which sends both and ) proc get_mode_LNM {{inoutchannels {stdin stdout}}} { @@ -1689,7 +1689,7 @@ namespace eval punk::console { #terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate. #todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position. #todo - determine if these anomalies are independent of font - #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. + #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. #review - vertical movements (e.g /n /v will cause emit 0 to be ineffective - todo - disallow?) proc test_char_width {char_or_string {emit 0}} { #return 1 @@ -1797,7 +1797,7 @@ namespace eval punk::console { #don't set ansi_avaliable here - we want to be able to change things, retest etc. if {"windows" eq "$::tcl_platform(platform)"} { if {[package provide twapi] ne ""} { - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set existing_mode [twapi::GetConsoleMode $h_out] if {[expr {$existing_mode & 4}]} { #virtual terminal processing happens to be enabled - so it's supported @@ -1808,12 +1808,12 @@ namespace eval punk::console { #try temporarily setting it - if we get an error - ansi not supported if {[catch { - twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] } errM]} { return 0 } #restore - twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] return 1 } else { #todo - try a cursorpos query and read stdin to see if we got a response? @@ -1837,26 +1837,26 @@ namespace eval punk::console { set ansi_available [test_can_ansi] return $ansi_available } - return 1 + return 1 } - variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested + variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested #todo - flag to retest? (for consoles where grapheme cluster support can be disabled e.g via decmode 2027) proc grapheme_cluster_support {} { variable grapheme_cluster_support if {[dict size $grapheme_cluster_support]} { - return $grapheme_cluster_support + return $grapheme_cluster_support } if {[info exists ::env(TERM_PROGRAM)]} { #terminals known to support grapheme clusters, but unable to respond to decmode request 2027 #wezterm (on windows as at 2024-12 decmode 2027 doesn't work) - #REVIEW - what if terminal is remote wezterm? can/will this env variable + #REVIEW - what if terminal is remote wezterm? can/will this env variable # iterm and apple terminal also set TERM_PROGRAM if {[string tolower $::env(TERM_PROGRAM)] in [list wezterm]} { set is_available 1 - return [dict create available 1 mode set] + return [dict create available 1 mode set] } } #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) @@ -1884,7 +1884,7 @@ namespace eval punk::console { set m "BAD_RESPONSE" } } - return [dict create available $is_available mode $m] + return [dict create available $is_available mode $m] } @@ -1947,7 +1947,7 @@ namespace eval punk::console { set was_raw 1 } puts -nonewline stdout \033\[6n ;flush stdout - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 set info [read stdin 20] ;# after 1 if {[string first "R" $info] <=0} { @@ -2015,8 +2015,8 @@ namespace eval punk::console { (aka: cursor home) The sequence emitted will depend on the mode of the - terminal as stored in the consolehandle. - Directly setting the mode via raw escape sequences: + terminal as stored in the consolehandle. + Directly setting the mode via raw escape sequences: e.g unset_mode DECANM for vt52 or puts \x1b< to return to ANSI will not necessarily update the application of @@ -2036,7 +2036,7 @@ namespace eval punk::console { This sequence will generally not be understood by terminals that are not in vt52 mode even if higher modes are supported. - + } @values -min 2 -max 2 row -type integer -help\ @@ -2045,7 +2045,7 @@ namespace eval punk::console { "column number - starting at 1" }] proc move {row col} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { return [punk::ansi::move $row $col] } else { @@ -2053,7 +2053,7 @@ namespace eval punk::console { } } proc move_forward {n} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_forward $n] } else { @@ -2061,7 +2061,7 @@ namespace eval punk::console { } } proc move_back {n} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_back $n] } else { @@ -2075,7 +2075,7 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::move_down $n] } proc move_column {col} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_column $col] } else { @@ -2086,7 +2086,7 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::move_row $row] } proc move_emit {row col data args} { - upvar ::punk::console::is_v52 is_vt52 + upvar ::punk::console::is_v52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] } else { @@ -2226,7 +2226,7 @@ namespace eval punk::console { } proc titleset {windowtitle} { puts -nonewline stdout [punk::ansi::titleset $windowtitle] - } + } proc test_decaln {} { puts -nonewline stdout [punk::ansi::test_decaln] } @@ -2239,10 +2239,10 @@ namespace eval punk::console { if { $ansi_wanted <= 0} { punk::console::local::titleset $windowtitle } else { - ansi::titleset $windowtitle + ansi::titleset $windowtitle } } - #no known pure-ansi solution + #no known pure-ansi solution proc titleget {} { return [local::titleget] } @@ -2272,14 +2272,14 @@ namespace eval punk::console { #experimental proc rhs_prompt {col text} { package require textblock - lassign [textblock::size $text] _w tw _h th + lassign [textblock::size $text] _w tw _h th if {$th > 1} { #move up first.. need to know current line? } #set blanks [string repeat " " [expr {$col + $tw}]] #puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text #puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] - cursor_save_dec + cursor_save_dec #move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text #puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text puts -nonewline [punk::ansi::erase_eol][punk::ansi::move_column $col]$text @@ -2323,7 +2323,7 @@ namespace eval punk::console { 18 30 60 C0 60 30 18 00 00 00 7E 00 7E 00 00 00 60 30 18 0C 18 30 60 00 - 3C 66 0C 18 18 00 18 00 + 3C 66 0C 18 18 00 18 00 } #libungif extras append fontmap1 { @@ -2491,7 +2491,7 @@ namespace eval punk::console { #curses attr off reverse #a noreverse set reverse 0 - set output "" + set output "" set charno 0 foreach char [split $str {}] { binary scan $char c f @@ -2528,9 +2528,9 @@ namespace eval punk::console { } proc display {} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5] punk::console::move $orig_row $orig_col @@ -2539,9 +2539,9 @@ namespace eval punk::console { proc displaystr {str} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr $str 10 5] punk::console::move $orig_row $orig_col @@ -2571,13 +2571,13 @@ namespace eval punk::console { if {$dingbat_heavy_plus_width == 2} { set can_terminal_report_dingbat_width 1 } else { - puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." + puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." } set diacritic_width [punk::console::test_char_width a\u0300] if {$diacritic_width == 1} { set can_terminal_report_diacritic_width 1 } else { - puts stderr "punk::console warning: terminal unable to report diacritic width properly." + puts stderr "punk::console warning: terminal unable to report diacritic width properly." } if {$can_high_unicode && $can_regex_high_unicode && $can_terminal_report_dingbat_width && $can_terminal_report_diacritic_width} { @@ -2617,7 +2617,7 @@ namespace eval punk::console::check { } return $has_bug_legacysymbolwidth } - return 1 + return 1 } variable has_bug_zwsp -1 ;#undetermined proc has_bug_zwsp {} { diff --git a/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/bootsupport/modules/punk/fileline-0.1.0.tm index 1f02859b..ca222524 100644 --- a/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -9,7 +9,7 @@ # @@ Meta Begin # Application punk::fileline 0.1.0 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::fileline 0 0.1.0] #[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 --}] +#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] #[require punk::fileline] #[keywords module text parse file encoding BOM] #[description] @@ -33,7 +33,7 @@ #[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]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] @@ -42,13 +42,13 @@ # 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 +# 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]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. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -141,7 +141,7 @@ namespace eval punk::fileline::class { variable o_line_epoch variable o_payloadlist variable o_linemap - variable o_LF_C + variable o_LF_C variable o_CRLF_C @@ -158,7 +158,7 @@ namespace eval punk::fileline::class { #[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] - # fconfigure $fd -translation binary + # chan configure $fd -translation binary # set chunkdata [lb]read $fd[rb]] #or # set chunkdata [lb]fileutil::cat -translation binary[rb] @@ -191,7 +191,7 @@ namespace eval punk::fileline::class { set o_bom "" ;#review set o_chunk $datachunk - set o_line_epoch [list] + 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\ @@ -206,11 +206,11 @@ namespace eval punk::fileline::class { } } 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" @@ -261,7 +261,7 @@ namespace eval punk::fileline::class { #[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 + #[para] objName chunk 0 end return [string range $o_chunk $chunkstart $chunkend] } method chunklen {} { @@ -273,7 +273,7 @@ namespace eval punk::fileline::class { 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]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\ @@ -331,7 +331,7 @@ namespace eval punk::fileline::class { if {$opt_ansi} { set ::punk::fileline::ansi::enabled 1 } else { - set ::punk::fileline::ansi::enabled 0 + set ::punk::fileline::ansi::enabled 0 } if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { proc ::punk::fileline::a {args} { @@ -350,7 +350,7 @@ namespace eval punk::fileline::class { } proc ::punk::fileline::ansistrip {str} { if {$::punk::fileline::ansi::enabled} { - tailcall ::punk::fileline::ansi::ansistrip $str + tailcall ::punk::fileline::ansi::ansistrip $str } else { return $str } @@ -361,10 +361,10 @@ namespace eval punk::fileline::class { #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 + #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) " + 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] @@ -402,7 +402,7 @@ namespace eval punk::fileline::class { } else { set linebase $maxline } - set linebase ${sign}$linebase + set linebase ${sign}$linebase } elseif {[string match start* $tail]} { set endmath [string range $tail 5 end] if {[string length $endmath]} { @@ -489,7 +489,7 @@ namespace eval punk::fileline::class { 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 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] @@ -503,11 +503,11 @@ namespace eval punk::fileline::class { set e [dict get $lineinfo end] set boundarymarker "" - set displayidx "" + 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 [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] @@ -527,29 +527,29 @@ namespace eval punk::fileline::class { set linenum_display ${linenum_display},$idx } - set lhs_status $opt_cmark ;#default + 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 + set lhs_status $opt_tmark + set rhs_status $opt_tmark } elseif {"left" in $tside} { - set lhs_status $opt_tmark + set lhs_status $opt_tmark } elseif {"right" in $tside} { set rhs_status $opt_tmark } } else { - set line [my line $lineidx] + set line [my line $lineidx] } if {$displayidx ne ""} { - set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] + 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 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 *] @@ -586,12 +586,12 @@ namespace eval punk::fileline::class { 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]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 + 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] @@ -641,13 +641,13 @@ namespace eval punk::fileline::class { set opt_strategy [dict get $opts -strategy] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_start [dict get $opts -start] - set opt_start [expr {$opt_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 + set opt_end $max_line_index } #TODO if {$opt_end < $max_line_index} {error "-end less than max_line_index unimplemented"} @@ -705,7 +705,7 @@ namespace eval punk::fileline::class { #[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 + lassign [my numeric_linerange $lineindex 0] lineindex return [lindex $o_payloadlist $lineindex] } method linepayloads {startindex endindex} { @@ -722,17 +722,17 @@ namespace eval punk::fileline::class { #[list_begin itemized] #[item] le #[para] A string representing the type of line-ending: crlf|lf|none - #[item] linelen + #[item] linelen #[para] The number of characters/bytes in the whole line including line-ending if any - #[item] payloadlen + #[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 + #[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 + lassign [my numeric_linerange $lineindex 0] lineindex dict get $o_linemap $lineindex } method lineinfo {lineindex} { @@ -797,7 +797,7 @@ namespace eval punk::fileline::class { 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 + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set linestart -1 for {set i 0} {$i < [llength $o_payloadlist]} {incr i} { @@ -829,7 +829,7 @@ namespace eval punk::fileline::class { #[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 + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set defaults [dict create\ -show_truncated 0\ ] @@ -840,9 +840,9 @@ namespace eval punk::fileline::class { } } 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] @@ -878,8 +878,8 @@ namespace eval punk::fileline::class { 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 + dict set first truncated $truncated + dict set first truncatedleft $lhs } } ########################### @@ -908,7 +908,7 @@ namespace eval punk::fileline::class { if {$chunkend < [dict get $end_info end]} { #there is rhs truncation if {[dict get $first is_truncated]} { - dict set first truncatedside [list left right] + dict set first truncatedside [list left right] } else { dict set first is_truncated 1 dict set first truncatedside [list right] @@ -925,7 +925,7 @@ namespace eval punk::fileline::class { 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 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]} { @@ -971,13 +971,13 @@ namespace eval punk::fileline::class { set payload_and_le "${payload}${le_chars}" set split [expr {$chunkend - $line_start}] - set truncated [string range $payload_and_le 0 $split] + 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' + #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' } } @@ -991,7 +991,7 @@ namespace eval punk::fileline::class { ########################### #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. + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. return $infolist } @@ -1017,12 +1017,12 @@ namespace eval punk::fileline::class { #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 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. @@ -1035,7 +1035,7 @@ namespace eval punk::fileline::class { #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] } @@ -1061,13 +1061,13 @@ namespace eval punk::fileline::class { 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]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 + #[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 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] { @@ -1078,9 +1078,9 @@ namespace eval punk::fileline::class { set index $max } "*-*" { - #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions + #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions lassign [split $index -] A B - if {$A eq "end"} { + if {$A eq "end"} { set index [expr {$max - $B}] } else { set index [expr {$A - $B}] @@ -1088,7 +1088,7 @@ namespace eval punk::fileline::class { } "*+*" { lassign [split $index +] A B - if {$A eq "end"} { + 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}] @@ -1098,9 +1098,9 @@ namespace eval punk::fileline::class { } 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. + #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 + #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 } @@ -1109,13 +1109,13 @@ namespace eval punk::fileline::class { } } } - #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. + #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" + 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)" + error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" } return [list $startidx $endidx] } @@ -1136,7 +1136,7 @@ namespace eval punk::fileline::class { 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 lf_lines [split $normalised_data $o_LF_C] set idx 0 set lf_count 0 @@ -1145,14 +1145,14 @@ namespace eval punk::fileline::class { set i 0 set imax [expr {[llength $lf_lines]-1}] foreach lfln $lf_lines { - set crlf_parts [split $lfln $o_CRLF_C] + 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 + #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 @@ -1177,7 +1177,7 @@ namespace eval punk::fileline::class { 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 filedata_offset $linelen incr crlf_count incr idx } @@ -1200,7 +1200,7 @@ namespace eval punk::fileline::class { set le lf } - lappend o_payloadlist $lfpart + 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 @@ -1221,8 +1221,11 @@ namespace eval punk::fileline::class { #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 + #??? + #set } @@ -1248,19 +1251,19 @@ namespace eval punk::fileline { #*** !doctools #[subsection {Namespace punk::fileline}] - #[para] Core API functions for punk::fileline + #[para] Core API functions for punk::fileline #[list_begin definitions] - punk::args::define { + 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 + -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]] @@ -1272,7 +1275,7 @@ namespace eval punk::fileline { #[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]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. @@ -1285,10 +1288,10 @@ namespace eval punk::fileline { # -- --- --- --- if {$opt_file ne ""} { - set filename $opt_file - set fd [open $filename r] - fconfigure $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 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]} { @@ -1335,7 +1338,7 @@ namespace eval punk::fileline { 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) + #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 @@ -1360,7 +1363,7 @@ namespace eval punk::fileline { set bomenc "binary" ;# utf-8??? set startdata 3 } elseif {$maybe_bom eq "84319533"} { - if {![dict exists [punk::char::page_names_dict gb18030]]} { + 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 { @@ -1374,7 +1377,7 @@ namespace eval punk::fileline { 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!" + 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 @@ -1433,7 +1436,7 @@ namespace eval punk::fileline { } 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]] @@ -1443,7 +1446,7 @@ namespace eval punk::fileline { #!? if {$bomenc eq "binary"} { set datachunk [string range $rawchunk $startdata end] - set encoding_selected binary + set encoding_selected binary } else { set datachunk [encoding convertfrom utf-8 [string range $rawchunk $startdata end]] set encoding_selected utf-8 @@ -1485,7 +1488,7 @@ namespace eval punk::fileline { proc file_boundary_display {filename startbyte endbyte chunksize args} { set fd [open $filename r] ;#use default error if file not readable - fconfigure $fd -translation binary + chan configure $fd -translation binary set rawfiledata [read $fd] close $fd set textobj [class::textinfo new $rawfiledata] @@ -1510,7 +1513,7 @@ namespace eval punk::fileline::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::fileline::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] @@ -1532,12 +1535,12 @@ namespace eval punk::fileline::lib { #[para]e.g #[example_begin] # range_spans_chunk_boundaries 10 1750 512 - # is_span 1 boundaries {512 1024 1536} + # is_span 1 boundaries {512 1024 1536} #[example_end] - #[para]The -offset option + #[para]The -offset option #[example_begin] # range_spans_chunk_boundaries 10 1750 512 -offset 2 - # is_span 1 boundaries {514 1026 1538} + # 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-}]} { @@ -1576,12 +1579,12 @@ namespace eval punk::fileline::lib { namespace eval punk::fileline::system { #*** !doctools #[subsection {Namespace punk::fileline::system}] - #[para] Internal functions that are not part of the API + #[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 + return [binary format S* $elements] ;#format big endian } proc wordswap32 {data} { binary scan $data i* elements @@ -1622,7 +1625,7 @@ namespace eval punk::fileline::system { 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 @@ -1632,7 +1635,7 @@ namespace eval punk::fileline::system { } else { set overflow 0 } - set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] + set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] if {$overflow} { #we don't know how many overflowed.. set inrange [list] @@ -1668,7 +1671,7 @@ namespace eval punk::fileline::system { set opt_offset [dict get $opts -offset] # -- --- --- --- - set is_span 0 + set is_span 0 set smod [expr {$start % $chunksize}] if {$smod != 0} { set start [expr {$start + ($chunksize - $smod)}] @@ -1681,7 +1684,7 @@ namespace eval punk::fileline::system { 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 + incr btrack $chunksize set boff [expr {$btrack + $opt_offset}] } set bstart $btrack @@ -1689,9 +1692,9 @@ namespace eval punk::fileline::system { set bstart $start } for {set b $bstart} {[set boff [expr {$b + $opt_offset}]] <= $end} {incr b $chunksize} { - lappend boundaries $boff - } - + lappend boundaries $boff + } + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries offset $opt_offset] } @@ -1707,7 +1710,7 @@ 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 + #[para]See [package punk::ansi] for documentation #[list_begin definitions] variable enabled 1 #*** !doctools @@ -1720,11 +1723,11 @@ namespace eval punk::fileline::ansi { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::fileline [namespace eval punk::fileline { variable pkg punk::fileline variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/bootsupport/modules/punk/lib-0.1.1.tm index 09a73385..b6c6dd4a 100644 --- a/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application punk::lib 0.1.1 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::lib 0 0.1.1] #[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 --}] +#[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]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 # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -34,7 +34,7 @@ #[section Overview] #[para] overview of punk::lib #[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[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. @@ -108,7 +108,7 @@ tcl::namespace::eval punk::lib::ensemble { tcl::namespace::eval $extension [ list namespace ensemble create -command $routine -unknown [ list apply {{renamed ensemble routine args} { - list $renamed $routine + list $renamed $routine }} $renamed ] ] @@ -126,7 +126,7 @@ tcl::namespace::eval punk::lib::check { uplevel #0 $script set rep1 [tcl::unsupported::representation $::j] set script "" - set rep2 [tcl::unsupported::representation $::j] + set rep2 [tcl::unsupported::representation $::j] set nostring1 [string match "*no string" $rep1] set nostring2 [string match "*no string" $rep2] @@ -185,15 +185,15 @@ tcl::namespace::eval punk::lib::check { #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 + 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 + #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} { @@ -244,7 +244,7 @@ tcl::namespace::eval punk::lib::compat { 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 + #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 ""} { @@ -305,7 +305,7 @@ tcl::namespace::eval punk::lib::compat { 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 + #[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] @@ -356,7 +356,7 @@ tcl::namespace::eval punk::lib::compat { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -454,7 +454,7 @@ namespace eval punk::lib { #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) proc aliases {{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] + 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]]} { @@ -464,7 +464,7 @@ namespace eval punk::lib { set segcount [llength $segments] ;#only match number of segments matching current ns - set all_aliases [interp aliases {}] + set all_aliases [interp aliases {}] set matched [list] foreach a $all_aliases { #normalize with leading :: @@ -477,7 +477,7 @@ namespace eval punk::lib { set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] set acount [llength $asegs] #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {[expr {$acount - 1}] == $segcount} { + 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 @@ -485,7 +485,7 @@ namespace eval punk::lib { } } } - } + } #set matched_abs [lsearch -all -inline $all_aliases $glob] return $matched @@ -513,7 +513,7 @@ namespace eval punk::lib { set target [interp alias "" $aliasorglob] if {[llength $target]} { return $target - } + } if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { set aliaslist [punk::lib::aliases $aliasorglob] @@ -611,7 +611,7 @@ namespace eval punk::lib { } } 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. @@ -619,10 +619,10 @@ namespace eval punk::lib { #also 1b3 == 1b0003 if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "tm_version_required_canonical - invalid version specification" + 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 + #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'" @@ -634,7 +634,7 @@ namespace eval punk::lib { error "$errmsg '$versionspec'" } } else { - # min- or min-max + # 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 @@ -700,29 +700,29 @@ namespace eval punk::lib { #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 + #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) set a_index [lindex_resolve $l $a] set a_msg "" switch -- $a_index { -2 { - set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" + set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" } -3 { - set a_msg "1st supplied index $a is below the lower bound for the list (0)" + set a_msg "1st supplied index $a is below the lower bound for the list (0)" } } set z_index [lindex_resolve $l $z] set z_msg "" switch -- $z_index { -2 { - set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" - } + set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" + } -3 { - set z_msg "2nd supplied index $z is below the lower bound for the list (0)" + set z_msg "2nd supplied index $z is below the lower bound for the list (0)" } } - set errmsg "lswap cannot swap indices $a and $z" + set errmsg "lswap cannot swap indices $a and $z" if {$a_msg ne ""} { append errmsg \n $a_msg } @@ -732,7 +732,7 @@ namespace eval punk::lib { error $errmsg } set item2 [lindex $l $z] - lset l $z [lindex $l $a] + lset l $z [lindex $l $a] lset l $a $item2 return $l } @@ -760,20 +760,20 @@ namespace eval punk::lib { #proc swap_intvars2 {swapv1 swapv2} { # upvar $swapv1 _x $swapv2 _y # set _x [expr {$_x ^ $_y}] - # set _y [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 _x $_y # set _y $z #} #*** !doctools #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib + #[para] Core API functions for punk::lib #[list_begin definitions] if {[info commands lseq] ne ""} { @@ -785,7 +785,7 @@ namespace eval punk::lib { } } else { #lseq accepts basic expressions e.g 4-2 for both arguments - #e.g we can do lseq 0 [llength $list]-1 + #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] @@ -798,16 +798,16 @@ namespace eval punk::lib { incr from -1 return [lmap v [lrepeat $count 0] {incr from}] } - #slower methods. + #slower methods. #2) - #set i -1 + #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] + # lappend L [incr from] #} #return $L } elseif {$from > $to} { @@ -821,14 +821,14 @@ namespace eval punk::lib { } #2) - #set i -1 + #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] + # lappend L [incr from -1] #} #return $L } else { @@ -839,7 +839,7 @@ namespace eval punk::lib { proc lzip {args} { switch -- [llength $args] { - 0 {return {}} + 0 {return {}} 1 {return [lindex $args 0]} 2 {return [lzip2lists {*}$args]} 3 {return [lzip3lists {*}$args]} @@ -874,7 +874,7 @@ namespace eval punk::lib { } proc Build_lzipn {n} { - set arglist [list] + 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 " @@ -890,7 +890,7 @@ namespace eval punk::lib { puts "proc punk::lib::lzip${n}lists {$arglist} \{" puts "$body" puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body + proc ::punk::lib::lzip${n}lists $arglist $body } #fastest is to know the number of lists to be zipped @@ -923,7 +923,7 @@ namespace eval punk::lib { } #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - + # review - proc lzipn_alt args { #stackoverflow - courtesy glenn jackman (modified) foreach l $args { @@ -961,7 +961,7 @@ namespace eval punk::lib { 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 $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] ledit flatlist $s [expr {$s + $len - 1}] {*}$list incr s $numcolumns } @@ -977,7 +977,7 @@ namespace eval punk::lib { set numcolumns [::tcl::mathfunc::max {*}$lens] set flatlist [list] foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] } lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} } @@ -988,9 +988,9 @@ namespace eval punk::lib { set numcolumns [::tcl::mathfunc::max {*}$lens] set flatlist [list] foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] } - set zip_l {} + set zip_l {} set cols_remaining $numcolumns for {set c 0} {$c < $numcolumns} {incr c} { if {$cols_remaining == 1} { @@ -1006,14 +1006,14 @@ namespace eval punk::lib { #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] } - + namespace import ::punk::args::lib::tstr - + proc invoke command { @@ -1030,7 +1030,7 @@ namespace eval punk::lib { #}] #see https://wiki.tcl-lang.org/page/open - lassign [chan pipe] chanout chanin + lassign [chan pipe] chanout chanin lappend command 2>@$chanin set fh [open |$command] set stdout [read $fh] @@ -1045,7 +1045,7 @@ namespace eval punk::lib { } elseif {$sysmsg eq {CHILDSTATUS}} { return [list $stdout $stderr $exit] } else { - return -options $e $stderr + return -options $e $stderr } } return [list $stdout $stderr 0] @@ -1055,7 +1055,7 @@ namespace eval punk::lib { package require punk::args variable has_punk_ansi if {!$has_punk_ansi} { - set sep " = " + set sep " = " } else { #set sep " [a+ Web-seagreen]=[a] " set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " @@ -1081,18 +1081,18 @@ namespace eval punk::lib { 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) + 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. + 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 + 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 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 */%# + 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* + 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. @@ -1101,9 +1101,9 @@ namespace eval punk::lib { 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 segement 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. + 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::get_dict $argspec $args] @@ -1152,7 +1152,7 @@ namespace eval punk::lib { @cmd -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject -return -default "tailtohead" -choices {tailtohead sidebyside} - -channel -default none + -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 @@ -1181,7 +1181,7 @@ namespace eval punk::lib { }] $args] #for punk::lib - we want to reduce pkg dependencies. - # - so we won't even use the tcllib debug pkg here + # - 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 ""} { @@ -1222,18 +1222,18 @@ namespace eval punk::lib { 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 + #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: + #we currently return: #0 = v0 #1 = v1 #2 = v2 @@ -1245,7 +1245,7 @@ namespace eval punk::lib { #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}} { @@ -1263,7 +1263,7 @@ namespace eval punk::lib { set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] #puts stderr "showdict-->_split_patterns: $patterninfo" foreach v_idx $patterninfo { - lassign $v_idx v idx + 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 "!"} { @@ -1283,28 +1283,28 @@ namespace eval punk::lib { set keys [dict keys $dval] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p 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 } } %# { - 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 + dict set pattern_this_structure $p list lappend keyset # lappend keyset_structure list } ## { - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict lappend keyset [list ## query] - lappend keyset_structure dict + lappend keyset_structure dict } @* { #puts "showdict ---->@*<----" @@ -1323,19 +1323,19 @@ namespace eval punk::lib { #returns keys only lappend keyset [list $p query] lappend keyset_structure dict - dict set pattern_this_structure $p 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 + 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 + #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 @@ -1351,7 +1351,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @@* { #exact match key - review - should raise error to match punk pipe behaviour? @@ -1360,10 +1360,10 @@ namespace eval punk::lib { if {[dict exists $dval $k]} { set keys [dict keys [dict remove $dval $k]] lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] + lappend keyset_structure {*}[lrepeat [llength $keys] dict] } else { lappend keyset {*}[dict keys $dval] - lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] } } else { if {[dict exists $dval $k]} { @@ -1371,7 +1371,7 @@ namespace eval punk::lib { lappend keyset_structure dict } } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @k@* - @K@* { #TODO get_not @@ -1380,7 +1380,7 @@ namespace eval punk::lib { lappend keyset $k lappend keyset_structure dict } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*@*} { #return list of values @@ -1392,7 +1392,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*.@*} { #TODO get_not @@ -1400,61 +1400,61 @@ namespace eval punk::lib { set keys [dict keys $dval $k] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p 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'" + #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 + 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 + 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 + 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 + dict set pattern_this_structure $p dict } default { - set this_type $opt_roottype + set this_type $opt_roottype if {[string match @* $p]} { - #list mode - trim optional list specifier @ + #list mode - trim optional list specifier @ set p [string range $p 1 end] - dict set pattern_this_structure $p list - set this_type list + dict set pattern_this_structure $p list + set this_type list } elseif {[string match %* $p]} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string lappend keyset $p - lappend keyset_structure string + lappend keyset_structure string set this_type string } if {$this_type eq "list"} { - dict set pattern_this_structure $p 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] + lappend keyset_structure {*}[lrepeat [llength $keys] list] } else { lappend keyset $p - lappend keyset_structure list + lappend keyset_structure list } } elseif {[string match "?*-?*" $p]} { #could be either - don't change type @@ -1469,7 +1469,7 @@ namespace eval punk::lib { #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds if {${lower_resolve} == -2} { ##x - #lower bound is above upper list range + #lower bound is above upper list range #match with decreasing indices is still possible set lower [expr {[llength $dval]-1}] ;#set to max } elseif {$lower_resolve == -3} { @@ -1510,15 +1510,15 @@ namespace eval punk::lib { } else { lappend keyset [list @$p query] } - lappend keyset_structure list - } + lappend keyset_structure list + } } elseif {$this_type eq "string"} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string } elseif {$this_type eq "dict"} { #default equivalent to @\*@* - dict set pattern_this_structure $p dict + 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] + set keys [dict keys $dval $p] if {$get_not} { set keys [dict keys [dict remove $dval {*}$keys]] } @@ -1533,9 +1533,9 @@ namespace eval punk::lib { } } - # -- --- --- --- + # -- --- --- --- #check next pattern-segment for substructure type to use - # -- --- --- --- + # -- --- --- --- set substructure "" set pnext [lindex $segments 1] set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] @@ -1556,7 +1556,7 @@ namespace eval punk::lib { set substructure dict } # { - set substructure list + set substructure list } ## { set substructure dict @@ -1579,7 +1579,7 @@ namespace eval punk::lib { if {[string match @* $pnext]} { set substructure list } elseif {[string match %* $pnext]} { - set substructure string + set substructure string } else { #set substructure $opt_roottype #set substructure [dict get $pattern_this_structure $pattern_nest] @@ -1590,13 +1590,13 @@ namespace eval punk::lib { } } } else { - #e.g /@0,%str,.../ + #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 @@ -1629,7 +1629,7 @@ namespace eval punk::lib { } #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" } else { - puts stdout "unrecognised roottype: $opt_roottype" + puts stdout "unrecognised roottype: $opt_roottype" return $dval } @@ -1684,7 +1684,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] set subansibasekeys [lrange $opt_ansibase_keys 1 end] @@ -1692,7 +1692,7 @@ namespace eval punk::lib { #dict set nextopts -substructure $nextsub dict set nextopts -keytemplates $nextkeytemplates dict set nextopts -ansibase_keys $subansibasekeys - dict set nextopts -roottype $nextsub + dict set nextopts -roottype $nextsub dict set nextopts -channel none #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" @@ -1724,7 +1724,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] dict set nextopts -roottype $nextsub dict set nextopts -channel none @@ -1751,22 +1751,22 @@ namespace eval punk::lib { set thisval [ansistring VIEWSTYLE -lf 1 $dval] } elseif {[string match *lpad-* $key]} { set hidekey 1 - lassign [split $key -] _ extra + 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 + 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 + 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 + 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 { @@ -1789,14 +1789,14 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - #set nextopts [dict get $argd opts] + #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} { @@ -1838,7 +1838,7 @@ namespace eval punk::lib { } } "sidebyside" { - # TODO - fix + # 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?) @@ -1942,7 +1942,7 @@ namespace eval punk::lib { #also struct::set difference with critcl is faster proc setdiff {A B} { if {[llength $A] == 0} {return {}} - set d [dict create] + set d [dict create] foreach x $A {dict set d $x {}} foreach x $B {dict unset d $x} return [dict keys $d] @@ -1950,7 +1950,7 @@ namespace eval punk::lib { #bulk dict remove is slower than a foreach with dict unset #proc setdiff2 {fromlist removeitems} { # #if {[llength $fromlist] == 0} {return {}} - # set d [dict create] + # set d [dict create] # foreach x $fromlist { # dict set d $x {} # } @@ -1975,8 +1975,8 @@ namespace eval punk::lib { struct::set union $list {} } } else { - puts stderr "WARNING: struct::set union no longer dedupes!" - #we could also test a sequence of: struct::set add + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add } } @@ -2026,9 +2026,9 @@ namespace eval punk::lib { } 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] + } } [info vars] } ] # -- --- --- set cvars [tcl::dict::get $capture vars] @@ -2039,13 +2039,13 @@ namespace eval punk::lib { 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% }] @@ -2075,7 +2075,7 @@ namespace eval punk::lib { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -2110,7 +2110,7 @@ namespace eval punk::lib { # if {[tcl::dict::exists $dictValue {*}$keys]} { # return [tcl::dict::get $dictValue {*}$keys] # } else { - # return [lindex $args end] + # return [lindex $args end] # } #} if {[info commands ::tcl::dict::getdef] eq ""} { @@ -2123,7 +2123,7 @@ namespace eval punk::lib { } } } else { - #we pay a minor perf penalty for the wrap + #we pay a minor perf penalty for the wrap interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef } @@ -2131,13 +2131,13 @@ namespace eval punk::lib { #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" #} #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features @@ -2158,14 +2158,14 @@ namespace eval punk::lib { } } - # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side + # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side proc lindex_resolve {list index} { #*** !doctools #[call [fun lindex_resolve] [arg list] [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 #[para]Users may define procs which accept a list 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]Sometimes the actual integer index is desired. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]lindex_resolve will parse the index expression and return: #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) @@ -2183,13 +2183,13 @@ namespace eval punk::lib { #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { - #can match +i -i + #can match +i -i if {$index < 0} { return -3 } elseif {$index >= [llength $list]} { - return -2 + return -2 } else { - #integer may still have + sign - normalize with expr + #integer may still have + sign - normalize with expr return [expr {$index}] } } else { @@ -2223,7 +2223,7 @@ namespace eval punk::lib { set index [expr {([llength $list]-1) - $offset}] } if {$index < 0} { - return -3 + return -3 } else { return $index } @@ -2258,30 +2258,30 @@ namespace eval punk::lib { #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) #[para] returns -1 for out of range at either end, or a valid integer index #[para] 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 Tcl which has the builtin lseq command + #[para] This is only likely to be faster than average over lindex_resolve 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 + #[para] For pure integer indices the performance should be equivalent #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ - # - which + # - which #for {set i 0} {$i < [llength $list]} {incr i} { # lappend indices $i - #} + #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { - #can match +i -i + #can match +i -i #avoid even the lseq overhead when the index is simple if {$index < 0 || ($index >= [llength $list])} { #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. return -1 } else { - #integer may still have + sign - normalize with expr + #integer may still have + sign - normalize with expr return [expr {$index}] } - } + } if {[llength $list]} { set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. - #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) + #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) } else { set indices [list] } @@ -2290,7 +2290,7 @@ namespace eval punk::lib { #we have no way to determine if out of bounds is at lower vs upper end return -1 } else { - return $idx + return $idx } } proc lindex_get {list index} { @@ -2308,26 +2308,26 @@ namespace eval punk::lib { 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]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. + #[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] 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) + 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 + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for ) $ } $bytes @@ -2347,7 +2347,7 @@ namespace eval punk::lib { 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) + #[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 :-) ^ (?: @@ -2362,7 +2362,7 @@ namespace eval punk::lib { 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] 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. @@ -2377,9 +2377,9 @@ namespace eval punk::lib { [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) ) + } $rawbytes completeChars]} { - return $completeChars - } - return "" + return $completeChars + } + return "" } proc hex2dec {args} { #*** !doctools @@ -2403,10 +2403,10 @@ namespace eval punk::lib { 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} { @@ -2427,7 +2427,7 @@ namespace eval punk::lib { 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}}]] + 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]]] @@ -2460,7 +2460,7 @@ namespace eval punk::lib { 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] { @@ -2504,7 +2504,7 @@ namespace eval punk::lib { #[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 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 expr {log($x)/log($b)} } proc factors {x} { @@ -2513,14 +2513,14 @@ namespace eval punk::lib { #[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]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]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. + #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]* 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 @@ -2537,7 +2537,7 @@ namespace eval punk::lib { proc oddFactors {x} { #*** !doctools #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order + #[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] @@ -2572,7 +2572,7 @@ namespace eval punk::lib { set max [expr {sqrt($x)}] while {$j <= $max} { if {$x % $j == 0} { - return [expr {$x / $j}] + return [expr {$x / $j}] } incr j 2 } @@ -2597,14 +2597,14 @@ namespace eval punk::lib { if {$other % 2 == 0} { set god $j } else { - set god [expr {$x / $j}] + set god [expr {$x / $j}] #lowest j - so other side must be highest break } } incr j 2 } - return $god + return $god } proc greatestOddFactor {x} { #*** !doctools @@ -2660,7 +2660,7 @@ namespace eval punk::lib { #[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]] + return [factors [gcd $x $y]] } #experimental only - there are better/faster ways @@ -2701,8 +2701,8 @@ namespace eval punk::lib { 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. + #[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 } @@ -2720,7 +2720,7 @@ namespace eval punk::lib { proc substring_count {str substring} { #*** !doctools #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of 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} @@ -2736,7 +2736,7 @@ namespace eval punk::lib { #[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] + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] } proc askuser {question} { @@ -2744,7 +2744,7 @@ namespace eval punk::lib { #[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]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 @@ -2755,12 +2755,12 @@ namespace eval punk::lib { # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { # puts "Proceeding" # } else { - # puts "Cancelled by user" + # puts "Cancelled by user" # } #[example_end] puts stdout $question flush stdout - set stdin_state [fconfigure stdin] + set stdin_state [chan configure stdin] if {[catch { package require punk::console set console_raw [tsv::get console is_raw] @@ -2769,7 +2769,7 @@ namespace eval punk::lib { set console_raw 0 } try { - fconfigure stdin -blocking 1 + chan configure stdin -blocking 1 if {$console_raw} { punk::console::disableRaw set answer [gets stdin] @@ -2778,7 +2778,7 @@ namespace eval punk::lib { set answer [gets stdin] } } finally { - fconfigure stdin -blocking [tcl::dict::get $stdin_state -blocking] + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] } return $answer } @@ -2788,7 +2788,7 @@ namespace eval punk::lib { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { - lappend result "" + lappend result "" } else { lappend result $prefix[string trimright $line] } @@ -2827,7 +2827,7 @@ namespace eval punk::lib { } return [join $result \n] } - #A version of textutil::string::longestCommonPrefixList + #A version of textutil::string::longestCommonPrefixList proc longestCommonPrefix {items} { if {[llength $items] <= 1} { return [lindex $items 0] @@ -2844,9 +2844,9 @@ namespace eval punk::lib { } set n [string length $min] set prefix "" - set i -1 + set i -1 while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c + append prefix $c } return $prefix } @@ -2855,7 +2855,7 @@ namespace eval punk::lib { proc linesort {args} { #*** !doctools #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] - #[para]Sort lines in 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} { @@ -2871,7 +2871,7 @@ namespace eval punk::lib { #*** !doctools #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] #[para]This simply joines 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]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 @@ -2903,8 +2903,8 @@ namespace eval punk::lib { #*** !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 + #[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 @@ -2928,7 +2928,7 @@ namespace eval punk::lib { } #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 + #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) @@ -2938,14 +2938,14 @@ namespace eval punk::lib { } $args]] 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" + error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] set text [string map {\r\n \n} $text] ;#review - option? @@ -2957,7 +2957,7 @@ namespace eval punk::lib { -commandprefix ""\ -ansiresets auto\ -ansireplays 0\ - ] + ] foreach {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets - -ansireplays { @@ -2989,16 +2989,16 @@ namespace eval punk::lib { } if {"trimall" in $opt_block} { #no other block options make sense in combination with this - set opt_block [list "trimall"] + set opt_block [list "trimall"] } - #TODO + #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } - + # -- --- --- --- --- --- set opt_line [tcl::dict::get $opts -line] @@ -3056,7 +3056,7 @@ namespace eval punk::lib { } } elseif {$tl_left} { foreach ln $nlsplit { - lappend linelist [string trimleft $ln] + lappend linelist [string trimleft $ln] } } elseif {$tl_right} { foreach ln $nlsplit { @@ -3074,7 +3074,7 @@ namespace eval punk::lib { set last "-" } else { if {$last ne ""} { - lappend linelist "" + lappend linelist "" } set last "" } @@ -3090,11 +3090,11 @@ namespace eval punk::lib { set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { - break + break } else { set lastempty $idx } - incr idx + incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] @@ -3107,7 +3107,7 @@ namespace eval punk::lib { set i 0 foreach ln $revlinelist { if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] + set linelist [lreverse [lrange $revlinelist $i end]] break } incr i @@ -3131,13 +3131,13 @@ namespace eval punk::lib { } #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 + #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" + set RST "\x1b\[0m" } else { set RST "" } @@ -3157,7 +3157,7 @@ namespace eval punk::lib { } } else { - #INLINE punk::ansi::codetype::is_sgr_reset + #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 @@ -3176,30 +3176,30 @@ namespace eval punk::lib { #leave replaycodes as is for next line set nextreplay $replaycodes } else { - set tail $RST + 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 + 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 + 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 + #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 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 + set tail $RST #determine effective replay for line set codestack [list start] foreach code $ansisplits { @@ -3211,7 +3211,7 @@ namespace eval punk::lib { 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. + #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 @@ -3241,7 +3241,7 @@ namespace eval punk::lib { } } else { set nextreplay $replaycodes - } + } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay @@ -3260,7 +3260,7 @@ namespace eval punk::lib { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] - } + } set linelist $transformed } @@ -3271,14 +3271,14 @@ namespace eval punk::lib { 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 + #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" + error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] set text [string map {\r\n \n} $text] ;#review - option? @@ -3290,7 +3290,7 @@ namespace eval punk::lib { -commandprefix ""\ -ansiresets auto\ -ansireplays 0\ - ] + ] foreach {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets - -ansireplays { @@ -3322,16 +3322,16 @@ namespace eval punk::lib { } if {"trimall" in $opt_block} { #no other block options make sense in combination with this - set opt_block [list "trimall"] + set opt_block [list "trimall"] } - #TODO + #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } - + # -- --- --- --- --- --- set opt_line [tcl::dict::get $opts -line] @@ -3389,7 +3389,7 @@ namespace eval punk::lib { } } elseif {$tl_left} { foreach ln $nlsplit { - lappend linelist [string trimleft $ln] + lappend linelist [string trimleft $ln] } } elseif {$tl_right} { foreach ln $nlsplit { @@ -3407,7 +3407,7 @@ namespace eval punk::lib { set last "-" } else { if {$last ne ""} { - lappend linelist "" + lappend linelist "" } set last "" } @@ -3423,11 +3423,11 @@ namespace eval punk::lib { set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { - break + break } else { set lastempty $idx } - incr idx + incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] @@ -3440,7 +3440,7 @@ namespace eval punk::lib { set i 0 foreach ln $revlinelist { if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] + set linelist [lreverse [lrange $revlinelist $i end]] break } incr i @@ -3464,13 +3464,13 @@ namespace eval punk::lib { } #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 + #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" + set RST "\x1b\[0m" } else { set RST "" } @@ -3490,7 +3490,7 @@ namespace eval punk::lib { } } else { - #INLINE punk::ansi::codetype::is_sgr_reset + #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 @@ -3507,28 +3507,28 @@ namespace eval punk::lib { #leave replaycodes as is for next line set nextreplay $replaycodes } else { - set tail $RST + 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 + 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 + 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 + #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 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 + set tail $RST #determine effective replay for line set codestack [list start] foreach {pt code} $ansisplits { @@ -3540,7 +3540,7 @@ namespace eval punk::lib { 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. + #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 @@ -3570,7 +3570,7 @@ namespace eval punk::lib { } } else { set nextreplay $replaycodes - } + } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay @@ -3589,7 +3589,7 @@ namespace eval punk::lib { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] - } + } set linelist $transformed } @@ -3600,17 +3600,17 @@ namespace eval punk::lib { 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 + #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 + 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 + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance set i 0 - set times {} + set times {} if {$iters < 2} {set iters 2} for {set i 0} {$i < $iters} {incr i} { @@ -3629,8 +3629,8 @@ namespace eval punk::lib { set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] } - set sigma [expr {int(sqrt($s2))}] - set average [expr int($average)] + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] return "$average +/- $sigma microseconds per iteration" } @@ -3673,9 +3673,9 @@ namespace eval punk::lib { default { return [list $dec $c] } - } + } + - } @@ -3686,7 +3686,7 @@ namespace eval punk::lib { 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. + #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" @@ -3701,7 +3701,7 @@ namespace eval punk::lib { set data [tcl::unsupported::disassemble method $obj $method] } } else { - error "show_jump_tables expected a procname or a class/object and method" + error "show_jump_tables expected a procname or a class/object and method" } set result "" set in_jt 0 @@ -3786,10 +3786,10 @@ namespace eval punk::lib { } #todo - get configured user defaults if {$delim eq ""} { - set delim $default_delim + set delim $default_delim } if {$groupsize eq ""} { - set groupsize $default_groupsize + set groupsize $default_groupsize } lappend results [delimit_number $number $delim $groupsize] @@ -3820,10 +3820,10 @@ namespace eval punk::lib { # 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 [expr $point + 1] end]; + set PostDecimal [string range $number $point+1 end]; set PostDecimalP 1; } else { - set point [expr [string length $number] + 1] + set point [expr {[string length $number] + 1}] set PostDecimal ""; set PostDecimalP 0; } @@ -3834,16 +3834,16 @@ namespace eval punk::lib { incr ind; } set FirstNonSpace $ind; - set LastSpace [expr $FirstNonSpace - 1]; + 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 [expr $point -1]]; + 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 Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; set DelimitedMain ""; #First we deal with the extra stuff. @@ -3851,7 +3851,7 @@ namespace eval punk::lib { append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; } set FirstInGroup $Phase; - set LastInGroup [expr $FirstInGroup + $GroupSize -1]; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; while {$LastInGroup < $Length} { if {$FirstInGroup > 0} { append DelimitedMain $delim; @@ -3869,7 +3869,7 @@ namespace eval punk::lib { } } - + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib ---}] @@ -3884,10 +3884,10 @@ tcl::namespace::eval punk::lib::flatgrid { #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 {$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]] @@ -3895,7 +3895,7 @@ tcl::namespace::eval punk::lib::flatgrid { set rows [list] set i 1 foreach s [lrange $splits 0 end-1] { - lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] incr i } return $rows @@ -3958,16 +3958,20 @@ tcl::namespace::eval punk::lib::flatgrid { } } +tcl::namespace::eval punk::lib::test { + +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #todo - way to generate 'internal' docs separately? #*** !doctools #[section Internal] tcl::namespace::eval punk::lib::system { - #*** !doctools + #*** !doctools #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #[list_begin definitions] @@ -3975,7 +3979,7 @@ tcl::namespace::eval punk::lib::system { ##*** !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) + #[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} { @@ -3988,9 +3992,9 @@ tcl::namespace::eval punk::lib::system { return [list number $most numfactors $mostcount] } proc factorCountBelow_punk {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[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! @@ -4001,9 +4005,9 @@ tcl::namespace::eval punk::lib::system { return $tally } proc factorCountBelow_numtheory {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[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) @@ -4070,7 +4074,7 @@ tcl::namespace::eval punk::lib::system { lappend innerpartials "" } else { if {[lindex $waiting end] eq {"}} { - #this quote is endquote + #this quote is endquote set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { @@ -4078,7 +4082,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting {"} lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4089,7 +4093,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\]" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4098,7 +4102,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\}" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4109,13 +4113,13 @@ tcl::namespace::eval punk::lib::system { set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } } } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } set escaped 0 @@ -4192,20 +4196,20 @@ tcl::namespace::eval punk::lib::system { } #get info about punk nestindex key ie type: list,dict,undetermined - # pdict devel + # pdict devel proc nestindex_info {args} { set argd [punk::args::get_dict { -parent -default "" - nestindex + nestindex } $args] 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 + 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 @@ -4221,11 +4225,11 @@ namespace eval ::punk::args::register { lappend ::punk::args::register::NAMESPACES ::punk::lib } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::lib [tcl::namespace::eval punk::lib { variable pkg punk::lib variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/bootsupport/modules/punk/mix/base-0.1.tm index c5ec5551..69f2f5cb 100644 --- a/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -18,7 +18,7 @@ namespace eval punk::mix::base { set extension "" } #--------- - + uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] } proc _cli {args} { @@ -69,7 +69,7 @@ namespace eval punk::mix::base { } #puts stderr "arglen:[llength $args]" #puts stdout "_unknown '$ns' '$args'" - + set d_commands [get_commands -extension $extension] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] @@ -98,11 +98,11 @@ namespace eval punk::mix::base { } tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns } else { - if {[regexp {.*[*?].*} $subcommand]} { + if {[regexp {.*[*?].*} $subcommand]} { set d_commands [get_commands -extension $from_ns] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] set matched_commands [lsearch -all -inline $all_commands $subcommand] - set commands "" + set commands "" foreach m $matched_commands { append commands $m \n } @@ -113,12 +113,12 @@ namespace eval punk::mix::base { } proc _split_args {arglist} { #don't assume arglist is fully paired. - set posn [lsearch $arglist -extension] + set posn [lsearch $arglist -extension] set opts [list] if {$posn >= 0} { if {$posn+2 <= [llength $arglist]} { set opts [list -extension [lindex $arglist $posn+1]] - set argsremaining [lreplace $arglist $posn $posn+1] + set argsremaining [lreplace $arglist $posn $posn+1] } else { #no value supplied to -extension error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." @@ -151,7 +151,7 @@ namespace eval punk::mix::base { if {![string length $extension]} { set extension [namespace qualifiers [lindex [info level -1] 0]] } - + set maincommands [list] #extension may still be blank e.g if punk::mix::base::get_commands called directly if {[string length $extension]} { @@ -164,7 +164,7 @@ namespace eval punk::mix::base { } foreach c $nscommands { set cmd [namespace tail $c] - lappend maincommands $cmd + lappend maincommands $cmd } set maincommands [lsort $maincommands] } @@ -190,29 +190,29 @@ namespace eval punk::mix::base { set basecommands [lsort $basecommands] - return [list main $maincommands base $basecommands] + return [list main $maincommands base $basecommands] } proc help {args} { #' **%ensemblecommand% help** *args* - #' + #' #' Help for ensemble commands in the command line interface - #' - #' + #' + #' #' Arguments: - #' + #' #' * args - first word of args is the helptopic requested - usually a command name #' - calling help with no arguments will list available commands - #' + #' #' Returns: help text (text) - #' + #' #' Examples: - #' + #' #' ``` #' %ensemblecommand% help #' ``` - #' - #' - + #' + #' + #extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| # >} inspect -label a {| @@ -220,7 +220,7 @@ namespace eval punk::mix::base { # pipecase ,0/1/#= $switchargs {| # e/0 # >} .=>. {set e} - # pipecase /1,1/1/#= $switchargs + # pipecase /1,1/1/#= $switchargs #} |@@ok/result> " opts $opts] } @@ -620,7 +620,7 @@ namespace eval punk::mix::base { if {$path eq $base} { #attempting to cksum at root/volume level of a filesystem.. extra work - #This needs fixing for general use.. not necessarily just for project repos + #This needs fixing for general use.. not necessarily just for project repos puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" return [list error unsupported_path opts $opts] } @@ -671,8 +671,8 @@ namespace eval punk::mix::base { set archivename $tmplocation/[punk::mix::util::tmpfile].tar cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) - - #temp emission to stdout.. todo - repl telemetry channel + + #temp emission to stdout.. todo - repl telemetry channel puts stdout "cksum_path: creating temporary tar archive for $path" puts -nonewline stdout " at: $archivename ..." set tsstart [clock millis] @@ -692,7 +692,7 @@ namespace eval punk::mix::base { set ms [expr {$tsend - $tsstart}] puts stdout " tar::create done ($ms ms)" puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing" - } + } if {$ftype eq "file"} { set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)" @@ -718,7 +718,7 @@ namespace eval punk::mix::base { set cksum [{*}$cksum_command $path] } } else { - error "cksum_path unsupported $opts for path type [file type $path]" + error "cksum_path unsupported $opts for path type [file type $path]" } } set result [dict create] @@ -733,7 +733,7 @@ namespace eval punk::mix::base { #base can be empty string in which case paths must be absolute #expect dict_path_cksum to be a dict keyed on relpath where each value is a dictionary with keys cksum and opts # ie subdict for can be created from output of cksum_path (for already known values not requiring filling) - # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) + # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { if {$base eq ""} { set error_paths [list] @@ -775,7 +775,7 @@ namespace eval punk::mix::base { } } if {$base ne ""} { - set fullpath [file join $base $path] + set fullpath [file join $base $path] } else { set fullpath $path } @@ -820,7 +820,7 @@ namespace eval punk::mix::base { #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will honour valid-looking prefilled cksum values (ie will pass them through) #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) proc get_relativecksum_from_base {base specifiedpath args} { - if {$base ne ""} { + if {$base ne ""} { #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix if {[file pathtype $specifiedpath] eq "relative"} { @@ -846,9 +846,9 @@ namespace eval punk::mix::base { #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" } - set targetpath $specifiedpath + set targetpath $specifiedpath set storedpath [punk::path::relative $base $specifiedpath] - + } } else { if {[file type $specifiedpath] eq "relative"} { @@ -863,7 +863,7 @@ namespace eval punk::mix::base { # #NOTE: specifiedpath can be a relative path (to cwd) when base is empty - #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc + #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc #possibly also: base: somewhere targetpath: ../elsewhere/etc # #todo - write tests @@ -881,7 +881,7 @@ namespace eval punk::mix::base { set ckopts [cksum_filter_opts {*}$args] set ckinfo [cksum_path $targetpath {*}$ckopts] - + set keyvals $args ;# REVIEW dict set keyvals cksum [dict get $ckinfo cksum] #dict set keyvals cksum_all_opts [dict get $ckinfo opts] @@ -891,7 +891,7 @@ namespace eval punk::mix::base { } #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop - #storedpath is relative if possible + #storedpath is relative if possible return [dict create $storedpath $keyvals] } @@ -910,7 +910,7 @@ namespace eval punk::mix::base { dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] } - #buildruntime.exe obsolete.. + #buildruntime.exe obsolete.. set fullpath_buildruntime $buildfolder/buildruntime.exe set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] @@ -944,7 +944,7 @@ namespace eval punk::mix::base { } proc get_all_build_cksums_stored {path} { set buildfolder [get_build_workdir $path] - + set vfscontainer [file dirname $buildfolder] set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] set dict_cksums [dict create] @@ -963,7 +963,7 @@ namespace eval punk::mix::base { } set vfscontainer [file dirname $vfsfolder] set buildfolder $vfscontainer/_build - set dict_vfs [get_vfs_build_cksums $vfsfolder] + set dict_vfs [get_vfs_build_cksums $vfsfolder] set data "" dict for {path cksum} $dict_vfs { append data "$path $cksum" \n diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 5d38fad8..3cf64b33 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::mix::cli 0.3.1 +# Application punk::mix::cli 0.3.1 # Meta platform tcl # Meta license # @@ Meta End @@ -19,7 +19,7 @@ ##e.g package require frobz package require punk::repo package require punk::ansi -package require punkcheck ;#checksum and/or timestamp records +package require punkcheck ;#checksum and/or timestamp records @@ -33,7 +33,7 @@ namespace eval punk::mix::cli { namespace ensemble create variable initialised 0 - #lazy _init - called by punk::mix::base::_cli when ensemble used + #lazy _init - called by punk::mix::base::_cli when ensemble used proc _init {args} { variable initialised if {$initialised} { @@ -52,7 +52,7 @@ namespace eval punk::mix::cli { catch { package require punk::mix::commandset::project punk::overlay::import_commandset project . ::punk::mix::commandset::project - punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection } if {[catch { package require punk::mix::commandset::layout @@ -91,12 +91,12 @@ namespace eval punk::mix::cli { } proc stat {{workingdir ""} args} { - dict set args -v 0 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 0 + punk::mix::cli::lib::get_status $workingdir {*}$args } proc status {{workingdir ""} args} { - dict set args -v 1 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 1 + punk::mix::cli::lib::get_status $workingdir {*}$args } @@ -128,13 +128,13 @@ namespace eval punk::mix::cli { set project_base [punk::repo::find_candidate] set sourcefolder $project_base/src puts stderr "WARNING - project not under git or fossil control" - puts stderr "Using base folder $project_base" + puts stderr "Using base folder $project_base" } else { set sourcefolder $startdir } } - #review - why can't we be anywhere in the project? + #review - why can't we be anywhere in the project? #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { puts stderr "dev make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" @@ -157,7 +157,7 @@ namespace eval punk::mix::cli { if {![string length $project_base]} { puts stderr "WARNING no git or fossil repository detected." - puts stderr "Using base folder $startdir" + puts stderr "Using base folder $startdir" set project_base $startdir } @@ -178,7 +178,7 @@ namespace eval punk::mix::cli { } } #cd $sourcefolder - + #use run so that stdout visible as it goes if {![catch {run --timeout=55000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { #todo - notify if exit because of timeout! @@ -198,7 +198,7 @@ namespace eval punk::mix::cli { puts stdout "OK make finished " return true } - } + } proc Kettle {args} { tailcall lib::kettle_call lib {*}$args @@ -241,7 +241,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- if {$opt_strict} { if {[regexp {[A-Z]} $modulename]} { - error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" + error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" } } @@ -272,7 +272,7 @@ namespace eval punk::mix::cli { } elseif {[regexp {[A-Z]} $modulename]} { set msg "module names containing uppercase are not recommended (see tip 590).\n" append msg "Please retype the module name '$modulename' to proceed.\n" - append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" append msg "Retype it all in lowercase to use recommended naming" set answer [util::askuser $msg] if {[regexp {[A-Z]} $answer]} { @@ -285,11 +285,11 @@ namespace eval punk::mix::cli { } set modulename $answer } else { - #user has resupplied modulename all as lowercase + #user has resupplied modulename all as lowercase if {$answer eq [string tolower $modulename]} { set finalised 1 } else { - #.. but it doesn't match original - require rerun + #.. but it doesn't match original - require rerun } set modulename $answer } @@ -332,7 +332,7 @@ namespace eval punk::mix::cli { if {[string first "::" $projectname] >= 0} { error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" } - return $projectname + return $projectname } proc validate_name_not_empty_or_spaced {name args} { set opts [list\ @@ -394,7 +394,7 @@ namespace eval punk::mix::cli { set result "" if {$workingdir ne ""} { if {[file pathtype $workingdir] ne "absolute"} { - set workingdir [file normalize $workingdir] + set workingdir [file normalize $workingdir] } set active_dir $workingdir } else { @@ -403,10 +403,10 @@ namespace eval punk::mix::cli { set defaults [dict create\ -v 1\ ] - set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- set opt_v [dict get $opts -v] - # -- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- set repopaths [punk::repo::find_repos [pwd]] @@ -417,7 +417,7 @@ namespace eval punk::mix::cli { append result [dict get $repopaths warnings] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { - #review - multiple process launches to fossil a bit slow on windows.. + #review - multiple process launches to fossil a bit slow on windows.. #could we query global db in one go instead? # set fossil_prog [auto_execok fossil] @@ -444,14 +444,14 @@ namespace eval punk::mix::cli { if {"project" in $repotypes} { #punk project if {![catch {package require textblock; package require patternpunk}]} { - set result [textblock::join -- [>punk . logo] " " $result] + set result [textblock::join -- [>punk . logo] " " $result] append result \n - } - } + } + } set timeline [exec fossil timeline -n 5 -t ci] set timeline [string map {\r\n \n} $timeline] - append result $timeline + append result $timeline if {$opt_v} { set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] append result \n [punk::repo::workingdir_state_summary $repostate] @@ -516,7 +516,7 @@ namespace eval punk::mix::cli { puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" exit 2 } - set srcdirname [file tail $srcdir] + set srcdirname [file tail $srcdir] set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir if {[llength $subdirlist] == 0} { @@ -578,7 +578,7 @@ namespace eval punk::mix::cli { } set fileparts [split [file rootname $modpath] -] #set tmfile_versionsegment [lindex $fileparts end] - lassign [split_modulename_version $modpath] basename tmfile_versionsegment + lassign [split_modulename_version $modpath] basename tmfile_versionsegment if {$tmfile_versionsegment eq ""} { #split_modulename_version version part will be empty if not valid tcl version #last segment doesn't look even slightly versiony - fail. @@ -634,8 +634,8 @@ namespace eval punk::mix::cli { set modulefile $buildfolder/$basename-$module_build_version.tm - $build_event targetset_init INSTALL $podtree_copy - $build_event targetset_addsource $current_source_dir/$modpath + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath if {$tmfile_versionsegment eq $magicversion} { $build_event targetset_addsource $versionfile } @@ -667,7 +667,7 @@ namespace eval punk::mix::cli { if {[file exists $tmfile]} { set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm file rename $tmfile $newname - set tmfile $newname + set tmfile $newname } set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd set data [string map [list $magicversion $module_build_version] $data] @@ -745,12 +745,12 @@ namespace eval punk::mix::cli { $build_event targetset_end SKIPPED } $build_event destroy - $build_installer destroy + $build_installer destroy - #JMN - review + #JMN - review if {!$had_error} { - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm - $event targetset_addsource $modulefile + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile if {\ [llength [dict get [$event targetset_source_changes] changed]]\ || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ @@ -759,12 +759,12 @@ namespace eval punk::mix::cli { $event targetset_started # -- --- --- --- --- --- if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} - lappend module_list $modulefile + lappend module_list $modulefile if {[catch { file copy -force $modulefile $target_module_dir } errMsg]} { puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir" - $event targetset_end FAILED -note "could not copy $modulefile" + $event targetset_end FAILED -note "could not copy $modulefile" } else { puts stderr "Copied zip modpod module $modulefile to $target_module_dir" # -- --- --- --- --- --- @@ -782,7 +782,7 @@ namespace eval punk::mix::cli { } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar } file { set m $modpath @@ -808,12 +808,12 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #rebuild the .tm from the #tarjar + #rebuild the .tm from the #tarjar if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - + } else { - + } #REVIEW - should be in same structure/depth as $target_module_dir in _build? @@ -824,22 +824,22 @@ namespace eval punk::mix::cli { set tmfile $buildfolder/$basename-$module_build_version.tm file delete -force $buildfolder/#tarjar-$basename-$module_build_version file delete -force $tmfile - - + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version # #bsdtar doesn't seem to work.. or I haven't worked out the right options? #exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version package require tar - tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version if {![file exists $tmfile]} { puts stdout "ERROR: failed to build tarjar file $tmfile" exit 4 } #copy the file? - #set target $target_module_dir/$basename-$module_build_version.tm + #set target $target_module_dir/$basename-$module_build_version.tm #file copy -force $tmfile $target - + lappend module_list $tmfile } else { #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. @@ -851,7 +851,7 @@ namespace eval punk::mix::cli { # #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm $event targetset_addsource $versionfile $event targetset_addsource $current_source_dir/$m @@ -902,7 +902,7 @@ namespace eval punk::mix::cli { #------------------------------ } - + continue } ##------------------------------ @@ -917,7 +917,7 @@ namespace eval punk::mix::cli { #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] #set changed_list [dict get $changed_unchanged changed] #---------- - $event targetset_init INSTALL $target_module_dir/$m + $event targetset_init INSTALL $target_module_dir/$m $event targetset_addsource $current_source_dir/$m if {\ [llength [dict get [$event targetset_source_changes] changed]]\ @@ -981,7 +981,7 @@ namespace eval punk::mix::cli { } if {$CALLDEPTH == 0} { $event destroy - $installer destroy + $installer destroy } return $module_list } @@ -1017,7 +1017,7 @@ namespace eval punk::mix::cli { } dict set kettle_reset_args $p $arglist } - } + } } #call kettle_reinit to ensure recipes point to current project @@ -1095,14 +1095,14 @@ namespace eval punk::mix::cli { kettle_reinit } } - set first [lindex $args 0] + set first [lindex $args 0] if {[string match @* $first]} { error "deck kettle doesn't support special operations - try calling tclsh kettle directly" } if {$first eq "-f"} { set args [lassign $args __ path] } else { - set path $startdir/build.tcl + set path $startdir/build.tcl } set opts [list] @@ -1123,9 +1123,9 @@ namespace eval punk::mix::cli { } } - #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names + #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) - #REVIEW - needs to be updated to keep in sync with kettle. + #REVIEW - needs to be updated to keep in sync with kettle. set knownopts [list\ --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ @@ -1202,7 +1202,7 @@ namespace eval punk::mix::cli { package require punk::mix::base package require punk::overlay if {[catch { - punk::overlay::custom_from_base [namespace current] ::punk::mix::base + punk::overlay::custom_from_base [namespace current] ::punk::mix::base } errM]} { puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" error "punk::mix::cli error: $errM" @@ -1213,9 +1213,9 @@ namespace eval punk::mix::cli { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::cli [namespace eval punk::mix::cli { variable version - set version 0.3.1 + set version 0.3.1 }] return diff --git a/src/bootsupport/modules/punk/mix/templates-0.1.0.tm b/src/bootsupport/modules/punk/mix/templates-0.1.0.tm index dab5312f..63b5335c 100644 --- a/src/bootsupport/modules/punk/mix/templates-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/templates-0.1.0.tm @@ -47,7 +47,7 @@ namespace eval punk::mix::templates { lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. #review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. - #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. + #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. return $decls } } @@ -86,9 +86,9 @@ namespace eval punk::mix::templates { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::templates [namespace eval punk::mix::templates { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file 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 79150d6c..8e4699dc 100644 --- a/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -57,7 +57,7 @@ namespace eval punk::mix::util { incr i set last_opt $i } else { - set last_opt [expr {$i - 1}] + set last_opt [expr {$i - 1}] break } } @@ -73,7 +73,7 @@ namespace eval punk::mix::util { #puts stderr "opts: $opts paths: $paths" - #let's proceed, but warn the user if an apparent option is in paths + #let's proceed, but warn the user if an apparent option is in paths foreach opt [list -encoding -eofchar -translation] { if {$opt in $paths} { puts stderr "fcat WARNING: apparent option $opt found after file argument(s) (expected them before filenames). Passing to fileutil::cat anyway - but for at least some versions, these options may be ignored. commandline 'fcat $args'" @@ -142,7 +142,7 @@ namespace eval punk::mix::util { } #---------------------------------------- - #namespace import ::punk::ns::nsimport_noclobber + #namespace import ::punk::ns::nsimport_noclobber proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { set source_ns [namespace qualifiers $pattern] @@ -153,7 +153,7 @@ namespace eval punk::mix::util { set nscaller [uplevel 1 {namespace current}] set ns [punk::nsjoin $nscaller $ns] } - set a_export_patterns [namespace eval $source_ns {namespace export}] + set a_export_patterns [namespace eval $source_ns {namespace export}] set a_commands [info commands $pattern] set a_tails [lmap v $a_commands {namespace tail $v}] set a_exported_tails [list] @@ -359,9 +359,9 @@ namespace eval punk::mix::util { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::util [namespace eval punk::mix::util { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 140f2678..bce44dee 100644 --- a/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::nav::fs 0 0.1.0] #[copyright "2024"] #[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] -#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] +#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] #[require punk::nav::fs] #[keywords module filesystem terminal] #[description] @@ -117,9 +117,9 @@ tcl::namespace::eval punk::nav::fs { #Both tcl's notion of pwd and VIRTUAL_CWD can be out of sync with the process CWD. This happens when in a VFS. #We can also have VIRTUAL_CWD navigate to spaces that Tcl's cd can't - review - variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint + variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint if {![interp issafe]} { - set VIRTUAL_CWD [pwd] + set VIRTUAL_CWD [pwd] } else { set VIRTUAL_CWD "" } @@ -127,25 +127,25 @@ tcl::namespace::eval punk::nav::fs { variable VIRTUAL_CWD set cwd [pwd] if {$cwd ne $VIRTUAL_CWD} { - puts stderr "pwd: $cwd" + puts stderr "pwd: $cwd" } return $::punk::nav::fs::VIRTUAL_CWD } - #TODO - maintain per 'volume/server' CWD - #e.g cd and ./ to: - # d: + #TODO - maintain per 'volume/server' CWD + #e.g cd and ./ to: + # d: # //zipfs: # //server # https://example.com # should return to the last CWD for that volume/server - + #VIRTUAL_CWD follows pwd when changed via cd set stackrecord [commandstack::rename_command -renamer punk::nav::fs cd {args} { if {![catch { $COMMANDSTACKNEXT {*}$args } errM]} { - set ::punk::nav::fs::VIRTUAL_CWD [pwd] + set ::punk::nav::fs::VIRTUAL_CWD [pwd] } else { error $errM } @@ -153,7 +153,7 @@ tcl::namespace::eval punk::nav::fs { #*** !doctools #[subsection {Namespace punk::nav::fs}] - #[para] Core API functions for punk::nav::fs + #[para] Core API functions for punk::nav::fs #[list_begin definitions] @@ -170,7 +170,7 @@ tcl::namespace::eval punk::nav::fs { #This seems unfortunate - as a multithreaded set of test runs might otherwise have made some sense.. but perhaps for tests more serious isolation is a good idea. #It also seems common to cd when loading certain packages e.g tls from starkit. #While in most/normal cases the library will cd back to the remembered working directory after only a brief time - there seem to be many opportunities for issues - #if the repl is used to launch/run a number of things in the one process + #if the repl is used to launch/run a number of things in the one process proc d/ {args} { variable VIRTUAL_CWD @@ -205,7 +205,7 @@ tcl::namespace::eval punk::nav::fs { } set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] - set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) + set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) #set location [file normalize [dict get $matchinfo location]] set location [dict get $matchinfo location] @@ -217,7 +217,7 @@ tcl::namespace::eval punk::nav::fs { set filesizes [lsearch -all -inline -not $filesizes na] set filebytes [tcl::mathop::+ {*}$filesizes] lappend result filebytes [punk::lib::format_number $filebytes] - } + } if {[punk::nav::fs::system::codethread_is_running]} { if {[llength [info commands ::punk::console::titleset]]} { #if ansi is off - punk::console::titleset will try 'local' api method - which can fail @@ -252,18 +252,18 @@ tcl::namespace::eval punk::nav::fs { set a1 [lindex $args 0] switch -exact -- $a1 { . - ./ { - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } .. - ../ { if {$VIRTUAL_CWD eq "//zipfs:/" && ![string match //zipfs:/* [pwd]]} { #exit back to last nonzipfs path that was in use set VIRTUAL_CWD [pwd] - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } - #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) - # [file join //server ..] would become /server/.. - use normjoin to get //server - # file dirname //server/share would stay as //server/share + #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) + # [file join //server ..] would become /server/.. - use normjoin to get //server + # file dirname //server/share would stay as //server/share #set up1 [file dirname $VIRTUAL_CWD] set up1 [punk::path::normjoin $VIRTUAL_CWD ..] if {[string match //zipfs:/* $up1]} { @@ -277,7 +277,7 @@ tcl::namespace::eval punk::nav::fs { cd $up1 #set VIRTUAL_CWD [file normalize $a1] } - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } } @@ -318,13 +318,13 @@ tcl::namespace::eval punk::nav::fs { } } if {[file type $target] eq "directory"} { - set VIRTUAL_CWD $target + set VIRTUAL_CWD $target } } tailcall punk::nav::fs::d/ } set curdir $VIRTUAL_CWD - } else { + } else { set curdir [pwd] } @@ -365,7 +365,7 @@ tcl::namespace::eval punk::nav::fs { set location $path set glob * if {$searchspec_relative} { - set searchbase [pwd] + set searchbase [pwd] } else { set searchbase $path } @@ -373,19 +373,19 @@ tcl::namespace::eval punk::nav::fs { set location [file dirname $path] set glob [file tail $path] ;#search for exact match file if {$searchspec_relative} { - set searchbase [pwd] + set searchbase [pwd] } else { set searchbase [file dirname $path] } } } - set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] + set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] #puts stderr "=--->$matchinfo" set location [file normalize [dict get $matchinfo location]] if {[string match //xzipfs:/* $location] || $location ne $last_location} { - #REVIEW - zipfs test disabled with leading x + #REVIEW - zipfs test disabled with leading x #emit previous result if {[dict size $this_result]} { dict set this_result filebytes [punk::lib::format_number [dict get $this_result filebytes]] @@ -398,7 +398,7 @@ tcl::namespace::eval punk::nav::fs { set this_result [dict create] set dircount 0 set filecount 0 - } + } incr dircount [llength [dict get $matchinfo dirs]] incr filecount [llength [dict get $matchinfo files]] @@ -406,7 +406,7 @@ tcl::namespace::eval punk::nav::fs { dict set this_result location $location dict set this_result dircount $dircount dict set this_result filecount $filecount - + set filesizes [dict get $matchinfo filesizes] if {[llength $filesizes]} { set filesizes [lsearch -all -inline -not $filesizes na] @@ -468,7 +468,7 @@ tcl::namespace::eval punk::nav::fs { } set normpath [file normalize $path] cd $normpath - set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] + set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] set location [file normalize [dict get $matchinfo location]] @@ -479,7 +479,7 @@ tcl::namespace::eval punk::nav::fs { set filesizes [lsearch -all -inline -not $filesizes na] set filebytes [tcl::mathop::+ {*}$filesizes] lappend result filebytes [punk::lib::format_number $filebytes] - } + } set out [dirfiles_dict_as_lines -stripbase 1 $matchinfo] #return $out\n[pwd] @@ -583,7 +583,7 @@ tcl::namespace::eval punk::nav::fs { set ext [file extension $path] set extlower [string tolower $ext] if {$extlower in $tcl_extensions} { - set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first set ::argv0 $path set ::argc [llength $newargs] set ::argv $newargs @@ -609,7 +609,7 @@ tcl::namespace::eval punk::nav::fs { } } if {$tcl_indicator} { - set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. set ::argv0 $path set ::argc [llength $newargs] set ::argv $newargs @@ -645,7 +645,7 @@ tcl::namespace::eval punk::nav::fs { } proc dirfiles {args} { set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] - lassign [dict values $argd] leaders opts values_dict + lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] set opt_formatsizes [dict get $opts -formatsizes] @@ -663,11 +663,11 @@ tcl::namespace::eval punk::nav::fs { #dirfiles_dict would handle simple cases of globs within paths anyway - but we need to explicitly set tailglob here in all branches so that next level doesn't need to do file vs dir checks to determine user intent. #(dir-listing vs file-info when no glob-chars present is inherently ambiguous so we test file vs dir to make an assumption - more explicit control via -tailglob can be done manually with dirfiles_dict) if {$relativepath} { - set searchbase [pwd] + set searchbase [pwd] if {!$has_tailglobs} { if {[file isdirectory [file join $searchbase $searchspec]]} { set location [file join $searchbase $searchspec] - set tailglob * + set tailglob * } else { set location [file dirname [file join $searchbase $searchspec]] set tailglob [file tail $searchspec] ;#use exact match as a glob - will retrieve size,attributes etc. @@ -700,29 +700,29 @@ tcl::namespace::eval punk::nav::fs { return [dirfiles_dict_as_lines -stripbase $opt_stripbase -formatsizes $opt_formatsizes $contents] } - #todo - package as punk::nav::fs + #todo - package as punk::nav::fs #todo - in thread #todo - streaming version #glob patterns in path prior to final segment should already be resolved before using dirfiles_dict - as the underlying filesystem mechanisms can't do nested globbing themselves. #dirfiles_dict will assume the path up to the final segment is literal even if globchars are included therein. #final segment globs will be recognised only if -tailglob is passed as empty string #if -tailglob not supplied and last segment has globchars - presume searchspec parendir is the container and last segment is globbing within that. - #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * + #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * #caller should use parentdir as location and set tailglob to search-pattern or exact match if location is intended to match a file rather than a directory #examples: # somewhere/files = search is effectively somewhere/files/* (location somewhere/files glob is *) # somewhere/files/* = (as above) - # -tailglob * somewhere/files = (as above) + # -tailglob * somewhere/files = (as above) # # -tailglob "" somewhere/files = search somewhere folder for exactly 'files' (location somewhere glob is files) # -tailglob files somewhere = (as above) # # somewhere/f* = search somewhere folder for f* (location somewhere glob is f*) - # -tailglob f* somewhere = (as above) - # + # -tailglob f* somewhere = (as above) + # # This somewhat clumsy API is so that simple searches can be made in a default sensible manner without requiring extra -tailglob argument for the common cases - with lack of trailing glob segment indicating a directory listing # - but we need to distinguish somewhere/files as a search of that folder vs somewhere/files as a search for exactly 'files' within somewhere, hence the -tailglob option to fine-tune. - # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. + # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. # #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied @@ -733,7 +733,7 @@ tcl::namespace::eval punk::nav::fs { -searchbase -default "" -tailglob -default "\uFFFF" #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) - -with_sizes -default "\uFFFF" -type string + -with_sizes -default "\uFFFF" -type string -with_times -default "\uFFFF" -type string @values -min 0 -max -1 -type string } @@ -743,7 +743,7 @@ tcl::namespace::eval punk::nav::fs { #puts stderr "searchspecs: $searchspecs [llength $searchspecs]" #puts stdout "arglist: $opts" - + if {[llength $searchspecs] > 1} { #review - spaced paths ? error "dirfiles_dict: multiple listing not *yet* supported" @@ -757,7 +757,7 @@ tcl::namespace::eval punk::nav::fs { # -- --- --- --- --- --- --- #we don't want to normalize.. - #for example if the user supplies ../ we want to see ../result + #for example if the user supplies ../ we want to see ../result set is_relativesearchspec [expr {[file pathtype $searchspec] eq "relative"}] if {$opt_searchbase eq ""} { @@ -770,7 +770,7 @@ tcl::namespace::eval punk::nav::fs { switch -- $opt_tailglob { "" { if {$searchspec eq ""} { - set location + set location } else { if {$is_relativesarchspec} { #set location [file dirname [file join $opt_searchbase $searchspec]] @@ -821,13 +821,13 @@ tcl::namespace::eval punk::nav::fs { set location $searchspec } } - set match_contents $opt_tailglob + set match_contents $opt_tailglob } } #puts stdout "searchbase: $searchbase searchspec:$searchspec" - #file attr //cookit:/ returns {-vfs 1 -handle {}} + #file attr //cookit:/ returns {-vfs 1 -handle {}} #we will treat it differently for now - use generic handler REVIEW set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit. if {[llength [package provide vfs]]} { @@ -873,11 +873,11 @@ tcl::namespace::eval punk::nav::fs { #we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name? set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob) } else { - #we could use 'file attr' here to test if {-vfs 1} - #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) + #we could use 'file attr' here to test if {-vfs 1} + #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) #instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume } - + } } @@ -885,7 +885,7 @@ tcl::namespace::eval punk::nav::fs { #relative vs absolute? review - cwd valid for //zipfs:/ ?? set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } elseif {$in_cookit} { - #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ + #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ #don't use twapi #could possibly use du_dirlisting_tclvfs REVIEW #files and folders are all returned with the -types hidden option for glob on windows @@ -928,12 +928,12 @@ tcl::namespace::eval punk::nav::fs { lappend dirs $vfsmount } } - } + } #NOTE: -types {hidden d} * may return . & .. on unix platforms - but will not show them on windows. #A mounted vfs exe (e.g sometclkit.exe) may be returned by -types {hidden d} on windows - but at the same time has "-hidden 0" in the result of file attr. - + #non-unix platforms may have attributes to indicate hidden status even if filename doesn't have leading dot. #mac & windows have these #windows doesn't consider dotfiles as hidden - mac does (?) @@ -946,8 +946,8 @@ tcl::namespace::eval punk::nav::fs { set flaggedhidden [punk::lib::lunique_unordered $flaggedhidden] } - set dirs [lsort $dirs] ;#todo - natsort - + set dirs [lsort $dirs] ;#todo - natsort + #foreach d $dirs { @@ -958,7 +958,7 @@ tcl::namespace::eval punk::nav::fs { #glob -types {hidden} will not always return the combination of glob -types {hidden f} && -types {hidden d} (on windows anyway) - # -- --- + # -- --- #can't lsort files without lsorting filesizes #Note - the sort by index would convert an empty filesizes list to a list of empty strings - one for each entry in files #We want to preserve the empty list if that's what the dirlisting mechanism returned (presumably because -with_sizes was 0 or explicitly excluded files) @@ -971,22 +971,22 @@ tcl::namespace::eval punk::nav::fs { set sorted_filesizes [list] foreach i $sortorder { lappend sorted_files [lindex $files $i] - lappend sorted_filesizes [lindex $filesizes $i] + lappend sorted_filesizes [lindex $filesizes $i] } } set files $sorted_files set filesizes $sorted_filesizes - # -- --- + # -- --- #jmn foreach nm [list {*}$dirs {*}$files] { if {[punk::winpath::illegalname_test $nm]} { lappend nonportable $nm - } + } } - set front_of_dict [dict create location $location searchbase $opt_searchbase] + set front_of_dict [dict create location $location searchbase $opt_searchbase] set listing [dict merge $front_of_dict $listing] set updated [dict create dirs $dirs files $files filesizes $filesizes nonportable $nonportable flaggedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes] @@ -1045,7 +1045,7 @@ tcl::namespace::eval punk::nav::fs { set prefix_test_list [tcl::prefix all $searchbases [lindex $shortest_to_longest 0 0]] #if shortest doesn't match all searchbases - we have no common base if {[llength $prefix_test_list] == [llength $searchbases]} { - set common_base [lindex $shortest_to_longest 0 0]; #we + set common_base [lindex $shortest_to_longest 0 0]; #we } } } @@ -1082,11 +1082,11 @@ tcl::namespace::eval punk::nav::fs { } set $fileset $stripped } - #Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. + #Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. } # -- --- --- --- --- --- --- --- --- --- --- - #assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out + #assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out #As at 2024-09 for windows symlinks - Tcl can't do file readlink on symlinks created with mklink /D name target (SYMLINKD) or mklink name target (SYMLINK) #We can't read the target information - best we can do is classify it as a file or a dir #we can't use 'file type' as that will report just 'link' - but file isfile and file isdirectory work and should work for links on all platforms - REVIEW @@ -1110,7 +1110,7 @@ tcl::namespace::eval punk::nav::fs { } } } else { - #fallback if no target_type + #fallback if no target_type if {[file isfile $s]} { lappend file_symlinks $s #will be appended in finfo_plus later @@ -1125,9 +1125,9 @@ tcl::namespace::eval punk::nav::fs { } #we now have the issue that our symlinks aren't sorted within the dir/file categorisation - they currently will have to appear at beginning or end - TODO # -- --- --- --- --- --- --- --- --- --- --- - - - #todo - sort whilst maintaining order for metadata? + + + #todo - sort whilst maintaining order for metadata? #we need to co-sort files only with filesizes (other info such as times is keyed on fname so cosorting not required) @@ -1135,7 +1135,7 @@ tcl::namespace::eval punk::nav::fs { if {$opt_formatsizes} { set filesizes [punk::lib::format_number $filesizes] ;#accepts a list and will process each } - + #col2 (file info) with subcolumns set widest2a [tcl::mathfunc::max {*}[lmap v [list {*}$files {*}$file_symlinks ""] {string length $v}]] @@ -1162,7 +1162,7 @@ tcl::namespace::eval punk::nav::fs { set mtime [dict get $contents times $key m] set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] } else { - #set ts [string repeat { } 19] + #set ts [string repeat { } 19] set ts "$key vs [dict keys [dict get $contents times]]" } set note "" @@ -1181,7 +1181,7 @@ tcl::namespace::eval punk::nav::fs { set mtime [dict get $contents times $key m] set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] } else { - set ts "[string repeat { } 19]" + set ts "[string repeat { } 19]" } set note "link" ;#default only if {[dict exists $contents linkinfo $key linktype]} { @@ -1207,24 +1207,24 @@ tcl::namespace::eval punk::nav::fs { set fname [dict get $fdict file] if {[file extension $fname] eq ".lnk"} { if {![catch {package require punk::winlnk}]} { - set shortcutinfo [punk::winlnk::file_get_info $fname] + set shortcutinfo [punk::winlnk::file_get_info $fname] set target_type "file" ;#default/fallback if {[dict exists $shortcutinfo link_target]} { - set is_valid_lnk 1 + set is_valid_lnk 1 set tgt [dict get $shortcutinfo link_target] if {[file exists $tgt]} { #file type could return 'link' - we will use isfile/isdirectory if {[file isfile $tgt]} { set target_type file } elseif {[file isdirectory $tgt]} { - set target_type directory + set target_type directory } else { set target_type file ;## ? } } else { #todo - see if punk::winlnk has info about the type at the time of linking #for now - treat as file - } + } } else { #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. set is_valid_lnk 0 @@ -1239,7 +1239,7 @@ tcl::namespace::eval punk::nav::fs { } directory { #target of link is a dir - for display/categorisation purposes we want to see it as a dir - #will be styled later based on membership of dir_shortcuts + #will be styled later based on membership of dir_shortcuts lappend dirs $fname lappend dir_shortcuts $fname } @@ -1292,7 +1292,7 @@ tcl::namespace::eval punk::nav::fs { set fdisp "" if {[string length $d]} { if {$d in $flaggedhidden} { - set d1 [punk::ansi::a+ cyan normal] + set d1 [punk::ansi::a+ cyan normal] } if {$d in $vfsmounts} { if {$d in $flaggedhidden} { @@ -1313,7 +1313,7 @@ tcl::namespace::eval punk::nav::fs { } } else { if {$d in $nonportable} { - set d1 [punk::ansi::a+ red bold] + set d1 [punk::ansi::a+ red bold] } } #dlink-style & dshortcut_style are for underlines - can be added with colours already set @@ -1336,11 +1336,11 @@ tcl::namespace::eval punk::nav::fs { } lappend displaylist [overtype::left $col1 $d1$d$RST]$f1$fdisp$RST } - + return [punk::lib::list_as_lines $displaylist] - } + } - #pass in base and platform to head towards purity/testability. + #pass in base and platform to head towards purity/testability. #this function can probably never be pure in such a simple form - as it needs to read state from the os storage system configuration #consider haskells approach of well-typed paths for cross-platform paths: https://hackage.haskell.org/package/path #review: punk::winpath calls cygpath! @@ -1360,8 +1360,8 @@ tcl::namespace::eval punk::nav::fs { set path_absolute [punk::unixywindows::towinpath $path] #puts stderr "winpath: $path" } else { - #todo handle volume-relative paths with volume specified c:etc c: - #note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd + #todo handle volume-relative paths with volume specified c:etc c: + #note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd #not clear whether tcl can/will fix this - but it means these paths are dangerous. #The cwd of the process can get out of sync with what tcl thinks is the working directory when you swap drives #Arguably if ...? @@ -1421,14 +1421,14 @@ tcl::namespace::eval punk::nav::fs::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::nav::fs::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 + # #[para]Description of utility1 + # return 1 #} @@ -1446,7 +1446,7 @@ tcl::namespace::eval punk::nav::fs::lib { tcl::namespace::eval punk::nav::fs::system { #*** !doctools #[subsection {Namespace punk::nav::fs::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #ordinary emission of chunklist when no repl proc emit_chunklist {chunklist} { @@ -1471,18 +1471,18 @@ tcl::namespace::eval punk::nav::fs::system { proc codethread_is_running {} { if {[info commands ::punk::repl::codethread::is_running] ne ""} { - return [punk::repl::codethread::is_running] + return [punk::repl::codethread::is_running] } return 0 } } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::nav::fs [tcl::namespace::eval punk::nav::fs { variable pkg punk::nav::fs variable version - set version 0.1.0 + set version 0.1.0 }] return 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 feee9d87..a64eef0f 100644 --- a/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm +++ b/src/bootsupport/modules/punk/repl/codethread-0.1.1.tm @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::repl::codethread 0 0.1.1] #[copyright "2024"] #[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] -#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] +#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] #[require punk::repl::codethread] #[keywords module repl] #[description] -#[para] This is part of the infrastructure required for the punk::repl to operate +#[para] This is part of the infrastructure required for the punk::repl to operate # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -122,7 +122,7 @@ tcl::namespace::eval punk::repl::codethread { #*** !doctools #[subsection {Namespace punk::repl::codethread}] - #[para] Core API functions for punk::repl::codethread + #[para] Core API functions for punk::repl::codethread #[list_begin definitions] @@ -130,13 +130,13 @@ tcl::namespace::eval punk::repl::codethread { #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" #} variable run_command_cache @@ -145,7 +145,7 @@ tcl::namespace::eval punk::repl::codethread { #if {[catch {interp children}]} { # #8.6.10 doesn't have it.. when was it introduced? #} else { - + #} proc is_running {} { @@ -153,14 +153,14 @@ tcl::namespace::eval punk::repl::codethread { return $running } proc runscript {script} { - + #puts stderr "->runscript" - variable replthread_cond + variable replthread_cond #variable output_stdout "" #variable output_stderr "" #expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available - #if a thread::send is done from the commandline in a codethread - Tcl will + #if a thread::send is done from the commandline in a codethread - Tcl will if {![interp exists code] || ![info exists replthread_cond]} { #in case someone tries calling from codethread directly - don't do anything or change any state #(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) @@ -233,12 +233,12 @@ tcl::namespace::eval punk::repl::codethread { flush stderr #interp transfer code $errhandle "" - #flush $errhandle + #flush $errhandle #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code [list set ::punk::repl::codethread::output_stdout]]] end] - set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] + set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] #note we could be in a *large* ansi segment such as sixel data - #review - why do we need to ansistrip? + #review - why do we need to ansistrip? set lastoutchar [string index [punk::ansi::ansistrip $lastoutpart] end] #set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] @@ -247,7 +247,7 @@ tcl::namespace::eval punk::repl::codethread { #puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" set tid [thread::id] - tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] + tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] tsv::set codethread_$tid status $status tsv::set codethread_$tid result $result tsv::set codethread_$tid errorcode $::errorCode @@ -277,14 +277,14 @@ tcl::namespace::eval punk::repl::codethread::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::repl::codethread::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 + # #[para]Description of utility1 + # return 1 #} @@ -302,17 +302,17 @@ tcl::namespace::eval punk::repl::codethread::lib { tcl::namespace::eval punk::repl::codethread::system { #*** !doctools #[subsection {Namespace punk::repl::codethread::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::repl::codethread [tcl::namespace::eval punk::repl::codethread { variable pkg punk::repl::codethread variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/bootsupport/modules/punkcheck-0.1.0.tm index db8a3db5..fbf9a4e4 100644 --- a/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -69,7 +69,7 @@ namespace eval punkcheck { } - proc load_records_from_file {punkcheck_file} { + proc load_records_from_file {punkcheck_file} { set record_list [list] if {[file exists $punkcheck_file]} { set tdlscript [punk::mix::util::fcat $punkcheck_file] @@ -86,7 +86,7 @@ namespace eval punkcheck { set linecount [llength [split $newtdl \n]] #puts stdout $newtdl set fd [open $punkcheck_file w] - fconfigure $fd -translation binary + chan configure $fd -translation binary puts -nonewline $fd $newtdl close $fd return [list recordcount [llength $recordlist] linecount $linecount] @@ -94,7 +94,7 @@ namespace eval punkcheck { #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? - #an installtrack objects represents an installation path from sourceroot to targetroot + #an installtrack objects represents an installation path from sourceroot to targetroot #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. # set objname [namespace current]::installtrack @@ -104,7 +104,7 @@ namespace eval punkcheck { #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD #each FILEINFO body being a list of SOURCE records oo::class create targetset { - variable o_targets + variable o_targets variable o_keep_installrecords variable o_keep_skipped variable o_keep_inprogress @@ -132,7 +132,7 @@ namespace eval punkcheck { -keep_inprogress $o_keep_inprogress\ body $o_records } - + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS method get_last_record {fileset_record} { set body [dict_getwithdefault $fileset_record body [list]] @@ -189,11 +189,11 @@ namespace eval punkcheck { } set o_ts_end [dict get $opts -tsend] set o_types [dict get $opts -types] - set o_configdict [dict get $opts -config] + set o_configdict [dict get $opts -config] set o_rel_sourceroot $rel_sourceroot set o_rel_targetroot $rel_targetroot - } + } destructor { #puts "[self] destructor called" } @@ -339,14 +339,14 @@ namespace eval punkcheck { set installing_record [lindex $fileinfo_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset fileinfo_body end $installing_record - + return [dict set o_fileset_record body $fileinfo_body] } else { #legacy call @@ -368,7 +368,7 @@ namespace eval punkcheck { } set status [string toupper $status] - set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] if {$o_operation_start_ts eq ""} { error "[self] targetset_end $status - no current operation - call targetset_started first" } @@ -383,7 +383,7 @@ namespace eval punkcheck { error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" } set operation_end_ts [clock microseconds] - set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] set file_record_body [dict get $o_fileset_record body] set installing_record [lindex $file_record_body end] set punkcheck_file [$o_installer get_checkfile] @@ -414,12 +414,12 @@ namespace eval punkcheck { } } set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] - dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -targets_cksums $new_targets_cksums dict set installing_record -cksum_all_opts $cksum_all_opts dict set installing_record -cksum_us $cksum_us } lset file_record_body end $installing_record - dict set o_fileset_record body $file_record_body + dict set o_fileset_record body $file_record_body set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] @@ -436,8 +436,8 @@ namespace eval punkcheck { set o_operation "" return $o_fileset_record } - #can supply empty cksum value - # - that will influence the opts used if there is no existing install record + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record method targetset_cksumcache_set {path_cksum_dict} { set o_path_cksum_cache $path_cksum_dict } @@ -504,12 +504,12 @@ namespace eval punkcheck { variable o_ts variable o_keep_events variable o_checkfile - variable o_sourceroot + variable o_sourceroot variable o_rel_sourceroot variable o_targetroot variable o_rel_targetroot variable o_record_list - variable o_active_event + variable o_active_event variable o_events constructor {installername punkcheck_file} { set o_active_event "" @@ -546,7 +546,7 @@ namespace eval punkcheck { #$o_events add $e [dict get $e -id] $o_events add $eobj [dict get $e -id] } - + } destructor { #puts "[self] destructor called" @@ -562,7 +562,7 @@ namespace eval punkcheck { } #call set_source_target before calling start_event/end_event - #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. method set_source_target {sourceroot targetroot} { if {[file pathtype $sourceroot] ne "absolute"} { error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" @@ -605,7 +605,7 @@ namespace eval punkcheck { } method save_installer_record {} { set file_records [punkcheck::load_records_from_file $o_checkfile] - + set this_installer_record [my as_record] set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] @@ -658,13 +658,13 @@ namespace eval punkcheck { set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] } method get_recordlist {} { - return $o_recordlist + return $o_recordlist } method end_event {} { if {$o_active_event eq ""} { error "[self] end_event error - no active event" } - $o_active_event end + $o_active_event end } method get_event {} { return $o_active_event @@ -720,7 +720,7 @@ namespace eval punkcheck { append msg "Call in order:" \n append msg " start_installer_event (get dict with eventid and recordset keys)" append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n - append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n append msg " ( - possibly with same algorithm as previous installrecord)" \n append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n append msg "Finalize by calling:" \n @@ -749,7 +749,7 @@ namespace eval punkcheck { set punkcheck_file [file join $punkcheck_folder/.punkcheck] set record_list [load_records_from_file $punkcheck_file] - + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] set installer_record_position [dict get $resultinfo position] if {$installer_record_position == -1} { @@ -805,7 +805,7 @@ namespace eval punkcheck { #validate any passed cached_cksums foreach cacheinfo $cached_cksums { if {[llength $cacheinfo] % 2 != 0} { - error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" } dict for {k v} $cacheinfo { switch -- $k { @@ -814,7 +814,7 @@ namespace eval punkcheck { #todo - validate $v keys } default { - error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" } } @@ -837,7 +837,7 @@ namespace eval punkcheck { } } } - #check that this relpath not already added as child of *-INPROGRESS + #check that this relpath not already added as child of *-INPROGRESS set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body set installing_record [lindex $file_record_body end] set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] @@ -871,14 +871,14 @@ namespace eval punkcheck { #use first entry in cached_cksums if we can if {[llength $cached_cksums]} { set use_cache 1 - set use_cache_record [lindex $cached_cksums 0] + set use_cache_record [lindex $cached_cksums 0] } } #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) #if same cksum_opts - then use cached data instead of checksumming here. - #allow nonexistant as a source + #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] if {![file exists $fpath]} { set ftype "missing" @@ -939,14 +939,14 @@ namespace eval punkcheck { set installing_record [lindex $file_record_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] - + dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset file_record_body end $installing_record - + dict set file_record body $file_record_body @@ -983,7 +983,7 @@ namespace eval punkcheck { dict set installing_record tag "INSTALL-RECORD" lset file_record_body end $installing_record - dict set file_record body $file_record_body + dict set file_record body $file_record_body set file_record [punkcheck::recordlist::file_record_prune $file_record] @@ -1016,8 +1016,8 @@ namespace eval punkcheck { set tsnow [clock microseconds] set elapsed_us [expr {$tsnow - $ts_start}] dict set installing_record -elapsed_us $elapsed_us - dict set installing_record tag "INSTALL-SKIPPED" - + dict set installing_record tag "INSTALL-SKIPPED" + lset file_record_body end $installing_record dict set file_record body $file_record_body @@ -1076,7 +1076,7 @@ namespace eval punkcheck { #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL proc install_record_get_matching_source_record {install_record source_relpath} { - set body [dict_getwithdefault $install_record body [list]] + set body [dict_getwithdefault $install_record body [list]] foreach src $body { if {[dict get $src tag] eq "SOURCE"} { if {[dict_getwithdefault $src -path ""] eq $source_relpath} { @@ -1124,7 +1124,7 @@ namespace eval punkcheck { set do_normalize 1 } } else { - #case differences in volumes is common on windows + #case differences in volumes is common on windows set do_normalize 1 } if {$do_normalize} { @@ -1207,7 +1207,7 @@ namespace eval punkcheck { if {[dict exists $dictValue {*}$keys]} { return [dict get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } lappend PUNKARGS [list { @@ -1273,11 +1273,11 @@ namespace eval punkcheck { # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target # -overwrite all-targets will copy regardless of timestamp at target - # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry # review - timestamps unreliable - # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? - # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? # if such a content-mismatch - what default behaviour and what options would make sense? # probably it's reasonable that only all-targets would overwrite such files. @@ -1369,7 +1369,7 @@ namespace eval punkcheck { if {[llength [file split $af]] > 1} { error "punkcheck::install received invalid -antiglob_file entry '$af'. -antiglob_file entries are meant to match to a file name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] if {$opt_antiglob_dir_core eq "\uFFFF"} { @@ -1383,7 +1383,7 @@ namespace eval punkcheck { if {[llength [file split $ad]] > 1} { error "punkcheck::install received invalid -antiglob_dir entry '$ad'. -antiglob_dir entries are meant to match to a directory name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment @@ -1482,7 +1482,7 @@ namespace eval punkcheck { } else { set store_source_cksums 0 } - + @@ -1545,12 +1545,12 @@ namespace eval punkcheck { } if {$suppress == 0} { lappend match_list $m - } + } } #sample .punkcheck file record (raw form) to make the code clearer #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist - #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS # #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { @@ -1563,15 +1563,15 @@ namespace eval punkcheck { # } #} - if {[llength $match_list]} { + if {[llength $match_list]} { #example - target dir has a file where there is a directory at the source if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" } } - + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} - + #puts stdout "Current target dir: $current_target_dir" foreach m $match_list { @@ -1581,7 +1581,7 @@ namespace eval punkcheck { set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing file - globmatchpath $antipath vs $relative_source_path" + #puts "testing file - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched $current_source_dir set is_antipath 1 @@ -1598,7 +1598,7 @@ namespace eval punkcheck { #puts stdout " rel_target: $punkcheck_target_relpath" - + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] #change to use extract_or_create_fileset_record ? set existing_filerec_posn [dict get $fetch_filerec_result position] @@ -1614,7 +1614,7 @@ namespace eval punkcheck { set filerec [dict get $fetch_filerec_result record] } set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] - + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. @@ -1630,7 +1630,7 @@ namespace eval punkcheck { #different volume or root } #Note this isn't a recordlist function - so it doesn't purely operate on the records - #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] @@ -1697,7 +1697,7 @@ namespace eval punkcheck { } else { #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it set is_skip 1 - puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" lappend files_skipped $current_source_dir/$m } } else { @@ -1728,7 +1728,7 @@ namespace eval punkcheck { #if {$store_source_cksums} { #} - set install_records [dict get $filerec body] + set install_records [dict get $filerec body] set current_install_record [lindex $install_records end] #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED if {$is_skip} { @@ -1790,7 +1790,7 @@ namespace eval punkcheck { set relative_source_path [file join $relative_source_dir $d] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing folder - globmatchpath $antipath vs $relative_source_path" + #puts "testing folder - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched [file join $current_source_dir $d] #puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath " @@ -1801,11 +1801,11 @@ namespace eval punkcheck { if {$is_antipath} { continue } - + #if {![file exists $current_target_dir/$d]} { # file mkdir $current_target_dir/$d #} - + set sub_opts_1 [list\ -call-depth-internal [expr {$CALLDEPTH + 1}]\ @@ -1828,7 +1828,7 @@ namespace eval punkcheck { -punkcheck_folder $punkcheck_folder\ -punkcheck_eventid $punkcheck_eventid\ -punkcheck_records $punkcheck_records\ - ] + ] set sub_opts [dict merge $opts $sub_opts] set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] @@ -1838,7 +1838,7 @@ namespace eval punkcheck { lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] set punkcheck_records [dict get $sub_result punkcheck_records] } - + if {[string match *store* $opt_source_checksum]} { #puts "subdirlist: $subdirlist" if {$CALLDEPTH == 0} { @@ -1849,7 +1849,7 @@ namespace eval punkcheck { #puts stdout ">>>>>>>>>>>>>>>>>>>" } else { #todo - write db INSTALLER record if -debug true - + } #puts stdout "sources_unchanged" #puts stdout "$sources_unchanged" @@ -2108,7 +2108,7 @@ namespace eval punkcheck { if {[dict get $file_record tag] ne "FILEINFO"} { error "file_record_set_defaults bad file_record: tag not FILEINFO" } - set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] foreach {k v} $defaults { if {![dict exists $file_record $k]} { dict set file_record $k $v @@ -2186,10 +2186,10 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punkcheck [namespace eval punkcheck { set pkg punkcheck variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/bootsupport/modules/textblock-0.1.3.tm b/src/bootsupport/modules/textblock-0.1.3.tm index 8d66978f..2d185f01 100644 --- a/src/bootsupport/modules/textblock-0.1.3.tm +++ b/src/bootsupport/modules/textblock-0.1.3.tm @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_textblock 0 0.1.3] #[copyright "2024"] #[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] +#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] #[require textblock] #[keywords module ansi text layout colour table frame console terminal] #[description] @@ -29,7 +29,7 @@ #*** !doctools #[section Overview] -#[para] overview of textblock +#[para] overview of textblock #[subsection Concepts] #[para] @@ -39,7 +39,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by textblock +#[para] packages used by textblock #[list_begin itemized] #*** !doctools @@ -90,7 +90,7 @@ package require textutil tcl::namespace::eval textblock { #review - what about ansi off in punk::console? tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ - tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus #(more likely to be optimised for modern cpu features?) @@ -102,7 +102,7 @@ tcl::namespace::eval textblock { namespace eval argdoc { proc hash_algorithm_choices_and_help {} { set choices [list none] - set unavailable [list] + set unavailable [list] set unloaded [dict create] set algorithm_packages {md5 sha1 sha256} foreach p $algorithm_packages { @@ -219,7 +219,7 @@ tcl::namespace::eval textblock { #ie only vll,blc,hlb used for cells except top row and right column #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 + #e.g for 4x4 # C C C O # L L L U # L L L U @@ -229,7 +229,7 @@ tcl::namespace::eval textblock { set L [list vll blc hlb] set U [list vll blc hlb brc vlr] set tops [list trc hlt tlc] - set lefts [list tlc vll blc] + set lefts [list tlc vll blc] set bottoms [list blc hlb brc] set rights [list trc brc vlr] @@ -491,8 +491,8 @@ tcl::namespace::eval textblock { set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v + set seps_h $requested_seps_h + set seps_v $requested_seps_v if {$requested_seps eq ""} { if {$requested_seps_h eq ""} { set seps_h 1 @@ -502,10 +502,10 @@ tcl::namespace::eval textblock { } } else { if {$requested_seps_h eq ""} { - set seps_h $seps + set seps_h $seps } if {$requested_seps_v eq ""} { - set seps_v $seps + set seps_v $seps } } return [tcl::dict::create horizontal $seps_h vertical $seps_v] @@ -515,8 +515,8 @@ tcl::namespace::eval textblock { set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body + set ft_header $requested_ft_header + set ft_body $requested_ft_body switch -- $requested_ft { light { if {$requested_ft_header eq ""} { @@ -544,10 +544,10 @@ tcl::namespace::eval textblock { } default { if {$requested_ft_header eq ""} { - set ft_header $requested_ft + set ft_header $requested_ft } if {$requested_ft_body eq ""} { - set ft_body $requested_ft + set ft_body $requested_ft } } } @@ -621,7 +621,7 @@ tcl::namespace::eval textblock { if {![llength $args]} { return $o_opts_table - } + } if {[llength $args] == 1} { if {[lindex $args 0] in [list %topt_keys%]} { #query single option @@ -634,7 +634,7 @@ tcl::namespace::eval textblock { tcl::dict::set infodict debug [ansistring VIEW $val] } -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] } } tcl::dict::set returndict info $infodict @@ -663,11 +663,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; + set ansi_codes [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend ansi_codes $code @@ -684,7 +684,7 @@ tcl::namespace::eval textblock { -framemap_body - -framemap_header { #upvar ::textblock::class::opts_table_defaults tdefaults #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map + #todo - check keys and map if {[llength $v] == 1} { if {$v eq "default"} { upvar ::textblock::class::opts_table_defaults tdefaults @@ -700,7 +700,7 @@ tcl::namespace::eval textblock { switch -- $subk { topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" } } #safe jumptable test @@ -752,14 +752,14 @@ tcl::namespace::eval textblock { } -show_hseps { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations } -show_edge { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play @@ -768,7 +768,7 @@ tcl::namespace::eval textblock { -show_vseps { #we allow empty string - so don't use -strict boolean check if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } #affects width calculations set o_calculated_column_widths [list] @@ -807,7 +807,7 @@ tcl::namespace::eval textblock { if {[my width] < [expr {$twidth+2}]} { set o_calculated_column_widths [list] tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] - } + } tcl::dict::set o_opts_table -title $v } default { @@ -840,7 +840,7 @@ tcl::namespace::eval textblock { } } #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] return $o_opts_table } @@ -858,7 +858,7 @@ tcl::namespace::eval textblock { for {set c 0} {$c < $matrix_colcount} {incr c} { my add_column -headers "" } - } + } set table_colcount [my column_count] if {$table_colcount != $matrix_colcount} { error "textblock::table::printmatrix column count of table doesn't match column count of matrix" @@ -874,7 +874,7 @@ tcl::namespace::eval textblock { method as_matrix {{cmd ""}} { #*** !doctools #[call class::table [method as_matrix] [arg ?cmd?]] - #[para] return a struct::matrix command representing the data portion of the table. + #[para] return a struct::matrix command representing the data portion of the table. if {$cmd eq ""} { set m [struct::matrix] @@ -883,8 +883,8 @@ tcl::namespace::eval textblock { } $m add columns [tcl::dict::size $o_columndata] $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v + tcl::dict::for {k v} $o_columndata { + $m set column $k $v } return $m } @@ -907,17 +907,17 @@ tcl::namespace::eval textblock { } } } - set colcount [tcl::dict::size $o_columndefs] + set colcount [tcl::dict::size $o_columndefs] tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { + if {[catch { my configure_column $colcount {*}$opts } errMsg]} { #configure failed - ensure o_columndata and o_columndefs entries are removed @@ -926,7 +926,7 @@ tcl::namespace::eval textblock { tcl::dict::unset o_columnstates $colcount #undo cache invalidation set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" } #any add_column that succeeds should invalidate the calculated column widths set o_calculated_column_widths [list] @@ -945,7 +945,7 @@ tcl::namespace::eval textblock { method column_count {} { #*** !doctools #[call class::table [method column_count]] - #[para] return the number of columns + #[para] return the number of columns return [tcl::dict::size $o_columndefs] } method configure_column {index_expression args} { @@ -956,7 +956,7 @@ tcl::namespace::eval textblock { set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } + } if {![llength $args]} { return [tcl::dict::get $o_columndefs $cidx] } else { @@ -991,7 +991,7 @@ tcl::namespace::eval textblock { } set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - set hstates $o_headerstates ;#operate on a copy + set hstates $o_headerstates ;#operate on a copy set colstate [tcl::dict::get $o_columnstates $cidx] set args_got_headers 0 set args_got_header_colspans 0 @@ -1000,7 +1000,7 @@ tcl::namespace::eval textblock { -headers { set args_got_headers 1 set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. foreach hdr $v { set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns #set this_header_height [textblock::height $hdr] @@ -1052,7 +1052,7 @@ tcl::namespace::eval textblock { # } #} else { set header_spans [tcl::dict::get $cspans $h] - set remaining [lindex $header_spans 0] + set remaining [lindex $header_spans 0] if {$remaining ne "any"} { incr remaining -1 } @@ -1109,11 +1109,11 @@ tcl::namespace::eval textblock { } -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; + set col_ansibase_items [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend col_ansibase_items $code @@ -1146,13 +1146,13 @@ tcl::namespace::eval textblock { } #args checked - ok to update headerstates, headerdefs and columndefs and columnstates tcl::dict::set o_columndefs $cidx $checked_opts - set o_headerstates $hstates + set o_headerstates $hstates dict for {hidx hstate} $hstates { #configure_header if {![dict exists $o_headerdefs $hidx]} { #remove calculated members -values -colspans set hdefaults [dict remove $o_opts_header_defaults -values -colspans] - dict set o_headerdefs $hidx $hdefaults + dict set o_headerdefs $hidx $hdefaults } } @@ -1183,7 +1183,7 @@ tcl::namespace::eval textblock { method header_count {} { #*** !doctools #[call class::table [method header_count]] - #[para] return the number of header rows + #[para] return the number of header rows return [tcl::dict::size $o_headerstates] } method header_count_calc {} { @@ -1232,7 +1232,7 @@ tcl::namespace::eval textblock { method header_colspans {} { #*** !doctools #[call class::table [method header_colspans]] - #[para] Show the colspans configured for all headers + #[para] Show the colspans configured for all headers #set num_headers [my header_count_calc] set num_headers [my header_count] @@ -1242,9 +1242,9 @@ tcl::namespace::eval textblock { set colspans_for_column [tcl::dict::get $cdef -header_colspans] for {set h 0} {$h < $num_headers} {incr h} { set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] + set defined_span [lindex $colspans_for_column $h] set i 0 - set spanremaining [lindex $headerspans 0] + set spanremaining [lindex $headerspans 0] if {$spanremaining ne "any"} { if {$spanremaining eq ""} { set spanremaining 1 @@ -1256,7 +1256,7 @@ tcl::namespace::eval textblock { set spanremaining "any" } elseif {$s == 0} { if {$spanremaining ne "any"} { - incr spanremaining -1 + incr spanremaining -1 } } else { set spanremaining [expr {$s - 1}] @@ -1273,7 +1273,7 @@ tcl::namespace::eval textblock { } else { lappend headerspans $defined_span } - tcl::dict::set colspans_by_header $h $headerspans + tcl::dict::set colspans_by_header $h $headerspans } } return $colspans_by_header @@ -1301,10 +1301,10 @@ tcl::namespace::eval textblock { } incr spanlen } - #overwrite the 'any' with it's actual span + #overwrite the 'any' with it's actual span set modified_spans [dict get $hcolspans $h] lset modified_spans $c $spanlen - dict set hcolspans $h $modified_spans + dict set hcolspans $h $modified_spans } incr c } @@ -1315,7 +1315,7 @@ tcl::namespace::eval textblock { method configure_header {index_expression args} { #*** !doctools #[call class::table [method configure_header]] - #[para] - configure header row-wise + #[para] - configure header row-wise #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis @@ -1331,7 +1331,7 @@ tcl::namespace::eval textblock { } if {![llength $args]} { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] set header_row_items [list] @@ -1339,9 +1339,9 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - tcl::dict::set result -values $header_row_items + tcl::dict::set result -values $header_row_items #review - ensure always a headerdef record for each header? if {[tcl::dict::exists $o_headerdefs $hidx]} { @@ -1359,7 +1359,7 @@ tcl::namespace::eval textblock { #set val [tcl::dict::get $o_rowdefs $ridx $k] set infodict [tcl::dict::create] - #todo + #todo # -blockalignments and -textalignments lists # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} #if there is a value it overrides alignments specified on the column @@ -1370,14 +1370,14 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - set val $header_row_items + set val $header_row_items set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] } -colspans { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] set val [tcl::dict::get $colspans_by_header $hidx] #ansireset not required @@ -1412,11 +1412,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; + set header_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend header_ansibase_items $code @@ -1443,7 +1443,7 @@ tcl::namespace::eval textblock { if {[llength $v] > $numcols} { error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" } - if {[llength $v] < $numcols} { + if {[llength $v] < $numcols} { puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" } @@ -1457,7 +1457,7 @@ tcl::namespace::eval textblock { } if {!$first_is_ok} { error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" - } + } #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) set remaining $firstspan if {$remaining ne "any"} { @@ -1469,7 +1469,7 @@ tcl::namespace::eval textblock { foreach span [lrange $v 1 end] { if {$remaining eq "any"} { if {$span eq "any"} { - set remaining "any" + set remaining "any" } elseif {$span > 0} { #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { @@ -1479,7 +1479,7 @@ tcl::namespace::eval textblock { set remaining $span incr remaining -1 } else { - #zero following an any - leave remaining as any + #zero following an any - leave remaining as any } } else { if {$span eq "0"} { @@ -1546,7 +1546,7 @@ tcl::namespace::eval textblock { # -- -- -- -- -- -- #also update maxwidthseen & maxheightseen set i 0 - set maxwidthseen 0 + set maxwidthseen 0 #set maxheightseen 0 foreach hdr $thiscol_headers_vertical { lassign [textblock::size $hdr] _w this_header_width _h this_header_height @@ -1567,7 +1567,7 @@ tcl::namespace::eval textblock { } } -colspans { - #sequence has been verified above - we need to split it and store across columns + #sequence has been verified above - we need to split it and store across columns set c 0 ;#column index foreach span $v { set colspans [tcl::dict::get $o_columndefs $c -header_colspans] @@ -1615,7 +1615,7 @@ tcl::namespace::eval textblock { } #set o_headerstate $hidx -minheight? -maxheight? ??? - tcl::dict::set o_headerdefs $hidx $update_hdefs + tcl::dict::set o_headerdefs $hidx $update_hdefs } method add_row {valuelist args} { @@ -1635,14 +1635,14 @@ tcl::namespace::eval textblock { if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { error "add_row - no values supplied, and no columns defined, so cannot use default column values" } - + set defaults [tcl::dict::create\ -minheight 1\ -maxheight ""\ -ansibase ""\ -ansireset "\uFFEF"\ ] - set o_opts_row_defaults $defaults + set o_opts_row_defaults $defaults if {[llength $args] %2 !=0} { error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" @@ -1676,23 +1676,23 @@ tcl::namespace::eval textblock { } } set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure if {[catch { my configure_row $rowcount {*}$opts } errMsg]} { #undo anything we saved before configure_row tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns + #remove auto_columns if {$auto_columns} { set o_columndata [tcl::dict::create] set o_columndefs [tcl::dict::create] set o_columnstate [tcl::dict::create] } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" } - + set c 0 set max_height_seen 1 foreach v $valuelist { @@ -1774,11 +1774,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; + set row_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend row_ansibase_items $code @@ -1954,7 +1954,7 @@ tcl::namespace::eval textblock { } method get_column_by_index {index_expression args} { #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. set opts [tcl::dict::create\ -position "inner"\ -return "string"\ @@ -1992,7 +1992,7 @@ tcl::namespace::eval textblock { set topt_show_header [tcl::dict::get $o_opts_table -show_header] if {$topt_show_header eq ""} { - set allheaders 0 + set allheaders 0 set all_cols [tcl::dict::keys $o_columndefs] foreach c $all_cols { incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] @@ -2015,8 +2015,8 @@ tcl::namespace::eval textblock { set boxlimits "" set joins "" - set header_boxlimits [list] - set header_body_joins [list] + set header_boxlimits [list] + set header_body_joins [list] set ftypes [my Get_frametypes] @@ -2035,9 +2035,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] @@ -2060,9 +2060,9 @@ tcl::namespace::eval textblock { set sep_elements_horizontal $::textblock::class::table_hseps set sep_elements_vertical $::textblock::class::table_vseps - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] set onlymap [tcl::dict::get $fmap only$opt_posn] set hdrmap [tcl::dict::get $hmap only${opt_posn}] @@ -2074,7 +2074,7 @@ tcl::namespace::eval textblock { set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] lassign [my Get_seps] _h show_seps_h _v show_seps_v @@ -2091,7 +2091,7 @@ tcl::namespace::eval textblock { set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] set ansiborder_final $ansibase_header$ansiborder_header$extrabg } else { set ansiborder_final $ansibase_header$ansiborder_header @@ -2099,7 +2099,7 @@ tcl::namespace::eval textblock { set RST [punk::ansi::a] - set hcolwidth $colwidth + set hcolwidth $colwidth #set hcolwidth [my column_width_configured $cidx] set hcell_line_blank [tcl::string::repeat " " $hcolwidth] @@ -2149,7 +2149,7 @@ tcl::namespace::eval textblock { if {$hrow == $hmax} { set header_joins $header_body_joins } else { - set header_joins $joins + set header_joins $joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] @@ -2167,7 +2167,7 @@ tcl::namespace::eval textblock { set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] set spanbelow [lindex $next_spanlist $cidx] if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins + #we don't want a down-join for blc - use a framedef with only left joins tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] } } else { @@ -2181,7 +2181,7 @@ tcl::namespace::eval textblock { #May be better to require user to pre-wrap as needed ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) # -width is always +2 - as the boxlimits take into account show_vseps and show_edge @@ -2219,10 +2219,10 @@ tcl::namespace::eval textblock { #puts ">> remaining_spans: $remaining_spans" set spancol [expr {$cidx + 1}] set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + - set last [expr {[llength $remaining_spans] -1}] set i 0 foreach s $remaining_spans { @@ -2238,9 +2238,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $next_posn $fname_body] set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] @@ -2263,14 +2263,14 @@ tcl::namespace::eval textblock { } } else { #join to body - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype } } if {$hrow == $hmax} { set header_joins $span_joins_body } else { - set header_joins $span_joins + set header_joins $span_joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] @@ -2285,7 +2285,7 @@ tcl::namespace::eval textblock { } else { break } - incr spancol + incr spancol incr i } @@ -2304,7 +2304,7 @@ tcl::namespace::eval textblock { set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] } else { - set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] } } else { @@ -2349,10 +2349,10 @@ tcl::namespace::eval textblock { set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] #POTENTIAL BUG (fixed with spans_to_rhs above) #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) - #we need to shift 1 to the left when doing our overtype with blockalign right + #we need to shift 1 to the left when doing our overtype with blockalign right #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge #(even though the column position may be left or inner) - + } else { @@ -2389,12 +2389,12 @@ tcl::namespace::eval textblock { set h_lines [lrepeat $padheight $bline] set hcell_blank [::join $h_lines \n] set header_frame $hcell_blank - } else { + } else { set bline [tcl::string::repeat $TSUB $padwidth] set h_lines [lrepeat $rowh $bline] set hcell_blank [::join $h_lines \n] # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi + #frame borders will never display - so use the simplest frametype and don't apply any ansi #puts "===>zerospan hlims: $hlims" set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ @@ -2424,13 +2424,13 @@ tcl::namespace::eval textblock { append part_header $header_frame\n } set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] + set adjusted_lines [list] foreach ln [split $part_header \n] { if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline + lappend adjusted_lines $padline } else { lappend adjusted_lines $ln } @@ -2496,7 +2496,7 @@ tcl::namespace::eval textblock { set cell_ansibase "" set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row + set ansiborder_final $ansiborder_body_col_row #$c will always have ansi resets due to overtype behaviour ? #todo - review overtype if {[punk::ansi::ta::detect $c]} { @@ -2514,7 +2514,7 @@ tcl::namespace::eval textblock { #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] #puts --->[ansistring VIEW $codes] - + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { #special case double reset at end of content @@ -2527,7 +2527,7 @@ tcl::namespace::eval textblock { set cell_ansibase $cell_ansi_tail } else { #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase } } else { if {$ftblock} { @@ -2555,7 +2555,7 @@ tcl::namespace::eval textblock { } else { set bmap $topmap if {$do_show_header} { - set blims $blims_top + set blims $blims_top } else { set blims $blims_top_headerless } @@ -2631,7 +2631,7 @@ tcl::namespace::eval textblock { } else { set output $part_body } - return $output + return $output } else { return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] } @@ -2652,15 +2652,15 @@ tcl::namespace::eval textblock { } error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" } - #assert cidx is integer >=0 - set num_header_rows [my header_count] - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] set ansibase_col [tcl::dict::get $cdef -ansibase] set textalign [tcl::dict::get $cdef -textalign] switch -- $textalign { left {set pad right} - right {set pad left} + right {set pad left} default { set pad "centre" ;#todo? } @@ -2684,7 +2684,7 @@ tcl::namespace::eval textblock { # lappend configured_widths [my column_width_configured $c] #} - set output [tcl::dict::create] + set output [tcl::dict::create] tcl::dict::set output headers [list] set showing_vseps [my Showing_vseps] @@ -2720,10 +2720,10 @@ tcl::namespace::eval textblock { set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerrow_colspans $cidx] + set this_span [lindex $headerrow_colspans $cidx] - #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] @@ -2734,7 +2734,7 @@ tcl::namespace::eval textblock { set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top set hval_block [::join $hval_lines \n] set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell + tcl::dict::lappend output headers $hcell } @@ -2758,7 +2758,7 @@ tcl::namespace::eval textblock { set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { set rowh $rowdefminh ;#an exact height is defined for the row } else { if {$rowdefminh eq ""} { @@ -2780,7 +2780,7 @@ tcl::namespace::eval textblock { } } } - + set cell_lines [lrepeat $rowh $cell_line_blank] #set cell_blank [join $cell_lines \n] @@ -2792,7 +2792,7 @@ tcl::namespace::eval textblock { set cval_lines [lrange $cval_lines 0 $rowh-1] set cval_block [::join $cval_lines \n] - #//JMN assert widest cval_line = datawidth = known_blockwidth + #//JMN assert widest cval_line = datawidth = known_blockwidth set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] tcl::dict::lappend output cells $cell @@ -2817,7 +2817,7 @@ tcl::namespace::eval textblock { #[call class::table [method debug]] #[para] display lots of debug information about how the table is constructed. - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) set defaults [tcl::dict::create\ -usetables 1\ ] @@ -2836,7 +2836,7 @@ tcl::namespace::eval textblock { puts stdout "rowstates: $o_rowstates" #puts stdout "columndefs: $o_columndefs" puts stdout "columndefs:" - if {!$opt_usetables} { + if {!$opt_usetables} { tcl::dict::for {k v} $o_columndefs { puts " $k $v" } @@ -2849,7 +2849,7 @@ tcl::namespace::eval textblock { continue } $t add_column -headers $property - } + } break } @@ -2858,15 +2858,15 @@ tcl::namespace::eval textblock { set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths tcl::dict::for {col coldef} $o_columndefs { set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] + set colheaders [tcl::dict::get $coldef -headers] #inner table probably overkill here ..but just as easy set htable [textblock::class::table new] $htable configure -show_header 1 -show_edge 0 -show_hseps 0 $htable add_column -headers row $htable add_column -headers text $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 + $htable add_column -headers span + set hnum 0 set spans [tcl::dict::get $o_columndefs $col -header_colspans] foreach h $colheaders s $spans { lassign [textblock::size $h] _w width _h height @@ -2881,7 +2881,7 @@ tcl::namespace::eval textblock { if {$w > [tcl::dict::get $max_widths $icol]} { tcl::dict::set max_widths $icol $w } - incr icol + incr icol } } @@ -2899,7 +2899,7 @@ tcl::namespace::eval textblock { tcl::dict::for {innercol maxw} $max_widths { $htable configure_column $innercol -minwidth $maxw -blockalign left } - lappend row [$htable print] + lappend row [$htable print] $htable destroy } default { @@ -2923,7 +2923,7 @@ tcl::namespace::eval textblock { tcl::dict::for {k coldef} $o_columndefs { if {[tcl::dict::exists $o_columndata $k]} { set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] + set coldata [tcl::dict::get $o_columndata $k] set colinfo "rowcount: [llength $coldata]" set allfields [concat $headerlist $coldata] if {[llength $allfields]} { @@ -2944,7 +2944,7 @@ tcl::namespace::eval textblock { if {$c == 0} { lappend cols [my get_column_by_index $c -position left] " " } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] + lappend cols [my get_column_by_index $c -position right] } else { lappend cols [my get_column_by_index $c -position inner] " " } @@ -3089,7 +3089,7 @@ tcl::namespace::eval textblock { lappend configured_widths [my column_width_configured $c] } set header_colspans [my header_colspans] - set width_max $colwidth + set width_max $colwidth set test_width $colwidth set showing_vseps [my Showing_vseps] set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] @@ -3125,7 +3125,7 @@ tcl::namespace::eval textblock { if {$showing_vseps} { incr others_width 1 } - } + } set total_spanned_width [expr {$width_max + $others_width}] if {$thiscol_widest_header > $total_spanned_width} { #this just allocates the extra space in the current column - which is not great. @@ -3172,9 +3172,9 @@ tcl::namespace::eval textblock { return true } } - return false + return false } - + method column_datawidth {index_expression args} { set opts [tcl::dict::create\ -headers 0\ @@ -3289,11 +3289,11 @@ tcl::namespace::eval textblock { set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] set widest [expr {max($valwidest,$hwidest)}] } else { - set widest $hwidest + set widest $hwidest } return $widest } - #print1 uses basic column joining - useful for testing/debug especially with colspans + #print1 uses basic column joining - useful for testing/debug especially with colspans method print1 {args} { if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3338,15 +3338,15 @@ tcl::namespace::eval textblock { incr colposn } if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] + return [textblock::join -- {*}$blocks] } else { return "No columns matched" } } method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr set colspace_added [tcl::dict::create] - + set ordered_spans [tcl::dict::create] tcl::dict::for {col spandata} [my spangroups] { set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] @@ -3363,7 +3363,7 @@ tcl::namespace::eval textblock { } } tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 + tcl::dict::set colspace_added $col 0 set spanlengths [tcl::dict::get $spandata spanlengths] foreach slen $spanlengths { @@ -3373,13 +3373,13 @@ tcl::namespace::eval textblock { set hwidth [tcl::dict::get $s headerwidth] set hrow [tcl::dict::get $s hrow] set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth } } } - #safe jumptable test + #safe jumptable test #dict for {spanid spandata} $ordered_spans {} tcl::dict::for {spanid spandata} $ordered_spans { lassign [split $spanid ,] startcol hrow @@ -3390,7 +3390,7 @@ tcl::namespace::eval textblock { if {$num_cols_spanned == 1} { set col [lindex $memcols 0] set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { + if {$space_to_alloc > 0} { set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] if {$maxwidth ne ""} { if {$maxwidth > [tcl::dict::get $colwidths $col]} { @@ -3400,7 +3400,7 @@ tcl::namespace::eval textblock { } set will_alloc [expr {min($space_to_alloc,$can_alloc)}] } else { - set will_alloc $space_to_alloc + set will_alloc $space_to_alloc } if {$will_alloc} { #tcl::dict::set colwidths $col $hwidth @@ -3422,12 +3422,12 @@ tcl::namespace::eval textblock { if {[my Showing_vseps]} { set sepcount [expr {$num_cols_spanned -1}] incr space_to_alloc -$sepcount - } + } #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added switch -- $allocmethod { least { #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3445,10 +3445,10 @@ tcl::namespace::eval textblock { } } least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth #(we should be able to collapse column width to zero and have header colspans gracefully respond) #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3485,7 +3485,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3521,7 +3521,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3533,10 +3533,10 @@ tcl::namespace::eval textblock { } - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] } - #spangroups keyed by column + #spangroups keyed by column method spangroups {} { #*** !doctools #[call class::table [method spangroups]] @@ -3550,8 +3550,8 @@ tcl::namespace::eval textblock { tcl::dict::set spangroups $c [list spanlengths {}] set spanlist [my column_get_spaninfo $c] set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist while {[llength $ungrouped]} { set spanlen [lindex $ungrouped 0 $index_spanlen_val] @@ -3569,14 +3569,14 @@ tcl::namespace::eval textblock { tcl::dict::set headerwidths $hcol,$hrow $hwidth } lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo + lappend sgroup $spaninfo } set spanlengths [tcl::dict::get $spangroups $c spanlengths] lappend spanlengths $spanlen tcl::dict::set spangroups $c spanlengths $spanlengths tcl::dict::set spangroups $c spangroups $spanlen $sgroup set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } + } } return $spangroups } @@ -3660,14 +3660,14 @@ tcl::namespace::eval textblock { basic { #basic column by column - This allocates extra space to first span/column as they're encountered. #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. + #The header values can extend over some of the spanned columns - but not optimally so. set o_calculated_column_widths [list] for {set c 0} {$c < $column_count} {incr c} { lappend o_calculated_column_widths [my basic_column_width $c] } } simplistic { - #just uses the widest column data or header element. + #just uses the widest column data or header element. #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column #This is a conservative option potentially useful in testing/debugging. set o_calculated_column_widths [list] @@ -3676,7 +3676,7 @@ tcl::namespace::eval textblock { } } span { - #widest of smallest spans first method + #widest of smallest spans first method #set calcresult [my columncalc_spans least] set calcresult [my columncalc_spans least_unmaxed] set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] @@ -3695,7 +3695,7 @@ tcl::namespace::eval textblock { return $o_calculated_column_widths } method print2 {args} { - variable full_column_cache + variable full_column_cache set full_column_cache [tcl::dict::create] if {![llength $args]} { @@ -3749,10 +3749,10 @@ tcl::namespace::eval textblock { tcl::dict::set full_column_cache $c $columninfo } set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] @@ -3762,12 +3762,12 @@ tcl::namespace::eval textblock { #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3787,7 +3787,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3839,7 +3839,7 @@ tcl::namespace::eval textblock { } set blocks [list] set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set table "" foreach c $cols { @@ -3855,20 +3855,20 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3888,7 +3888,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3916,7 +3916,7 @@ tcl::namespace::eval textblock { method print {args} { #*** !doctools #[call class::table [method print]] - #[para] Return the table as text suitable for console display + #[para] Return the table as text suitable for console display if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3944,7 +3944,7 @@ tcl::namespace::eval textblock { } } set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set header_build "" set body_blocks [list] @@ -3962,7 +3962,7 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] set headerheight [tcl::dict::get $columninfo headerheight] #set nextcol_lines [split $nextcol \n] #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] @@ -3971,7 +3971,7 @@ tcl::namespace::eval textblock { set nextcol_body [tcl::dict::get $columninfo body] if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header + set header_build $nextcol_header } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] @@ -3979,7 +3979,7 @@ tcl::namespace::eval textblock { #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } lappend body_blocks $nextcol_body - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {![llength $body_blocks]} { @@ -4014,7 +4014,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -4039,11 +4039,11 @@ tcl::namespace::eval textblock { method print_bodymatrix {} { #*** !doctools #[call class::table [method print_bodymatrix]] - #[para] output the matrix string corresponding to the body data using the matrix 2string format + #[para] output the matrix string corresponding to the body data using the matrix 2string format #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. # - + set m [my as_matrix] $m format 2string @@ -4098,7 +4098,7 @@ tcl::namespace::eval textblock { return $t } - #more complex colspans + #more complex colspans proc spantest2 {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} @@ -4137,7 +4137,7 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - @values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { @@ -4163,7 +4163,7 @@ tcl::namespace::eval textblock { " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] + ] set type_colours [list] @@ -4173,71 +4173,71 @@ tcl::namespace::eval textblock { set ansi [a+ {*}$fc web-black Web-gold] set val [list ansi $ansi cat alkaline_earth] foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val + tcl::dict::set ecat $e $val } set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val } set cat [list Li Na K Rb Cs Fr] - #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val } - set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] + set ansi [a+ {*}$fc web-black Web-lightskyblue] set val [list ansi $ansi cat post_transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list B Si Ge As Sb Te At] - #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] + set ansi [a+ {*}$fc web-black Web-orchid] set val [list ansi $ansi cat noble_gases] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] + set ansi [a+ {*}$fc web-black Web-plum] set val [list ansi $ansi cat actinoids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - #set ansi [a+ {*}$fc web-black Web-tan] - set ansi [a+ {*}$fc black Term-tan] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] set val [list ansi $ansi cat lanthanoids] foreach e $cat { tcl::dict::set ecat $e $val } - set ansi [a+ {*}$fc web-black Web-whitesmoke] + set ansi [a+ {*}$fc web-black Web-whitesmoke] set val [list ansi $ansi cat other] foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { tcl::dict::set ecat $e $val @@ -4264,7 +4264,7 @@ tcl::namespace::eval textblock { set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] set c 0 foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 + $t configure_column $c -headers [list $h] -minwidth 2 incr c } set ccount [$t column_count] @@ -4279,7 +4279,7 @@ tcl::namespace::eval textblock { } dict for {k v} $conf { if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] + dict set conf $k [dict get $opts $k] } } @@ -4310,14 +4310,14 @@ tcl::namespace::eval textblock { } proc bookend_lines {block start {end "\x1b\[m"}} { - set out "" + set out "" foreach ln [split $block \n] { append out $start $ln $end \n } return [string range $out 0 end-1] } proc ansibase_lines {block {newprefix ""}} { - set base "" + set base "" set out "" if {$newprefix eq ""} { if {![punk::ansi::ta::detect $block]} { @@ -4340,7 +4340,7 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + set parts [linsert $parts $code_idx+1 $base] } incr code_idx 2 } @@ -4373,7 +4373,7 @@ tcl::namespace::eval textblock { incr offset } incr code_idx 2 - } + } append out {*}$parts \n } return [string range $out 0 end-1] @@ -4398,29 +4398,29 @@ tcl::namespace::eval textblock { Will not be visible if -show_edge is false" -titlealign -type string -choices {left centre right} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ - -help "frame type or dict for custom frame" + -help "frame type or dict for custom frame" -show_edge -default "" -type boolean\ -help "show outer border of table" - -show_seps -default "" -type boolean + -show_seps -default "" -type boolean -show_vseps -default "" -type boolean\ - -help "Show vertical table separators" + -help "Show vertical table separators" -show_hseps -default "" -type boolean\ -help "Show horizontal table separators (default 0 if no existing -table supplied)" -colheaders -default "" -type list\ -help {list of lists. list of column header values. Outer list must match number of columns. - A table + A table e.g single header row: -colheaders {{column_a} {column_b} {column_c}} e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}} Note that each element of the outer list is itself a list so: - -colheaders {"column a" "column b" "column c"} + -colheaders {"column a" "column b" "column c"} Is likely not the right format if it was intended to have a single header row where the column titles contain spaces. The correct syntax for that would be: - -colheaders {{"column a"} {"column b"} {"column c"}} + -colheaders {{"column a"} {"column b"} {"column c"}} For spanning header cells - use 'set t [list_as_table -return tableobject ...]' and then something like: - $t configure_header 1 -colspans {3 0 0}; $t print + $t configure_header 1 -colspans {3 0 0}; $t print } -header -default "" -type list -multiple 1\ -help "Each supplied -header argument is a header row. @@ -4498,14 +4498,14 @@ tcl::namespace::eval textblock { if {[llength $colheaders] < $c+1} { lappend colheaders [lrepeat $r {}] } - set colinfo [lindex $colheaders $c] + set colinfo [lindex $colheaders $c] if {$r > [llength $colinfo]} { set diff [expr {$r - [llength $colinfo]}] lappend colinfo {*}[lrepeat $diff {}] } lappend colinfo $cell lset colheaders $c $colinfo - incr c + incr c } incr r } @@ -4516,15 +4516,15 @@ tcl::namespace::eval textblock { if {![tcl::dict::exists $opts received -show_header]} { set show_header 1 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } } else { if {![tcl::dict::exists $opts received -show_header]} { set show_header 0 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } - } + } if {[tcl::string::is integer -strict $opt_columns]} { set cols $opt_columns @@ -4536,7 +4536,7 @@ tcl::namespace::eval textblock { if {[llength $colheaders]} { set cols [llength $colheaders] } else { - set cols 2 ;#seems a reasonable default + set cols 2 ;#seems a reasonable default } } #defaults for new table only @@ -4605,13 +4605,13 @@ tcl::namespace::eval textblock { if {"-titlealign" in $received} { $t configure -titlealign [dict get $opts -titlealign] } - #puts stdout $rowdata + #puts stdout $rowdata if {[tcl::dict::get $opts -return] eq "table"} { set result [$t print] if {$is_new_table} { $t destroy } - return $result + return $result } else { return $t } @@ -4627,13 +4627,13 @@ tcl::namespace::eval textblock { error "textblock::block blockheight must be a positive integer" } if {$char eq ""} {return ""} - #using tcl::string::length is ok + #using tcl::string::length is ok if {[tcl::string::length $char] == 1} { set row [tcl::string::repeat $char $blockwidth] set mtrx [lrepeat $blockheight $row] return [::join $mtrx \n] } else { - set charblock [tcl::string::map [list \r\n \n] $char] + set charblock [tcl::string::map [list \r\n \n] $char] if {[tcl::string::last \n $charblock] >= 0} { if {$blockwidth > 1} { #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) @@ -4657,7 +4657,7 @@ tcl::namespace::eval textblock { columns wide and size rows tall. (which on a terminal will show as a vertically oriented rectangle due to - cells being taller than their width) + cells being taller than their width) The characters used are 123456789ABCDEF @@ -4681,7 +4681,7 @@ tcl::namespace::eval textblock { The additional pseudo-color 'rainbow' is available. - " + " } proc testblock {args} { @@ -4700,14 +4700,14 @@ tcl::namespace::eval textblock { lappend rainbow_list {37 40} ;#white Black lappend rainbow_list {black Yellow} lappend rainbow_list red - lappend rainbow_list green + lappend rainbow_list green lappend rainbow_list yellow lappend rainbow_list blue lappend rainbow_list purple - lappend rainbow_list cyan + lappend rainbow_list cyan lappend rainbow_list {white Red} - #set rainbow_direction "horizontal" + #set rainbow_direction "horizontal" #set vpos [lsearch $colour vertical] #if {$vpos >= 0} { # set rainbow_direction vertical @@ -4719,11 +4719,11 @@ tcl::namespace::eval textblock { # set colour [lremove $colour $hpos] #} set direction [dict get $argd opts -direction] - + set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + set charsubset [lrange $chars 0 $size-1] if {"noreset" in $colour} { set RST "" } else { @@ -4737,7 +4737,7 @@ tcl::namespace::eval textblock { for {set i 0} {$i <$size} {incr i} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] set ansi [a+ {*}$colour2] - + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } @@ -4748,7 +4748,7 @@ tcl::namespace::eval textblock { } } elseif {"rainbow" in $colour} { #direction must be horizontal - set block "" + set block "" for {set r 0} {$r < $size} {incr r} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] set ansi [a+ {*}$colour2] @@ -4763,7 +4763,7 @@ tcl::namespace::eval textblock { set block [tcl::string::trimright $block \n] return $block } else { - #row first - + #row first - set rows [list] foreach ch $charsubset { lappend rows [tcl::string::repeat $ch $size] @@ -4790,7 +4790,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4799,8 +4799,8 @@ tcl::namespace::eval textblock { if {[tcl::string::last \n $textblock] >= 0} { return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } - return [punk::char::ansifreestring_width $textblock] - } + return [punk::char::ansifreestring_width $textblock] + } #gather info about whether ragged (samewidth each line = false) and min width proc widthinfo {textblock} { #backspaces, vertical tabs ? @@ -4814,7 +4814,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4843,7 +4843,7 @@ tcl::namespace::eval textblock { if {[punk::ansi::ta::detect $tl]} { set tl [punk::ansi::ansistripraw $tl] } - return [punk::char::ansifreestring_width $tl] + return [punk::char::ansifreestring_width $tl] } #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. proc string_length_line_max {textblock} { @@ -4864,7 +4864,7 @@ tcl::namespace::eval textblock { proc height {textblock} { #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) + #empty string still has height 1 (at least for left-right/right-left languages) #vertical tab on a proper terminal should move directly down. #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) @@ -4894,7 +4894,7 @@ tcl::namespace::eval textblock { #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } else { - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -4933,7 +4933,7 @@ tcl::namespace::eval textblock { } } else { set num_le 0 - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -5010,14 +5010,14 @@ tcl::namespace::eval textblock { # -- --- --- --- --- --- --- --- --- --- set padchar [tcl::dict::get $opts -padchar] #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map #The caller may also use ansi within the padchar - although it's unlikely to be efficient. # -- --- --- --- --- --- --- --- --- --- set known_whiches [list l left r right c center centre] set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] switch -- $opt_which { center - centre - c { - set which c + set which c } left - l { set which l @@ -5055,7 +5055,7 @@ tcl::namespace::eval textblock { set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. set datawidth "" if {$width eq "auto"} { - #for auto - we + #for auto - we if {$known_blockwidth eq ""} { if {$known_samewidth ne "" && $known_samewidth} { set datawidth [textblock::widthtopline $block] @@ -5077,7 +5077,7 @@ tcl::namespace::eval textblock { set datawidth [textblock::widthtopline $block] } else { set datawidth $known_blockwidth - } + } } #assert datawidth may still be empty string } @@ -5096,7 +5096,7 @@ tcl::namespace::eval textblock { #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) #we should use overtype with suitable replacement char (space?) for chopped double-wides if {!$pad_has_ansi} { - return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] } else { set base [tcl::string::repeat " " $width] return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] @@ -5105,7 +5105,7 @@ tcl::namespace::eval textblock { #review - tcl format can only pad with zeros or spaces? #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - #review - surprisingly, this doesn't seem to be a performance win + #review - surprisingly, this doesn't seem to be a performance win #No detectable diff on small blocks - slightly worse on large blocks # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position @@ -5144,7 +5144,7 @@ tcl::namespace::eval textblock { set parts [list $block] } - set line_chunks [list] + set line_chunks [list] set line_len 0 set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad foreach {pt ansi} $parts { @@ -5179,7 +5179,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5237,7 +5237,7 @@ tcl::namespace::eval textblock { } #don't let trailing empty ansi affect the line_chunks length if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? } } #pad last line @@ -5251,7 +5251,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5321,7 +5321,7 @@ tcl::namespace::eval textblock { if {$i == $i_last_code} { return [lappend out $str {*}[lrange $ansisplits $i end]] } - #code being empty can only occur when we have reached last pt + #code being empty can only occur when we have reached last pt #we have returned by then. lappend out $code incr i 2 @@ -5338,7 +5338,7 @@ tcl::namespace::eval textblock { set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] + set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] set t [textblock::list_as_table -columns 3 -return tableobject $testlist] $t configure_column 0 -headers [list "ansi"] @@ -5397,20 +5397,20 @@ tcl::namespace::eval textblock { set r3 [list "column\ncolours"] #1 - #test without table padding + #test without table padding #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering #(basically a mechanism to add extra resets at start and end of each line) #dict for {b bdict} $blockinfo { # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] #} #2 - the more useful one? tcl::dict::for {b bdict} $blockinfo { lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] lappend r3 "" "" } @@ -5486,7 +5486,7 @@ tcl::namespace::eval textblock { # >} .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| # >} punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines } punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } + } proc example {args} { @@ -5930,7 +5930,7 @@ tcl::namespace::eval textblock { set RST [a] set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST + set pleft_greenb $greenb$pleft$RST set pright_redb $redb$pright$RST set prightair_cyanb $cyanb$prightair$RST set cpunks [textblock::join -- $pleft_greenb $pright_redb] @@ -6064,7 +6064,7 @@ tcl::namespace::eval textblock { } } } - } + } variable framedef_cache [tcl::dict::create] proc framedef {args} { #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. @@ -6072,7 +6072,7 @@ tcl::namespace::eval textblock { #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. #the arc set can't even join to itself e.g with curved equivalents of T-like shapes - #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. variable framedef_cache set cache_key $args if {[tcl::dict::exists $framedef_cache $cache_key]} { @@ -6115,10 +6115,10 @@ tcl::namespace::eval textblock { if {![llength $rawglobs] || "all" in $rawglobs || "*" in $rawglobs} { set globs * } else { - set globs [list] + set globs [list] foreach g $rawglobs { switch -- $g { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - hltj - hlbj - vllj - vlrj { lappend globs $g } @@ -6150,7 +6150,7 @@ tcl::namespace::eval textblock { } default { #must look like a glob search if not one of the above - if {[regexp {[*?\[\]]} $g]} { + if {[regexp {[*?\[\]]} $g]} { lappend globs $g } else { set bad_option 1 @@ -6174,7 +6174,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - @values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -6191,7 +6191,7 @@ tcl::namespace::eval textblock { set joins [tcl::dict::get $opts -joins] set boxonly [tcl::dict::get $opts -boxonly] - + #sorted order down left right up #1 x choose 4 #4 x choose 3 @@ -6204,7 +6204,7 @@ tcl::namespace::eval textblock { #e.g down-light, up-heavy set join_targets [tcl::dict::create left "" down "" right "" up ""] foreach jt $joins { - lassign [split $jt -] direction target + lassign [split $jt -] direction target if {$target ne ""} { tcl::dict::set join_targets $direction $target } @@ -6234,7 +6234,7 @@ tcl::namespace::eval textblock { #set brc [cd::brc] set brc [punk::ansi::g0 j] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6382,7 +6382,7 @@ tcl::namespace::eval textblock { set trc + set blc + set brc + - #horizontal and vertical bar joins + #horizontal and vertical bar joins #set hltj $hlt #set hlbj $hlb #set vllj $vll @@ -6392,7 +6392,7 @@ tcl::namespace::eval textblock { set hlbj + set vllj + set vlrj + - #our corners are all + already - so we won't do anything for directions or targets + #our corners are all + already - so we won't do anything for directions or targets } "light" { @@ -6408,7 +6408,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_lur] set brc [punk::char::charshort boxd_lul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6423,16 +6423,16 @@ tcl::namespace::eval textblock { #default empty targets to current box type 'light' foreach dir {down left right up} { set rawtarget [tcl::dict::get $join_targets $dir] - lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same + lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same switch -- $target { "" - light { - set target$dir light + set target$dir light } ascii - altg - arc { - set target$dir light + set target$dir light } heavy { - set target$dir $target + set target$dir $target } default { set target$dir other @@ -6504,7 +6504,7 @@ tcl::namespace::eval textblock { other-light { set blc \u2534 ;#(btj) set tlc \u252c ;#(ttj) - #brc - default corner + #brc - default corner set vllj \u2524 ;# (rtj) } other-other { @@ -6546,7 +6546,7 @@ tcl::namespace::eval textblock { light-other { set blc \u251c ;# (ltj) #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) + set brc \u2524 ;# boxd_lvl (rtj) set hlbj \u252c ;# (ttj) } light-heavy { @@ -6682,41 +6682,41 @@ tcl::namespace::eval textblock { light_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } light_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] tcl::dict::with arcframe {} ;#extract keys as vars } "heavy" { @@ -6731,7 +6731,7 @@ tcl::namespace::eval textblock { set trc [punk::char::charshort boxd_hdl] set blc [punk::char::charshort boxd_hur] set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6743,10 +6743,10 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - heavy { - set target$dir heavy + set target$dir heavy } light - ascii - altg - arc { - set target$dir light + set target$dir light } default { set target$dir other @@ -6773,12 +6773,12 @@ tcl::namespace::eval textblock { #2 switch -- $targetleft { light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) set vllj \u2528 ;# left light (rtj) } heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set blc [punk::char::charshort boxd_huhz] ;# (btj) set vllj \u252b ;#(rtj) } @@ -6833,7 +6833,7 @@ tcl::namespace::eval textblock { set vllj \u2528 ;# left light (rtj) } down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) set hlbj \u252F ;# down light (ttj) @@ -6954,41 +6954,41 @@ tcl::namespace::eval textblock { heavy_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } heavy_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] tcl::dict::with arcframe {} ;#extract keys as vars } "double" { @@ -7004,7 +7004,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7163,7 +7163,7 @@ tcl::namespace::eval textblock { } left_right { #8 - + #from 2 #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set tlc \U2566 ;# (ttj) @@ -7254,7 +7254,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7266,7 +7266,7 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - arc { - set target$dir self + set target$dir self } default { set target$dir other @@ -7282,7 +7282,7 @@ tcl::namespace::eval textblock { set blc \u251c ;# *light (ltj) #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal #set brc \u2524 ;# *light(rtj) #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) @@ -7354,41 +7354,41 @@ tcl::namespace::eval textblock { arc_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } arc_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] tcl::dict::with arcframe {} ;#extract keys as vars } block1 { @@ -7402,7 +7402,7 @@ tcl::namespace::eval textblock { set blc \u2594 ;# upper one eighth block set brc \u2594 ;# upper one eight block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7410,7 +7410,7 @@ tcl::namespace::eval textblock { } block2 { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7425,7 +7425,7 @@ tcl::namespace::eval textblock { set trc \U1fb7e ;#legacy block set blc \U1fb7c ;#legacy block set brc \U1fb7f ;#legacy block - + if {(![interp issafe])} { if {![catch {punk::console::check::has_bug_legacysymbolwidth} symbug] && $symbug} { #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems @@ -7437,7 +7437,7 @@ tcl::namespace::eval textblock { } } - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7445,7 +7445,7 @@ tcl::namespace::eval textblock { } block2hack { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7466,7 +7466,7 @@ tcl::namespace::eval textblock { # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs + #except that the punk overtype library does recognise PMs #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block @@ -7474,7 +7474,7 @@ tcl::namespace::eval textblock { set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7491,7 +7491,7 @@ tcl::namespace::eval textblock { set blc \u2599 set brc \u259f - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7526,9 +7526,9 @@ tcl::namespace::eval textblock { set $t [tcl::dict::get $custom_frame $t] } else { #set more explicit type to it's more general counterpart if it's missing - #e.g hlt -> hl - #e.g hltj -> hlt - set $t [set [string range $t 0 end-1]] + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] } } #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set @@ -7671,14 +7671,14 @@ tcl::namespace::eval textblock { tcl::dict::for {k v} $display_dict { lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? #set fwidth [textblock::width $frame] set frameinfo "$k used:$used " set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] if {$allinone_width >= $termwidth} { #split across 2 lines - append out "$frameinfo\n" + append out "$frameinfo\n" append out $frame \n } else { append out [textblock::join -- $frameinfo $frame]\n @@ -7707,7 +7707,7 @@ tcl::namespace::eval textblock { set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] return $FRAMETYPELABELS } - #proc EG {} "return {[a+ brightblack]}" + #proc EG {} "return {[a+ brightblack]}" #make EG fetch from SGR cache so as to abide by colour off/on proc EG {} { a+ brightblack @@ -7729,7 +7729,7 @@ tcl::namespace::eval textblock { -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and provide more comprehensive error info. - Set false for slight performance improvement." + Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ @@ -7741,10 +7741,10 @@ tcl::namespace::eval textblock { passing an empty string will result in no box, but title/subtitle will still appear if supplied. ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict - -joins -default {} -type list + -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. - May contain ANSI - no trailing reset required. + May contain ANSI - no trailing reset required. ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" -titlealign -default "centre" -choices {left centre right} @@ -7778,7 +7778,7 @@ tcl::namespace::eval textblock { -help "Show ANSI control characters within frame contents. (Control Representation Mode) Frame width doesn't adapt and content may be truncated - so -width may need to be manually set to display more." + so -width may need to be manually set to display more." @values -min 0 -max 1 contents -default "" -type string\ @@ -7793,7 +7793,7 @@ tcl::namespace::eval textblock { # #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it # - but we would need to maintain support for the rendered-string based operations too. proc frame {args} { @@ -7828,8 +7828,8 @@ tcl::namespace::eval textblock { # for ansi art - -pad 0 is likely to be preferable set has_contents 0 - set optlist $args ;#initial only - content will be removed - #no solo opts for frame + set optlist $args ;#initial only - content will be removed + #no solo opts for frame if {[llength $args] %2 == 0} { if {[lindex $args end-1] eq "--"} { set contents [lpop optlist end] @@ -7843,7 +7843,7 @@ tcl::namespace::eval textblock { set contents [lpop optlist end] set has_contents 1 } - + #todo args -justify left|centre|right (center) #todo -blockalignbias -textalignbias? #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache @@ -7852,12 +7852,12 @@ tcl::namespace::eval textblock { foreach {k v} $optlist { set k2 [tcl::prefix::match -error "" $optnames $k] switch -- $k2 { - -etabs - -type - -boxlimits - -boxmap - -joins + -etabs - -type - -boxlimits - -boxmap - -join - -title - -titlealign - -subtitle - -subtitlealign - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -crm_mode - - -usecache - -buildcache - -pad + - -usecache - -buildcache - -pad - -checkargs { tcl::dict::set opts $k2 $v } @@ -7878,21 +7878,21 @@ tcl::namespace::eval textblock { set contents [dict get $argd values contents] } - # -- --- --- --- --- --- + # -- --- --- --- --- --- # cache relevant set opt_usecache [tcl::dict::get $opts -usecache] set opt_buildcache [tcl::dict::get $opts -buildcache] set usecache $opt_usecache ;#may need to override set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination set opt_crm_mode [tcl::dict::get $opts -crm_mode] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_type [tcl::dict::get $opts -type] set opt_boxlimits [tcl::dict::get $opts -boxlimits] set opt_joins [tcl::dict::get $opts -joins] set opt_boxmap [tcl::dict::get $opts -boxmap] set buildcache $opt_buildcache set opt_pad [tcl::dict::get $opts -pad] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_title [tcl::dict::get $opts -title] set opt_subtitle [tcl::dict::get $opts -subtitle] set opt_width [tcl::dict::get $opts -width] @@ -7930,7 +7930,7 @@ tcl::namespace::eval textblock { ##e.g down-light, up-heavy #set join_targets [tcl::dict::create left "" down "" right "" up ""] #foreach jt $opt_joins { - # lassign [split $jt -] direction target + # lassign [split $jt -] direction target # if {$target ne ""} { # tcl::dict::set join_targets $direction $target # } @@ -8056,10 +8056,10 @@ tcl::namespace::eval textblock { set FSUB \uF2DD - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see + #set buildcache 0 ;#comment out for debug/analysis so we can see #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" set cache_key [a+ Web-red web-white]$cache_key[a] } @@ -8069,7 +8069,7 @@ tcl::namespace::eval textblock { #we can still substitute with right length set cache_key [a+ Web-steelblue web-black]$cache_key[a] } else { - #actual_contentwidth is narrower than frame - check template's patternwidth + #actual_contentwidth is narrower than frame - check template's patternwidth if {[tcl::dict::exists $frame_cache $cache_key]} { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] } else { @@ -8096,7 +8096,7 @@ tcl::namespace::eval textblock { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] set template [tcl::dict::get $frame_cache $cache_key frame] set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record set is_cached 1 } @@ -8107,7 +8107,7 @@ tcl::namespace::eval textblock { # -- --- --- --- --- set is_joins_ok 1 foreach v $opt_joins { - lassign [split $v -] direction target + lassign [split $v -] direction target switch -- $direction { left - right - up - down {} default { @@ -8126,7 +8126,7 @@ tcl::namespace::eval textblock { if {!$is_joins_ok} { error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set is_boxmap_ok 1 tcl::dict::for {boxelement subst} $opt_boxmap { switch -- $boxelement { @@ -8139,9 +8139,9 @@ tcl::namespace::eval textblock { } } if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" + error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #these are all valid commands for overtype:: switch -- $opt_textalign { left - right - centre - center {} @@ -8149,7 +8149,7 @@ tcl::namespace::eval textblock { error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" } } - # -- --- --- --- --- --- + # -- --- --- --- --- --- switch -- $opt_blockalign { left - right - centre - center {} default { @@ -8217,7 +8217,7 @@ tcl::namespace::eval textblock { switch -- $frameset { custom { #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely set vll_width [punk::ansi::printing_length $vll] set hlb_width [punk::ansi::printing_length $hlb] @@ -8235,8 +8235,8 @@ tcl::namespace::eval textblock { if {$opt_width eq ""} { #width wasn't specified - so user is expecting frame to adapt to title/contents #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] } else { @@ -8281,14 +8281,14 @@ tcl::namespace::eval textblock { set tbar [tcl::string::repeat $hlt $frame_inner_width] #set tbar [cd::groptim $tbar] set tbar [punk::ansi::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] + set bbar [tcl::string::repeat $hlb $frame_inner_width] #set bbar [cd::groptim $bbar] set bbar [punk::ansi::groptim $bbar] } default { set tbar [tcl::string::repeat $hlt $frame_inner_width] set bbar [tcl::string::repeat $hlb $frame_inner_width] - + } } @@ -8467,7 +8467,7 @@ tcl::namespace::eval textblock { #after overtype::block - our actual patternwidth may be less set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - if {$leftborder && $rightborder} { + if {$leftborder && $rightborder} { #set bodyparts [list $lhs $inner $rhs] set cache_bodyparts [list $lhs $cache_inner $rhs] } else { @@ -8522,12 +8522,12 @@ tcl::namespace::eval textblock { } set template $fscached ;#end !$is_cached - } + } - #use the same mechanism to build the final frame - whether from cache or template + #use the same mechanism to build the final frame - whether from cache or template if {$actual_contentwidth == 0} { set fs [tcl::string::map [list $FSUB " "] $template] } else { @@ -8549,7 +8549,7 @@ tcl::namespace::eval textblock { #set cwidth [textblock::width $contents] set cwidth $actual_contentwidth if {$opt_pad} { - set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) set paddedwidth [textblock::widthtopline $paddedcontents] #review - horizontal truncation if {$paddedwidth > $cache_patternwidth} { @@ -8590,7 +8590,7 @@ tcl::namespace::eval textblock { if {$is_cached} { - return $fs + return $fs } else { if {$buildcache} { tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] @@ -8621,9 +8621,9 @@ tcl::namespace::eval textblock { set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size + set fit_size $size if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size + set max_cross_size $fit_size } else { #todo - only allow divisors #set testsize [expr {min($fit_size,$opt_max_cross_size)}] @@ -8651,7 +8651,7 @@ tcl::namespace::eval textblock { set onecross "" set crossrows [list] set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] + set row [lrepeat $max_cross_size " "] #toparm for {set i 0} {$i < $armsize} {incr i} { set r $row @@ -8692,7 +8692,7 @@ tcl::namespace::eval textblock { return $out } - #Test we can join two coloured blocks + #Test we can join two coloured blocks proc test_colour {} { set b1 [a red]1\n2\n3[a] set b2 [a green]a\nb\nc[a] @@ -8716,10 +8716,10 @@ interp alias {} piper_blockjoin {} ::textblock::piper::join # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide textblock [tcl::namespace::eval textblock { variable version - set version 0.1.3 + set version 0.1.3 }] return diff --git a/src/bootsupport/modules/zipper-0.12.tm b/src/bootsupport/modules/zipper-0.12.tm index 080e7da9..1983211c 100644 Binary files a/src/bootsupport/modules/zipper-0.12.tm and b/src/bootsupport/modules/zipper-0.12.tm differ 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 3d1d87e9..5b45b2bc 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 @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] #[copyright "2024"] #[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::aliascore] #[keywords module alias] #[description] @@ -98,7 +98,7 @@ package require Tcl 8.6- # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::aliascore { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable aliases #use absolute ns ie must be prefixed with :: #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased @@ -136,7 +136,7 @@ tcl::namespace::eval punk::aliascore { #*** !doctools #[subsection {Namespace punk::aliascore}] - #[para] Core API functions for punk::aliascore + #[para] Core API functions for punk::aliascore #[list_begin definitions] @@ -144,13 +144,13 @@ tcl::namespace::eval punk::aliascore { #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" #} #todo - options as to whether we should raise an error if collisions found, undo aliases etc? @@ -208,13 +208,13 @@ tcl::namespace::eval punk::aliascore { #todo - ensure exported? noclobber? if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { #puts stderr "importing $cmd" - tcl::namespace::eval :: [list namespace import $cmd] + tcl::namespace::eval :: [list namespace import $cmd] } else { #target command name differs from exported name #e.g stripansi -> punk::ansi::ansistrip #import and rename #puts stderr "importing $cmd (with rename to ::$a)" - tcl::namespace::eval $tempns [list namespace import $cmd] + tcl::namespace::eval $tempns [list namespace import $cmd] catch {rename ${tempns}::[namespace tail $cmd] ::$a} } } else { @@ -242,18 +242,18 @@ tcl::namespace::eval punk::aliascore { # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::aliascore::lib { - namespace export {[a-z]*} ;# Convention: export all lowercase + namespace export {[a-z]*} ;# Convention: export all lowercase namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::aliascore::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 + # #[para]Description of utility1 + # return 1 #} @@ -271,17 +271,17 @@ namespace eval punk::aliascore::lib { namespace eval punk::aliascore::system { #*** !doctools #[subsection {Namespace punk::aliascore::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::aliascore [namespace eval punk::aliascore { variable pkg punk::aliascore 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/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 b367be2a..50ea5082 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 @@ -19,21 +19,21 @@ #[manpage_begin punkshell_module_punk::ansi 0 0.1.1] #[copyright "2023"] #[titledesc {Ansi string functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] +#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] #[require punk::ansi] #[keywords module ansi terminal console string] #[description] -#[para]Ansi based terminal control string functions -#[para]See [package punk::ansi::console] for related functions for controlling a console +#[para]Ansi based terminal control string functions +#[para]See [package punk::ansi::console] for related functions for controlling a console # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Overview] -#[para] overview of punk::ansi +#[para] overview of punk::ansi #[para]punk::ansi functions return their values - no implicit emission to console/stdout #[subsection Concepts] -#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner +#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner #[para]There are many differences in terminal implementations - but most should support a core set of features #[para]punk::ansi does not contain any code for direct terminal manipulation via the local system APIs. #[para]Sticking to ansi codes where possible may be better for cross-platform and remote operation where such APIs are unlikely to be useable. @@ -45,7 +45,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::ansi +#[para] packages used by punk::ansi #[list_begin itemized] package require Tcl 8.6- @@ -72,7 +72,7 @@ tcl::namespace::eval punk::ansi::class { if {![llength [tcl::info::commands class_ansi]]} { oo::class create class_ansi { - variable o_ansistringobj + variable o_ansistringobj variable o_render_dimensions ;#last dimensions at which we rendered variable o_rendered @@ -83,7 +83,7 @@ tcl::namespace::eval punk::ansi::class { } #a straight string compare may be faster.. but a checksum is much smaller in memory, so we'll use that by default. - set o_rendered_what "" + set o_rendered_what "" #There may also be advantages to renering to a class_ansistring class object set o_render_dimensions $dimensions @@ -100,7 +100,7 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set cksum "not-done" - if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { + if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { #some ansi layout/art relies on wrapping at the width-dimension to display properly #this includes cursor movements ie right arrow can move cursor to columns in lines below #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. @@ -111,7 +111,7 @@ tcl::namespace::eval punk::ansi::class { #if dimensions changed - the checksum won't have been done set o_rendered_what [$o_ansistringobj checksum] } else { - set o_rendered_what $cksum + set o_rendered_what $cksum } set o_render_dimensions $dimensions } @@ -127,8 +127,8 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set o_dimensions $dimensions - - + + set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } @@ -185,12 +185,12 @@ tcl::namespace::eval punk::ansi::class { set lfvis [ansistring VIEW -lf 1 \n] set maplf [list \n "[a+ green bold reverse]${lfvis}[a]\n"] ;#a mapping to highlight newlines - set lines [split [$o_ansistringobj get] \n] + set lines [split [$o_ansistringobj get] \n] set rlines [lrange $lines 0 $x] - set chunk [::join $rlines \n] + set chunk [::join $rlines \n] append chunk \n if {$opt_minus ne "0"} { - set chunk [tcl::string::range $chunk 0 end-$opt_minus] + 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 marker "" @@ -212,7 +212,7 @@ tcl::namespace::eval punk::ansi::class { 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 + #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 renderheight [llength [split $rendered \n]] set chunkdisplay_lines [split $chunkdisplay \n] @@ -221,7 +221,7 @@ tcl::namespace::eval punk::ansi::class { #the input chunk lines are often much longer than the output.. resulting in main content being way up the screen. It's often impractical to view more than the tail of the chunkdisplay. textblock::join -- $rendered $chunkdisplay_block } - + method checksum {} { return [$o_ansistringobj checksum] } @@ -237,7 +237,7 @@ tcl::namespace::eval punk::ansi::class { -lf 0\ -vt 0\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -267,7 +267,7 @@ tcl::namespace::eval punk::ansi::class { method viewchars {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -295,7 +295,7 @@ tcl::namespace::eval punk::ansi::class { method viewstyle {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -338,20 +338,20 @@ tcl::namespace::eval punk::ansi::class { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ansi { - variable PUNKARGS + variable PUNKARGS #*** !doctools #[subsection {Namespace punk::ansi}] - #[para] Core API functions for punk::ansi + #[para] Core API functions for punk::ansi #[list_begin definitions] - #old-school ansi graphics - C0 control glyphs. - variable cp437_map + #old-school ansi graphics - C0 control glyphs. + variable cp437_map #for cp437 images we need to map these *after* splitting ansi, to single-width unicode chars #It would also probably be problematic to map \u000A to the glyph - as this is the newline - it included in the map anyway for completeness. The caller may have to manually carve that or other specific c0 controls out of the map to use it depending on the situation(?) #Layout for cp437 won't be right if you don't at least set width of control-chars to 1 - but also some images specifically use these glyphs - #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too + #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too #by mapping these we can display regardless. - #nul char - no cp437 image but commonly used as space in ansi graphics. + #nul char - no cp437 image but commonly used as space in ansi graphics. #(This is a potential conflict because we use nul as a filler to mean empty column in overtype rendering) REVIEW tcl::dict::set cp437_map \u0000 " " ;#space tcl::dict::set cp437_map \u0001 \u263A ;#smiley @@ -377,11 +377,11 @@ tcl::namespace::eval punk::ansi { tcl::dict::set cp437_map \u0015 \u00A7 ;#Section Sign tcl::dict::set cp437_map \u0016 \u25AC ;#Heavy horizontal? tcl::dict::set cp437_map \u0017 \u21A8 ;#updown arrow 2 ? - tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow - tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow - tcl::dict::set cp437_map \u001A \u2192 ;#right arrow - tcl::dict::set cp437_map \u001B \u2190 ;#left arrow - tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner + tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow + tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow + tcl::dict::set cp437_map \u001A \u2192 ;#right arrow + tcl::dict::set cp437_map \u001B \u2190 ;#left arrow + tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner tcl::dict::set cp437_map \u001D \u2194 ;#left-right arrow tcl::dict::set cp437_map \u001E \u25B2 ;#up arrow triangle tcl::dict::set cp437_map \u001F \u25BC ;#down arrow triangle @@ -396,7 +396,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics c \u240c ;#symbol for FF tcl::dict::set map_special_graphics d \u240d ;#symbol for CR tcl::dict::set map_special_graphics e \u240a ;#symbol for LF - tcl::dict::set map_special_graphics f \u00b0 ;#degree sign + tcl::dict::set map_special_graphics f \u00b0 ;#degree sign tcl::dict::set map_special_graphics g \u00b1 ;#plus-minus sign tcl::dict::set map_special_graphics h \u2424 ;#symbol for NL tcl::dict::set map_special_graphics i \u240b ;#symbol for VT @@ -408,8 +408,8 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics o \u23ba ;#horizontal scan line-1 tcl::dict::set map_special_graphics p \u23bb ;#horizontal scan line-3 tcl::dict::set map_special_graphics q \u2500 ;#light horizontal - box drawing - tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 - tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 + tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 + tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 tcl::dict::set map_special_graphics t \u251c ;#light vertical and right - box drawing tcl::dict::set map_special_graphics u \u2524 ;#light vertical and left - box drawing tcl::dict::set map_special_graphics v \u2534 ;#light up and horizontal - box drawing @@ -419,10 +419,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics z \u2265 ;#greater than or equal tcl::dict::set map_special_graphics "\{" \u03c0 ;#greek small letter pi tcl::dict::set map_special_graphics "|" \u2260 ;#not equal to - tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign + tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign tcl::dict::set map_special_graphics ~ \u00b7 ;#middle dot - #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control + #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control variable test "blah\033\[1;33mETC\033\[0;mOK" @@ -451,14 +451,14 @@ tcl::namespace::eval punk::ansi { 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\\ \u009c] ;#note mix of 1 and 2-byte terminals + #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\\ \u009c] ;#note mix of 1 and 2-byte terminals tcl::dict::set escape_terminals DCS [list \007 \033\\ \u009c] tcl::dict::set escape_terminals MISC [list \007 \033\\ \u009c] - #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) + #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) #This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows? - #review - there doesn't seem to be an \x1b#7 + #review - there doesn't seem to be an \x1b#7 # https://espterm.github.io/docs/VT100%20escape%20codes.html #self-contained 2 byte ansi escape sequences - review more? @@ -479,9 +479,9 @@ tcl::namespace::eval punk::ansi { #comparitive test (performance) string-append vs 2-object (with existing splits) append proc test_cat1 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -492,13 +492,13 @@ tcl::namespace::eval punk::ansi { $s2 destroy #$s1 append \033\[31mX ;#redX - return $s1 + return $s1 } proc test_cat2 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -513,12 +513,12 @@ tcl::namespace::eval punk::ansi { # -------------------------------------- - #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? + #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? #In testing old ansi graphics files available on the web, some files need encoding {utf-8 cp437} some just cp437 proc readfile {fname {encoding cp437}} { - #todo + #todo #1- look for BOM - read according to format given by BOM - #2- assume utf-8 + #2- assume utf-8 #3- if errors - assume cp437? if {[llength $encoding] == 1} { @@ -605,7 +605,7 @@ tcl::namespace::eval punk::ansi { Defaults to /src/testansi - where projectbase is determined from the current directory. " - @values -min 0 -max -1 + @values -min 0 -max -1 files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help\ "List of filenames - leave empty to display 4 defaults" } ""] @@ -620,7 +620,7 @@ tcl::namespace::eval punk::ansi { set fnames [dict get $argd values files] #assumes fixed column widths e.g 80col images will fit in 82-width frames (common standard for old ansi art) (of arbitrary height) - #todo - review dependency on punk::repo ? + #todo - review dependency on punk::repo ? package require textblock package require punk::repo package require punk::console @@ -630,13 +630,13 @@ tcl::namespace::eval punk::ansi { puts stderr "Ensure ansi test files exist: $fnames" #error "punk::ansi::example Cannot find example files" } - set termsize [punk::console:::get_size] + set termsize [punk::console:::get_size] set termcols [dict get $termsize columns] set margin 4 ;#review set freewidth [expr {$termcols-$margin}] if {$freewidth < $colwidth} { puts stderr "[a+ red bold]punk::ansi::example freewidth: $freewidth < colwidth: $colwidth TRUNCATING IMAGES[a]" - set colwidth $freewidth + set colwidth $freewidth } set per_row [expr {$freewidth / $colwidth}] @@ -655,7 +655,7 @@ tcl::namespace::eval punk::ansi { #set img [join [lines_as_list -line trimline -block trimtail [ansicat $filepath]] \n] #-line trimline will wreck some images set img [join [lines_as_list -block trimtail [ansicat $filepath]] \n] - lappend pics [tcl::dict::create filename $f pic $img status ok] + lappend pics [tcl::dict::create filename $f pic $img status ok] } } @@ -670,13 +670,13 @@ tcl::namespace::eval punk::ansi { foreach picinfo $pics { set subtitle "" if {[tcl::dict::get $picinfo status] ne "ok"} { - set subtitle [tcl::dict::get $picinfo status] + set subtitle [tcl::dict::get $picinfo status] } set title [tcl::dict::get $picinfo filename] set fr [textblock::frame -checkargs 0 -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] - # -- --- --- --- + # -- --- --- --- #we need the max height of a row element to use join_basic instead of join below - # -- --- --- --- + # -- --- --- --- set fr_height [textblock::height $fr] lappend row $fr lappend rowh $fr_height @@ -691,8 +691,8 @@ tcl::namespace::eval punk::ansi { set rowmax $fr_height lset maxheights end $rowmax } - } - # -- --- --- --- + } + # -- --- --- --- if {$i % $per_row == 0} { lappend rowlist $row @@ -718,9 +718,9 @@ tcl::namespace::eval punk::ansi { if {$h < $maxheight} { #add blank lines to bottom of shorter images so join_basic can be used. #textblock::join of ragged-height images would work and remove the need for all the height calculation - #.. but it requires much more processing + #.. but it requires much more processing append i [string repeat \n$blankline [expr {$maxheight - $h}]] - } + } lappend adjusted_row $i } append result [textblock::join_basic -- {*}$adjusted_row] \n @@ -746,12 +746,12 @@ tcl::namespace::eval punk::ansi { #b) DEVICE CONTROL STRING (DCS) #c) OPERATING SYSTEM COMMAND (OSC) #d) PRIVACY MESSAGE (PM) - #e) START OF STRING (SOS) + #e) START OF STRING (SOS) # #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ - #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. + #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. #todo - review - printing_length calculations affected by whether terminal honours PMs or not. detect and accomodate. #review - can terminals handle SGR codes within a PM? #Wezterm will hide PM,SOS,APC - but not any part following an SGR code - i.e it seems to terminate hiding before the ST (apparently at the ) @@ -779,7 +779,7 @@ tcl::namespace::eval punk::ansi { #candidate for zig/c implementation? proc stripansi2 {text} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters join [::punk::ansi::ta::split_at_codes $text] "" } @@ -793,7 +793,7 @@ tcl::namespace::eval punk::ansi { #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - #set re {\033\(0[^\033]*\033\(B} + #set re {\033\(0[^\033]*\033\(B} #set re {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} #set re2 {\033\(0(.*)\033\(B} ;#capturing @@ -806,9 +806,9 @@ tcl::namespace::eval punk::ansi { #don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this. - set re_g0_open_or_close {\x1b\(0|\x1b\(B} + set re_g0_open_or_close {\x1b\(0|\x1b\(B} set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text] - set out {} + set out {} set g0_on 0 foreach {other g} $parts { if {$g0_on} { @@ -838,7 +838,7 @@ tcl::namespace::eval punk::ansi { #That will either stop us matching - so no conversion - or risk converting parts of the ansi codes #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - set re {\033\(0[^\033]*\033\(B} + set re {\033\(0[^\033]*\033\(B} set re2 {\033\(0(.*)\033\(B} ;#capturing #box sample @@ -902,10 +902,10 @@ tcl::namespace::eval punk::ansi { #Note that SYN (\016) seems to put terminals in a state #where alternate graphics are not processed. #an ETB (\017) needs to be sent to get alt graphics working again. - #It isn't known what software utilises SYN/ETB within altg sequences + #It isn't known what software utilises SYN/ETB within altg sequences # (presumably to alternate between the charsets within a graphics-on/graphics-off section) #but as modern emulators seem to react to it, we should handle it. - #REVIEW - this mapping not fully understood + #REVIEW - this mapping not fully understood #used by groptim variable grforw variable grback @@ -938,10 +938,10 @@ tcl::namespace::eval punk::ansi { proc ansistrip_gx {text} { #e.g "\033(0" - select VT100 graphics for character set G0 - #e.g "\033(B" - reset + #e.g "\033(B" - reset #e.g "\033)0" - select VT100 graphics for character set G1 #e.g "\033)X" - where X is any char other than 0 to reset ?? - + #return [convert_g0 $text] return [tcl::string::map [list \x1b(0 "" \x1b(B "" \x1b)0 "" \x1b)X ""] $text] } @@ -953,7 +953,7 @@ tcl::namespace::eval punk::ansi { #CSI m = SGR (Select Graphic Rendition) #leave map unindented - used both as a dict and for direct display variable SGR_setting_map { -reset 0 bold 1 dim 2 italic 3 noitalic 23 +reset 0 bold 1 dim 2 italic 3 noitalic 23 underline 4 doubleunderline 21 nounderline 24 blink 5 fastblink 6 noblink 25 reverse 7 noreverse 27 hide 8 nohide 28 strike 9 nostrike 29 normal 22 defaultfg 39 defaultbg 49 overline 53 nooverline 55 @@ -967,26 +967,26 @@ Black 40 Red 41 Green 42 Yellow 43 Blue brightblack 90 brightred 91 brightgreen 92 brightyellow 93 brightblue 94 brightpurple 95 brightcyan 96 brightwhite 97 Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblue 104 Brightpurple 105 Brightcyan 106 Brightwhite 107 } - variable SGR_map ;#public - part of interface - review + variable SGR_map ;#public - part of interface - review set SGR_map [tcl::dict::merge $SGR_colour_map $SGR_setting_map] #we use prefixes e.g web-white and/or x11-white #Only a leading capital letter will indicate the colour target is background vs lowercase for foreground - #In the map key-lookup context the colour names will be canonically lower case + #In the map key-lookup context the colour names will be canonically lower case #We should be case insensitive in the non-prefix part ie after determining fg/bg target from first letter of the prefix - #e.g Web-Lime or Web-lime are ok and are targeting background + #e.g Web-Lime or Web-lime are ok and are targeting background #foreground target examples: web-Lime web-LIME web-DarkSalmon web-Darksalmon #specified in decimal - but we should also accept hex format directly in a+ function e.g #00FFFF for aqua - variable WEB_colour_map + variable WEB_colour_map #use the totitle format as the canonical lookup key #don't use leading zeros - keep compatible with earlier tcl and avoid octal issue - # -- --- --- + # -- --- --- #css 1-2.0 HTML 3.2-4 Basic colours eg web-silver for fg Web-silver for bg # variable WEB_colour_map_basic tcl::dict::set WEB_colour_map_basic white 255-255-255 ;# #FFFFFF - tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 + tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 tcl::dict::set WEB_colour_map_basic gray 128-128-128 ;# #808080 tcl::dict::set WEB_colour_map_basic black 0-0-0 ;# #000000 tcl::dict::set WEB_colour_map_basic red 255-0-0 ;# #FF0000 @@ -1001,7 +1001,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_basic navy 0-0-128 ;# #000080 tcl::dict::set WEB_colour_map_basic fuchsia 255-0-255 ;# #FF00FF tcl::dict::set WEB_colour_map_basic purple 128-0-128 ;# #800080 - # -- --- --- + # -- --- --- #Pink colours variable WEB_colour_map_pink tcl::dict::set WEB_colour_map_pink mediumvioletred 199-21-133 ;# #C71585 @@ -1010,7 +1010,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_pink hotpink 255-105-180 ;# #FF69B4 tcl::dict::set WEB_colour_map_pink lightpink 255-182-193 ;# #FFB6C1 tcl::dict::set WEB_colour_map_pink pink 255-192-203 ;# #FFCOCB - # -- --- --- + # -- --- --- #Red colours variable WEB_colour_map_red tcl::dict::set WEB_colour_map_red darkred 139-0-0 ;# #8B0000 @@ -1022,7 +1022,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_red salmon 250-128-114 ;# #FA8072 tcl::dict::set WEB_colour_map_red darksalmon 233-150-122 ;# #E9967A tcl::dict::set WEB_colour_map_red lightsalmon 255-160-122 ;# #FFA07A - # -- --- --- + # -- --- --- #Orange colours variable WEB_colour_map_orange tcl::dict::set WEB_colour_map_orange orangered 255-69-0 ;# #FF4500 @@ -1030,7 +1030,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_orange darkorange 255-140-0 ;# #FF8C00 tcl::dict::set WEB_colour_map_orange coral 255-127-80 ;# #FF7F50 tcl::dict::set WEB_colour_map_orange orange 255-165-0 ;# #FFA500 - # -- --- --- + # -- --- --- #Yellow colours variable WEB_colour_map_yellow tcl::dict::set WEB_colour_map_yellow darkkhaki 189-183-107 ;# #BDB76B @@ -1044,7 +1044,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_yellow lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 tcl::dict::set WEB_colour_map_yellow lemonchiffon 255-250-205 ;# #FFFACD tcl::dict::set WEB_colour_map_yellow lightyellow 255-255-224 ;# #FFFFE0 - # -- --- --- + # -- --- --- #Brown colours #maroon as above variable WEB_colour_map_brown @@ -1064,7 +1064,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_brown bisque 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown blanchedalmond 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown cornsilk 255-248-220 ;# #FFF8DC - # -- --- --- + # -- --- --- #Purple, violet, and magenta colours variable WEB_colour_map_purple tcl::dict::set WEB_colour_map_purple indigo 75-0-130 ;# #4B0082 @@ -1074,7 +1074,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple darkslateblue 72-61-139 ;# #9400D3 tcl::dict::set WEB_colour_map_purple blueviolet 138-43-226 ;# #8A2BE2 tcl::dict::set WEB_colour_map_purple darkorchid 153-50-204 ;# #9932CC - tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF + tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF tcl::dict::set WEB_colour_map_purple magenta 255-0-255 ;# #FF00FF - same as fuchsia tcl::dict::set WEB_colour_map_purple slateblue 106-90-205 ;# #6A5ACD tcl::dict::set WEB_colour_map_purple mediumslateblue 123-104-238 ;# #7B68EE @@ -1085,7 +1085,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD tcl::dict::set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8 tcl::dict::set WEB_colour_map_purple lavender 230-230-250 ;# #E6E6FA - # -- --- --- + # -- --- --- #Blue colours variable WEB_colour_map_blue tcl::dict::set WEB_colour_map_blue midnightblue 25-25-112 ;# #191970 @@ -1103,7 +1103,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_blue lightsteelblue 176-196-222 ;# #B0C4DE tcl::dict::set WEB_colour_map_blue lightblue 173-216-230 ;# #ADD8E6 tcl::dict::set WEB_colour_map_blue powderblue 176-224-230 ;# #B0E0E6 - # -- --- --- + # -- --- --- #Cyan colours #teal as above variable WEB_colour_map_cyan @@ -1114,11 +1114,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_cyan mediumturquoise 72-209-204 ;# #48D1CC tcl::dict::set WEB_colour_map_cyan turquoise 64-224-208 ;# #40E0D0 tcl::dict::set WEB_colour_map_cyan aqua 0-255-255 ;# #00FFFF - tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua + tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua tcl::dict::set WEB_colour_map_cyan aquamarine 127-255-212 ;# #7FFFD4 tcl::dict::set WEB_colour_map_cyan paleturquoise 175-238-238 ;# #AFEEEE tcl::dict::set WEB_colour_map_cyan lightcyan 224-255-255 ;# #E0FFFF - # -- --- --- + # -- --- --- #Green colours variable WEB_colour_map_green tcl::dict::set WEB_colour_map_green darkgreen 0-100-0 ;# #006400 @@ -1141,7 +1141,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_green lightgreen 144-238-144 ;# #90EE90 tcl::dict::set WEB_colour_map_green greenyellow 173-255-47 ;# #ADFF2F tcl::dict::set WEB_colour_map_green palegreen 152-251-152 ;# #98FB98 - # -- --- --- + # -- --- --- #White colours variable WEB_colour_map_white tcl::dict::set WEB_colour_map_white mistyrose 255-228-225 ;# #FFE4E1 @@ -1161,7 +1161,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_white snow 255-250-250 ;# #FFFAFA tcl::dict::set WEB_colour_map_white ivory 255-255-240 ;# #FFFFF0 tcl::dict::set WEB_colour_map_white white 255-255-255 ;# #FFFFFF - # -- --- --- + # -- --- --- #Gray and black colours variable WEB_colour_map_gray tcl::dict::set WEB_colour_map_gray black 0-0-0 ;# #000000 @@ -1202,8 +1202,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #Xterm colour names (256 colours) - #lists on web have duplicate names - #these have been renamed here in a systematic way: + #lists on web have duplicate names + #these have been renamed here in a systematic way: #They are suffixed with a dash and a letter e.g second deepskyblue4 -> deepskyblue4-b, third deepskyblue4 -> deepskyblue4-c #presumably the xterm colour names are not widely used or are used for reverse lookup from rgb to get an approximate name in the case of dupes? #Review! @@ -1215,10 +1215,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95) #Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway. #The xterm names are boringly unimaginative - and also have some oddities such as: - # DarkSlateGray1 which looks much more like cyan.. + # DarkSlateGray1 which looks much more like cyan.. # The greyxx names are spelt with an e - but the darkslategrayX variants use an a. Perhaps that's because they are more cyan than grey and the a is a hint? # there is no gold or gold2 - but there is gold1 and gold3 - #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. + #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. set xterm_names [list\ black\ @@ -1500,7 +1500,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {!$did_rename} { - error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" + error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" } } incr cidx @@ -1510,7 +1510,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #colour_hex2ansidec - #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) + #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) #we want to support arbitrary rgb values specified in hex - so a table of 16M+ is probably not a great idea #hex zero-padded - canonically upper case but mixed or lower accepted #dict for {k v} $WEB_colour_map { @@ -1539,7 +1539,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable SGR_map return $SGR_map } - + proc colourmap1 {args} { set opts {-bg Web-white -forcecolour 0} foreach {k v} $args { @@ -1603,7 +1603,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } package require textblock set clist [list] - set fg "black" + set fg "black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "black"} { @@ -1647,14 +1647,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::get $opts -forcecolour]} { set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 0} {$i <=15} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? + set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? if {[llength $row]== 8} { lappend rows $row set row [list] @@ -1686,7 +1686,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } set out "" - set fg "web-black" + set fg "web-black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "web-black"} { @@ -1694,7 +1694,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set fg "web-black" } - set br "\n" + set br "\n" } else { set br "" } @@ -1716,10 +1716,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set out "" #use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-black" + set fg "web-black" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 16} {$i <=231} {incr i} { @@ -1892,10 +1892,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_hseps 0 -show_edge 0 for {set i 232} {$i <=255} {incr i} { @@ -1955,7 +1955,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray] switch -- $groups { "" - * { - set show_groups $all_groupnames + set show_groups $all_groupnames } ? { return "Web group names: $all_groupnames" @@ -1996,7 +1996,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] } - $t configure -frametype {} + $t configure -frametype {} $t configure_column 0 -headers [list "[tcl::string::totitle $g] colours"] $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] @@ -2106,7 +2106,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST" set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST" set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST" - set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" + set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" append out "${indent}$undercurly $underdotted" \n append out "${indent}$underdashed" \n append out "${indent}$underline_c" \n @@ -2115,7 +2115,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out "${indent}If a fallback to standard underline is required, underline should be added along with extended codes such as underlinedotted, underlinedouble etc" \n append out "${indent}e.g cyan with curly yellow underline or fallback all cyan underlined \[a+ cyan undercurly underline undt-yellow\]text\[a] -> [a+ {*}$fc cyan undercurly underline undt-yellow]text$RST" \n append out "[a+ {*}$fc web-white]Standard SGR colours and attributes $RST" \n - set settings_applied $SGR_setting_map + set settings_applied $SGR_setting_map set strmap [list] #safe jumptable test #dict for {k v} $SGR_setting_map {} @@ -2139,7 +2139,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try package require textblock - append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n + append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n set bgname "Web-white" @@ -2287,7 +2287,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::exists $TERM_colour_map $tail]} { set descr [tcl::dict::get $TERM_colour_map $tail] } else { - set descr "UNKNOWN colour for term" + set descr "UNKNOWN colour for term" } } $t add_row [list $i $descr $s [ansistring VIEW $s]] @@ -2303,11 +2303,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t add_row [list $i $descr $s [ansistring VIEW $s]] } - rgb- - Rgb- - RGB- - - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - + rgb- - Rgb- - RGB- - + rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - - rgb# - Rgb# - RGB# - + RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - + rgb# - Rgb# - RGB# - und# - und- { set cont [string range $i end-11 end] switch -- $cont { @@ -2430,7 +2430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #REVIEW! note that OSC 4 can change the 256 color pallette - #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ + #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ # (or with colour name instead of rgb #HHHHHH on for example wezterm) #Q: If we can't detect OSC 4 - how do we know when to invalidate/clear at least the 256 color portion of the cache? @@ -2492,13 +2492,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set linelen $thislen } else { append line "$ansi$key$RST " - incr linelen $thislen + incr linelen $thislen } } if {[tcl::string::length $line]} { lappend lines $line } - return [join $lines \n] + return [join $lines \n] } #PUNKARGS doc performed below, after we create the proc @@ -2506,10 +2506,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun a+] [opt {ansicode...}]] #[para]Returns the ansi code to apply those from the supplied list - without any reset being performed first - #[para] e.g to set foreground red and bold + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #function name part of cache-key because a and a+ return slightly different results (a has leading reset) @@ -2538,7 +2538,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set args [lremove $args $fcpos] } - set t [list] + set t [list] set e [list] ;#extended codes needing to go in own escape sequence foreach i $args { set f4 [tcl::string::range $i 0 3] @@ -2560,7 +2560,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] switch -- $cont { -contrasting { set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] @@ -2592,7 +2592,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] switch -- $cont { -contrasting { set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] @@ -2629,13 +2629,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu unde { #TODO - fix # extended codes with colon suppress normal SGR attributes when in same escape sequence on terminal that don't support the extended codes. - # need to emit in + # need to emit in switch -- $i { underline { lappend t 4 ;#underline } underlinedefault { - lappend t 59 + lappend t 59 } underextendedoff { #lremove any existing 4:1 etc @@ -2689,7 +2689,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -2749,10 +2749,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a+ $args'" } @@ -2763,19 +2763,19 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a+ $args'" } } } - rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - + rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { #decimal rgb foreground/background - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx set cont [string range $i end-11 end] switch -- $cont { @@ -2832,8 +2832,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx #https://wezfurlong.org/wezterm/escape-sequences.html#csi-582-underline-color-rgb set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set RGB [lrange [tcl::string::map [list - { } , { } {;} { }] $rgbspec] 0 2] @@ -2854,7 +2854,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend e "58:2::$rgbfinal" } "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] #set rgb [join [::scan $hex6 %2X%2X%2X] {:}] set RGB [::scan $hex6 %2X%2X%2X] @@ -2880,10 +2880,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -2894,7 +2894,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -2906,7 +2906,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -2927,10 +2927,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #the performance penalty must not be placed on the standard colour_enabled path. #This is punk. Colour is the happy path despite the costs. - #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. - #As no_color doesn't strip all ansi - the motivation for it should not generally be + #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. + #As no_color doesn't strip all ansi - the motivation for it should not generally be if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -2940,7 +2940,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -2994,12 +2994,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 0-255 int values for red, green and blue. rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 web- Web- - + The acceptable values for and can be queried using punk::ansi::a? term and punk::ansi::a? web - + Example to set foreground red and background cyan followed by a reset: set str \"[a+ red Cyan]sample text[a]\" " @@ -3009,11 +3009,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun a] [opt {ansicode...}]] #[para]Returns the ansi code to reset any current settings and apply those from the supplied list - #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text - #[para] e.g to set foreground red and bold + #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #It's important to put the functionname in the cache-key because a and a+ return slightly different results @@ -3041,7 +3041,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set args [lremove $args $fcpos] } - set t [list] + set t [list] set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence foreach i $args { set f4 [tcl::string::range $i 0 3] @@ -3052,7 +3052,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground web colour set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] set rgb [tcl::string::map { - ;} $rgbdash] lappend t "38;2;$rgb" } else { @@ -3093,7 +3093,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend t 4 ;#underline } underlinedefault { - lappend t 59 + lappend t 59 } underextendedoff { #lremove any existing 4:1 etc @@ -3147,7 +3147,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -3207,10 +3207,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a $args'" } @@ -3221,10 +3221,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a $args'" } @@ -3232,7 +3232,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 { #decimal rgb foreground - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] lappend t "38;2;$rgb" @@ -3256,14 +3256,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend t "48;2;$rgb" } und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set rgb [tcl::string::map [list - {:} , {:}] $rgbspec] lappend e "58:2::$rgb" } "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] set rgb [join [::scan $hex6 %2X%2X%2X] {:}] lappend e "58:2::$rgb" @@ -3274,10 +3274,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -3288,7 +3288,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -3300,7 +3300,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -3318,9 +3318,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - + if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -3330,7 +3330,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -3431,7 +3431,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun reset]] #[para]reset console - return "\x1bc" + return "\x1bc" } proc reset_soft {} { #*** !doctools @@ -3450,7 +3450,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun reset_colour]] #[para]reset colour only - return "\x1b\[0m" + return "\x1b\[0m" } # -- --- --- --- --- @@ -3578,7 +3578,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu Sequence is of the form: ESCY - This sequence will generally not be understood by terminals + This sequence will generally not be understood by terminals that are not in vt52 mode (e.g DECANM unset). } @values -min 2 -max 2 @@ -3605,7 +3605,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu proc move_emit {row col data args} { #*** !doctools #[call [fun move_emit] [arg row] [arg col] [arg data] [opt {row col data...}]] - #[para]Return an ansi string representing a move to row col with data appended + #[para]Return an ansi string representing a move to row col with data appended #[para]row col data can be repeated any number of times to return a string representing the output of the data elements at all those points #[para]Compare to punk::console::move_emit which calls this function - but writes it to stdout #[para]punk::console::move_emit_return will also return the cursor to the original position @@ -3773,13 +3773,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return \x1b\[3l } - #DECSNM + #DECSNM #Note this can invert the enclosed section including any already reversed by SGR 7 - depending on terminal support. - #e.g + #e.g #set test [a+ reverse]aaa[a+ noreverse]bbb # - $test above can't just be reversed by putting another [a+ reverse] in front of it. # - but the following will work (even if underlying terminal doesn't support ?5 sequences) - #overtype::renderspace -width 20 [enable_inverse]$test + #overtype::renderspace -width 20 [enable_inverse]$test proc enable_inverse {} { return \x1b\[?5h } @@ -3818,7 +3818,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # \x1b\[?7\;1\$y # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - + #https://wiki.tau.garden/dec-modes/ #(DEC,xterm,contour,mintty,kitty etc) #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking @@ -3837,7 +3837,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # mouse_urxvt 1015\ # mouse_sgr_pixel 1016\ #] - variable decmode_data { + variable decmode_data { 1 { {origin DEC description "DECCKM - Cursor Keys Mode" names {DECCKM cursor_keys}} } @@ -3864,7 +3864,7 @@ In VT52 mode - use \x1b< to exit. {origin "xterm" description "X10 compatibility mouse" names {SET_X10_MOUSE mouse_tracking} note { Escape sequence on button press only. CSI M CbCxCy (6 chars) -Coords limited to 223 (=255 - 32) +Coords limited to 223 (=255 - 32) } } {origin DEC description "DECINLM - Interlace Mode (obsolete?)" names {DECINLM}} @@ -3925,7 +3925,7 @@ to 223 (=255 - 32) 2004 { {origin "xterm" description "Set bracketed paste mode" names {bracketed_paste}} } - 2027 { + 2027 { {origin Contour description "Grapheme Cluster Processing" names {grapheme_clusters}} } } @@ -3936,7 +3936,7 @@ to 223 (=255 - 32) foreach nm $names { dict set decmode_names $nm $code } - } + } } @@ -3960,12 +3960,12 @@ to 223 (=255 - 32) #Alt screen buffer - smcup/rmcup ti/te #Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty) - #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. + #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. #see: https://xn--rpa.cc/irl/term.html #1049 (introduced by xterm in 1998?) considered the more modern version? #1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence #1049 - includes save cursor,switch to alt screen, clear screen - #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) + #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) #SMCUP # \x1b7 (save cursor) # \x1b\[?47h (switch) @@ -3973,10 +3973,10 @@ to 223 (=255 - 32) #RMCUP # \x1b\[?47l (switch back) # \x1b8 (restore cursor) - + #1047 - clear screen on the way out (ony if actually on alt screen) proc enable_alt_screen {} { - #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? + #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? return \x1b\[?1049h } proc disable_alt_screen {} { @@ -4114,13 +4114,13 @@ to 223 (=255 - 32) #[para]Use punk::console::get_cursor_pos or punk::console::get_cursor_pos_list instead. #[para]These functions will emit the code - but read it in from stdin so that it doesn't display, and then return the row and column as a colon-delimited string or list respectively. #[para]The punk::ansi::cursor_pos function is used by punk::console::get_cursor_pos and punk::console::get_cursor_pos_list - return \033\[6n + return \033\[6n } - + proc cursor_pos_extended {} { #includes page e.g ^[[47;3;1R #(but not on all terminals - some (freebsd?) will report as per 6n e.g ^[[74;3R) - return \033\[?6n + return \033\[?6n } @@ -4128,7 +4128,7 @@ to 223 (=255 - 32) #REVIEW - vt100 accepts decimal values 132-126 and 160-255 ("in the current GL or GR in-use table") #some modern terminals accept and display characters outside this range - but this needs investigation. #in a modern unicode era - the restricted range doesn't make a lot of sense - but we need to see what terminal emulators actually do. - #e.g what happens with double-width? + #e.g what happens with double-width? #this wrapper accepts a char rather than a decimal value proc fill_rect {char t l b r} { set dec [scan $char %c] @@ -4169,7 +4169,7 @@ to 223 (=255 - 32) } - #alternative to string terminator is \007 - + #alternative to string terminator is \007 - proc titleset {windowtitle} { #*** !doctools #[call [fun titleset] [arg windowtitles]] @@ -4181,7 +4181,7 @@ to 223 (=255 - 32) return \x1bS$windowtitle\r } #titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title - #no cross-platform ansi-only mechanism ? + #no cross-platform ansi-only mechanism ? proc test_decaln {} { #Screen Alignment Test @@ -4189,13 +4189,13 @@ to 223 (=255 - 32) #(doesn't work on many terminals - seems to work in FreeBSD 13.2 and wezterm on windows) return \x1b#8 } - + #length of text for printing characters only #- unicode and other non-printing chars and combining sequences should be handled by the ansifreestring_width call at the end. #certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names #review - is there an existing library or better method? printing to a terminal and querying cursor position is relatively slow and terminals lie. #Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first - #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. + #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. proc printing_length {line} { #string last faster than string first for long strings anyway if {[tcl::string::last \n $line] >= 0} { @@ -4203,7 +4203,7 @@ to 223 (=255 - 32) } #what if line has \v (vertical tab) ie more than one logical screen line? - #review - detect ansi moves and warn/error? They would invalidate this algorithm + #review - detect ansi moves and warn/error? They would invalidate this algorithm #for a string with ansi moves - we would need to use the overtype::renderline function (which is a bit heavier) #arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review #the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char @@ -4237,7 +4237,7 @@ to 223 (=255 - 32) } #NOTE - this is non-destructive backspace as it occurs in text blocks - and is likely different to the sequence coming from a terminal or editor which generally does a destructive backspace - #e.g + #e.g #This means for example that abc\b has a length of 3. Trailing or leading backslashes have no effect #set bs [format %c 0x08] @@ -4260,16 +4260,16 @@ to 223 (=255 - 32) } #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner - #build an output + #build an output set idx 0 set outchars [list] set outsizes [list] # -- - #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code + #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code #this is difficult/risky to maintain - hence the lsearch and grapheme-replacement above #we could reasonably do it with backspace - but cr is more difficult #note that \x08 \b etc won't work to create a compiled switch statement even with unbraced (separate argument) form of switch statement. - #set bs "" + #set bs "" #set cr ? # -- foreach c $chars { @@ -4283,10 +4283,10 @@ to 223 (=255 - 32) set idx 0 } default { - #set nxt [llength $outchars] + #set nxt [llength $outchars] if {$idx < [llength $outchars]} { #overstrike? - should usually have no impact on width - width taken as last grapheme in that column - #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. lset outchars $idx $c } else { @@ -4338,7 +4338,7 @@ to 223 (=255 - 32) #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) if {[string length $text] < 2} {return $text} if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] @@ -4358,7 +4358,7 @@ to 223 (=255 - 32) #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } set parts [punk::ansi::ta::split_codes $text] #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" @@ -4369,9 +4369,9 @@ to 223 (=255 - 32) proc ansistripraw {text} { #*** !doctools #[call [fun ansistripraw] [arg text] ] - #[para]Return a string with ansi codes stripped out + #[para]Return a string with ansi codes stripped out #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. - #[para]ie instead of a horizontal line you may see: qqqqqq + #[para]ie instead of a horizontal line you may see: qqqqqq if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] @@ -4403,7 +4403,7 @@ tcl::namespace::eval punk::ansi { # name (one not found in xterm's tables) ends processing of the # list of names. proc xtgetcap {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -4412,7 +4412,7 @@ tcl::namespace::eval punk::ansi { return "\x1bP+q$payload\x1b\\" } proc xtgetcap2 {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -4432,8 +4432,8 @@ tcl::namespace::eval punk::ansi { #review - separate namespace for functions that operate on multiple or embedded? proc is_sgr {code} { - #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline - #we will accept and pass through the less common colon separator (ITU Open Document Architecture) + #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline + #we will accept and pass through the less common colon separator (ITU Open Document Architecture) #Terminals should generally ignore it if they don't use it regexp {\033\[[0-9;:]*m$} $code } @@ -4450,7 +4450,7 @@ tcl::namespace::eval punk::ansi { return 1 } } - return 0 + return 0 } #pure SGR reset with no other functions proc is_sgr_reset {code} { @@ -4458,8 +4458,8 @@ tcl::namespace::eval punk::ansi { #[call [fun is_sgr_reset] [arg code]] #[para]Return a boolean indicating whether this string has a trailing pure SGR reset #[para]Note that if the reset is not the very last item in the string - it will not be detected. - #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. - + #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. + #todo 8-bit csi regexp {\x1b\[0*m$} $code } @@ -4469,7 +4469,7 @@ tcl::namespace::eval punk::ansi { #if an SGR code has a reset in it - we don't need to carry forward any previous SGR codes #it generally only makes sense for the reset to be the first parameter - otherwise the code has ineffective portions #However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. - #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. + #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. #Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg colour twice in same code proc has_sgr_leadingreset {code} { @@ -4477,7 +4477,7 @@ tcl::namespace::eval punk::ansi { #[call [fun has_sgr_leadingreset] [arg code]] #[para]The reset must be the very first item in code to be detected. Trailing strings/codes ignored. set params "" - #we need non-greedy + #we need non-greedy if {[regexp {^\033\[([^m]*)m} $code _match params]} { #must match trailing m to be the type of reset we're looking for set plist [split $params ";"] @@ -4506,7 +4506,7 @@ tcl::namespace::eval punk::ansi { #regexp {\x1b\(B|\x1b\)B} $code regexp {\x1b(?:\(B|\)B)} $code } - #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through + #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through #This is not order-preserving if non-sgr codes are present as they are tacked on to the end even if they initially were before all SGR codes variable codestate_empty @@ -4514,11 +4514,11 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty rst "" ;#0 (or empty) tcl::dict::set codestate_empty intensity "" ;#1 bold, 2 dim, 22 normal tcl::dict::set codestate_empty italic "" ;#3 on 23 off - tcl::dict::set codestate_empty underline "" ;#4 on 24 off + tcl::dict::set codestate_empty underline "" ;#4 on 24 off #nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5 #4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions - #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines + #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines tcl::dict::set codestate_empty underextended "" ;#4:0 for no extended underline 4:1 etc for underline styles #tcl::dict::set codestate_empty undersingle "" #tcl::dict::set codestate_empty underdouble "" @@ -4550,10 +4550,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty superscript "" ;#73 tcl::dict::set codestate_empty subscript "" ;#74 tcl::dict::set codestate_empty nosupersub "" ;#75 - # -- + # -- tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 - tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 + tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 #misnomer should have been sgr_merge_args ? :/ @@ -4562,7 +4562,7 @@ tcl::namespace::eval punk::ansi { if {[llength $args] == 0} { return "" } elseif {[llength $args] == 1} { - return [lindex $args 0] + return [lindex $args 0] } sgr_merge $args } @@ -4610,7 +4610,7 @@ tcl::namespace::eval punk::ansi { set did_reset 0 #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? - #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? + #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? #we will output 7bit merge of the SGRs even if some or all were 8bit CSi #As at 2024 - 7bit are widely supported 8bit seem to be often ignored by pseudoterminals #auto-detecting and emitting 8bit only if any are present in our input doesn't seem like a good idea - as sgr_merge_list is only seeing a subset of the data - so any auto-decision at this level will just introduce indeterminism. @@ -4644,10 +4644,10 @@ tcl::namespace::eval punk::ansi { #some codes have additional parameters - e.g rgb colours so we need to jump forward in the parameter list sometimes. for {set i 0} {$i < [llength $plist]} {incr i} { set p [lindex $plist $i] - set paramsplit [split $p :] - #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters + set paramsplit [split $p :] + #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters #e.g see https://github.com/mintty/mintty/wiki/Tips#text-attributes-and-rendering - #this may have originated with kitty? + #this may have originated with kitty? #windows terminal seems to be implementing it too #however, they can be completely repurposed - so we probably need to specifically support them.. REVIEW. @@ -4682,7 +4682,7 @@ tcl::namespace::eval punk::ansi { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines #e.g hyper on windows if {[llength $paramsplit] == 1} { - tcl::dict::set codestate underline 4 + tcl::dict::set codestate underline 4 } else { switch -- [lindex $paramsplit 1] { 0 { @@ -4691,10 +4691,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended } 1 { - tcl::dict::set codestate underextended 4:1 + tcl::dict::set codestate underextended 4:1 } 2 { - tcl::dict::set codestate underextended 4:2 + tcl::dict::set codestate underextended 4:2 } 3 { tcl::dict::set codestate underextended "4:3" @@ -4716,7 +4716,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate reverse 7 } 8 { - tcl::dict::set codestate hide 8 + tcl::dict::set codestate hide 8 } 9 { tcl::dict::set codestate strike 9 @@ -4738,7 +4738,7 @@ tcl::namespace::eval punk::ansi { } 23 { #? wikipedia mentions blackletter - review - tcl::dict::set codestate italic 23 + tcl::dict::set codestate italic 23 } 24 { tcl::dict::set codestate underline 24 ;#off @@ -4766,11 +4766,11 @@ tcl::namespace::eval punk::ansi { 38 { #256 colour or rgb #check if subparams supplied as colon separated - if {[tcl::string::first : $p] < 0} { + if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4780,9 +4780,9 @@ tcl::namespace::eval punk::ansi { } } } else { - #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space + #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space #we should only need to pass it all through for the terminal to understand - #review + #review tcl::dict::set codestate fg $p } } @@ -4798,7 +4798,7 @@ tcl::namespace::eval punk::ansi { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4818,7 +4818,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate proportional 50 ;#off - see 26 } 51 - 52 { - tcl::dict::set codestate frame_or_circle 51 + tcl::dict::set codestate frame_or_circle 51 } 53 { tcl::dict::set codestate overline 53 ;#not supported in terminals? pass through anyway @@ -4830,13 +4830,13 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate overline 55; #off } 58 { - #nonstandard + #nonstandard #256 colour or rgb if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4905,11 +4905,11 @@ tcl::namespace::eval punk::ansi { } } - } + } default { lappend othercodes $c } - } + } } @@ -4920,7 +4920,7 @@ tcl::namespace::eval punk::ansi { #dict for {k v} $codestate {} tcl::dict::for {k v} $codestate { switch -- $v { - "" { + "" { } default { switch -- $k { @@ -5028,7 +5028,7 @@ tcl::namespace::eval punk::ansi { tcl::namespace::eval punk::ansi::ta { #*** !doctools #[subsection {Namespace punk::ansi::ta}] - #[para] text ansi functions + #[para] text ansi functions #[para] based on but not identical to the Perl Text Ansi module: #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm #[list_begin definitions] @@ -5036,7 +5036,7 @@ tcl::namespace::eval punk::ansi::ta { variable PUNKARGS - #handle both 7-bit and 8-bit csi + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position #CSI @@ -5058,7 +5058,7 @@ tcl::namespace::eval punk::ansi::ta { #non-greedy by excluding ST terminators variable re_esc_osc1 {(?:\x1b\])(?:[^\007]*)\007} #variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\} ;#somewhat wrong - we want to exclude the ST - not other esc sequences - variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} + variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} variable re_esc_osc3 {(?:\u009d)(?:[^\u009c]*)?\u009c} variable re_osc_open {(?:\x1b\]|\u009d).*} @@ -5070,7 +5070,7 @@ tcl::namespace::eval punk::ansi::ta { #ESC Y move, ESC b foreground colour #ESC F - gr-on ESC G - gr-off variable re_vt52_open {(?:\x1bY|\x1bb|\x1bF)} - #\x1bc vt52 bgcolour conflict ?? + #\x1bc vt52 bgcolour conflict ?? #if we don't split on altgraphics too and separate them out - it's easy to get into a horrible mess variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} @@ -5078,7 +5078,7 @@ tcl::namespace::eval punk::ansi::ta { variable re_g0_close {(?:\x1b\(B)} # DCS "ESC P" or "0x90" is also terminated by ST - set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} #ST terminators [list \007 \033\\ \u009c] #regex to capture the start of string/privacy message/application command block including the contents and string terminator (ST) @@ -5087,7 +5087,7 @@ tcl::namespace::eval punk::ansi::ta { #even if terminals generally don't support that - it's quite possible for an ansi code to get nested this way - and we'd prefer it not to break our splits #Just checking for \x1b will terminate the match too early #we also need to track the start of ST terminated code and not add it for replay (in the ansistring functions) - #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) + #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) #keep our 8bit/7bit start-end codes separate variable re_ST {(?:\x1bP|\x1bX|\x1b\^|\x1b_)(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007)|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)} @@ -5104,12 +5104,12 @@ tcl::namespace::eval punk::ansi::ta { #variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} #NOTE - the literal # char can cause problems in expanded syntax - even though it's within a bracketed section. \# seems to work though. - #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| + #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| #https://freemint.github.io/tos.hyp/en/VT_52_terminal.html #what to with ESC c vs vt52 ESC c (background colour) ??? #we probably need to use a separate re_ansi_detect for vt52 - #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes + #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes #ie - when DECANM is on - VT52 codes are *not* processed #todo - ansi mode and cursor key mode set ? @@ -5129,8 +5129,8 @@ tcl::namespace::eval punk::ansi::ta { - variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" - + variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" + #may be same as detect - kept in case detect needs to diverge #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect @@ -5142,7 +5142,7 @@ tcl::namespace::eval punk::ansi::ta { } lappend PUNKARGS [list -dynamic 0 { - @id -id ::punk::ansi::ta::detect + @id -id ::punk::ansi::ta::detect @cmd -name punk::ansi::ta::detect -help\ "Return a boolean indicating whether Ansi codes were detected in text. Important caveat: @@ -5151,9 +5151,9 @@ tcl::namespace::eval punk::ansi::ta { (one example is if a list element contains an unbalanced brace) This can cause square brackets that form part of the ansi to be backslash escaped - and the function can fail to match it as an Ansi code. - " + " @values -min 1 - text -type string + text -type string } ] #*** !doctools @@ -5187,8 +5187,8 @@ tcl::namespace::eval punk::ansi::ta { proc detect_g0 {text} [string map [list [list $re_g0_group]] { regexp $text }] - #note - micro optimisation of inlining gives us *almost* nothing extra. - #left in place for a few such as detect/detect_g0 as we want them as fast as possible + #note - micro optimisation of inlining gives us *almost* nothing extra. + #left in place for a few such as detect/detect_g0 as we want them as fast as possible # in general the technique doesn't seem particularly worthwhile for this set of functions. #the performance is dominated by the complexity of the regexp proc detect2 {text} { @@ -5211,8 +5211,8 @@ tcl::namespace::eval punk::ansi::ta { #[call [fun detect_csi] [arg text]] #[para]Return a boolean indicating whether an Ansi Control Sequence Introducer (CSI) was detected in text #[para]The csi is often represented in code as \x1b or \033 followed by a left bracket [lb] - #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation - #[para]There is also a multi-byte escape sequence \u009b + #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation + #[para]There is also a multi-byte escape sequence \u009b #[para]This is less commonly used but is also detected here #[para](This function is not in perl ta) variable re_csi_open @@ -5240,7 +5240,7 @@ tcl::namespace::eval punk::ansi::ta { #*** !doctools #[call [fun length] [arg text]] #[para]Return the character length after stripping ansi codes - not the printing length - + #we can use ansistripraw to avoid g0 conversion - as the length should remain the same tcl::string::length [ansistripraw $text] } @@ -5259,11 +5259,11 @@ tcl::namespace::eval punk::ansi::ta { proc split_at_codes {str} [string map [list $re_ansi_split] { #variable re_ansi_split #punk::ansi::internal::splitx $str ${re_ansi_split} - punk::ansi::ta::Do_split_at_codes $str {} + punk::ansi::ta::Do_split_at_codes $str {} }] #it is faster to split this function out than to inline it into split_at_codes in tcl 8.7 - something to do with the use of the variable vs argument for the regexp #literal inlining of the re in the main proc-body was slower too - but inlining it into the wrapper seems to work (a tiny bit) - #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - + #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - # - but in aggregate for something like textblock::periodic - we can get a bit over 5% faster (e.g 136ms vs 149ms) proc Do_split_at_codes {str regexp} { if {$str eq ""} { @@ -5342,12 +5342,12 @@ tcl::namespace::eval punk::ansi::ta { lappend list [tcl::string::range $str $start end] return $list }] - - # -- --- --- --- --- --- + + # -- --- --- --- --- --- #Split $text to a list containing alternating ANSI colour codes and text. #ANSI colour codes are always on the second element, fourth, and so on. #(ie plaintext on even list-indices ansi on odd indices) - #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) + #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) # Example: #split_codes "" # => "" #split_codes "a" # => "a" @@ -5361,7 +5361,7 @@ tcl::namespace::eval punk::ansi::ta { variable re_ansi_split_multi return [_perlish_split $re_ansi_split_multi $text] } - #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) + #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds) #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. @@ -5413,16 +5413,16 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] - incr start + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] + incr start } else { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] } if {$start >= [tcl::string::length $text]} { @@ -5437,20 +5437,20 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] - incr start + 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 $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] #? if {$start >= [tcl::string::length $text]} { @@ -5467,22 +5467,22 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::index $text $matchStart] - incr start + yield [tcl::string::index $text $matchStart] + incr start if {$start >= [tcl::string::length $text]} { break } continue } yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::range $text $matchStart $matchEnd] + yield [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] #? if {$start >= [tcl::string::length $text]} { @@ -5495,7 +5495,7 @@ tcl::namespace::eval punk::ansi::ta { proc _ws_split {text} { regexp -all -inline {(?:\S+)|(?:\s+)} $text } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #*** !doctools #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] @@ -5532,7 +5532,7 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- if {[llength $args] < 1} { error {usage: ?-width ? ?-height ? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring} @@ -5632,7 +5632,7 @@ tcl::namespace::eval punk::ansi::class { method rendernext {} { upvar ${o_ns_from}::o_ansisplits from_ansisplits upvar ${o_ns_from}::o_elements from_elements - upvar ${o_ns_from}::o_splitindex from_splitindex + upvar ${o_ns_from}::o_splitindex from_splitindex #if {![llength $from_ansisplits]} {$o_from_ansistring eval_in {my MakeSplit}} ;#!!todo - a better way to keep this method semi hidden but call from a 'friend' if {![llength $from_ansisplits]} { @@ -5658,7 +5658,7 @@ tcl::namespace::eval punk::ansi::class { set process_splitindex [lindex $from_splitindex $eidx] ;#which from_ansisplits index the first unrendered element belongs to set elementinfo [lindex $from_elements $eidx] - lassign $elementinfo type_rendered item + lassign $elementinfo type_rendered item #we don't expect type to change should be all graphemes (type 'g') or a single code (type 'sgr','other' etc) #review - we may want to store more info for graphemes e.g g0 g1 g2 for zero-wide 1-wide 2-wide ? #if so - we should report a list of the grapheme types that were rendered in a pt block @@ -5674,7 +5674,7 @@ tcl::namespace::eval punk::ansi::class { set e_splitindex $process_splitindex while {$e_splitindex == $process_splitindex && $eidx < [llength $from_elements]} { append newtext $item - lappend o_rendereditems $elementinfo + lappend o_rendereditems $elementinfo incr rendercount incr eidx @@ -5684,8 +5684,8 @@ tcl::namespace::eval punk::ansi::class { } } else { #while not g ? render however many ansi sequences are in a row? - set newtext $item - lappend o_rendereditems $elementinfo + set newtext $item + lappend o_rendereditems $elementinfo incr rendercount } @@ -5703,7 +5703,7 @@ tcl::namespace::eval punk::ansi::class { if {![tcl::string::length $overtext]} { continue } - #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] + #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] } } #renderspace equivalent? channel based? @@ -5714,7 +5714,7 @@ tcl::namespace::eval punk::ansi::class { } } - #name all with prefix class_ for rendertype detection + #name all with prefix class_ for rendertype detection oo::class create class_cp437 { superclass base_renderer } @@ -5733,7 +5733,7 @@ tcl::namespace::eval punk::ansi::class { #this is the main state we keep of the split apart string #we use the punk::ansi::ta::split_codes_single function which produces a list with zero, or an odd number elements always beginning and ending with plaintext - variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes + variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes variable o_ansisplits ;#store our plaintext/ansi-code splits so we don't keep re-running the regexp to split @@ -5750,7 +5750,7 @@ tcl::namespace::eval punk::ansi::class { variable o_elements ;#elements contains entry for each grapheme/control + each ansi code variable o_sgrstacks ;#list of ansi sgr codes that will be merged later. Entries deliberately repeat if no change from previous entry. Later scans look for difference between n and n-1 when deciding where to apply codes. variable o_gx0states ;#0|1 for alternate graphics gx0 - variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. + variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. # -- -- constructor {string} { @@ -5763,7 +5763,7 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- #we choose not to generate an internal split-state for the initial string - which may potentially be large. @@ -5772,7 +5772,7 @@ tcl::namespace::eval punk::ansi::class { set o_count "" ;#o_count first updated when string appended or a method causes MakeSplit to run (or by count method if constructor argument was empty string) - set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. + set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. set o_ptlist [list] #o_ansisplits and o_ptlist should only remain empty if an empty string was passed to the contructor, or no methods have yet triggered the initial string to have it's internal state built. @@ -5786,7 +5786,7 @@ tcl::namespace::eval punk::ansi::class { #empty if no render methods used # -- - set o_renderer "" + set o_renderer "" set o_renderout "" ;#class_ansistring # -- @@ -5810,18 +5810,18 @@ tcl::namespace::eval punk::ansi::class { method show_state {{verbose 0}} { #show some state info - without updating anything - #only use 'my' methods that don't update the state e.g has_ansi + #only use 'my' methods that don't update the state e.g has_ansi set result "" if {![llength $o_ansisplits]} { append result "No internal splits. " append result \n "has ansi : [my has_ansi]" - append result \n "Tcl string length raw string: [tcl::string::length $o_string]" + append result \n "Tcl string length raw string: [tcl::string::length $o_string]" } else { append result \n "has ansi : [my has_ansi]" - append result \n "ansisplit list len: [llength $o_ansisplits]" + append result \n "ansisplit list len: [llength $o_ansisplits]" append result \n "plaintext list len: [llength $o_ptlist]" append result \n "cached count : $o_count" - append result \n "Tcl string length raw string : [tcl::string::length $o_string]" + append result \n "Tcl string length raw string : [tcl::string::length $o_string]" append result \n "Tcl string length plaintext parts: [tcl::string::length [join $o_ptlist ""]]" if {[llength $o_ansisplits] %2 == 0} { append result \n -------------------------------------------------- @@ -5860,10 +5860,10 @@ tcl::namespace::eval punk::ansi::class { #private method method MakeSplit {} { #The split with each code as it's own element is more generally useful. - set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; + set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; set o_ptlist [list] set codestack [list] - set gx0_state 0 ;#default off + set gx0_state 0 ;#default off set current_split_index 0 ;#incremented for each pt block, incremented for each code if {$o_count eq ""} { set o_count 0 @@ -5878,7 +5878,7 @@ tcl::namespace::eval punk::ansi::class { incr o_count } #after handling the pt block - incr the current_split_index - incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry + incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry #we will only get an empty code at the very end of ansisplits (ansisplits is length 0 or odd length - always with pt at start and pt at end) if {$code ne ""} { lappend o_sgrstacks $codestack @@ -5914,7 +5914,7 @@ tcl::namespace::eval punk::ansi::class { } } #assertion every grapheme and every individual code has been added to o_elements - #every element has an entry in o_sgrstacks + #every element has an entry in o_sgrstacks #every element has an entry in o_gx0states assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} } @@ -5925,7 +5925,7 @@ tcl::namespace::eval punk::ansi::class { method strippedlength {} { if {![llength $o_ansisplits]} {my MakeSplit} #review - return [string length [join $o_ptlist ""]] + return [string length [join $o_ptlist ""]] } #returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already method stripped {} { @@ -5938,13 +5938,13 @@ tcl::namespace::eval punk::ansi::class { method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function return [tcl::string::length [regsub -all $re_diacritics $plaintext ""]] } - #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! + #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! method count {} { if {$o_count eq ""} { #only initial string present @@ -5977,7 +5977,7 @@ tcl::namespace::eval punk::ansi::class { #channels for stream in/out.. these are vaguely analogous to the input/output between a shell and a PTY Slave - but this is not intended to be a full pseudoterminal #renderstream_to_render (private?) - # write end held by outer ansistring? read end by inner render ansistring ? + # write end held by outer ansistring? read end by inner render ansistring ? #renderstream_from_render (public?) method rendertypes {} { @@ -5991,7 +5991,7 @@ tcl::namespace::eval punk::ansi::class { } set rtypes [my rendertypes] if {$rtype ni $rtypes} { - error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" + error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" } #if {$o_renderout eq ""} { # set o_renderout [punk::ansi::class::class_ansistring new ""] @@ -6022,7 +6022,7 @@ tcl::namespace::eval punk::ansi::class { } if {$rw eq $o_renderwidth} { return $o_renderwidth - } + } #re-render if needed? puts stderr "renderwidth todo? re-render?" @@ -6034,7 +6034,7 @@ tcl::namespace::eval punk::ansi::class { method render_state {} { #? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary #but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split. - #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work + #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work } method renderbuf {} { #get the underlying renderobj - if any @@ -6071,7 +6071,7 @@ tcl::namespace::eval punk::ansi::class { return [dict create graphemes $grapheme_count other $other_count] } method rendernext {} { - #render next available pt/code chunk only - not to end of available input + #render next available pt/code chunk only - not to end of available input if {$o_renderer eq ""} { my rendertype $o_rendertype ;#review - proper way to initialise rendering } @@ -6111,7 +6111,7 @@ tcl::namespace::eval punk::ansi::class { } #analagous to Tcl string append - #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient + #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient method append {args} { set catstr [join $args ""] if {$catstr eq ""} { @@ -6122,19 +6122,19 @@ tcl::namespace::eval punk::ansi::class { #ansi-free additions #if no initial internal-split - generate it without first appending our additions - as we can more efficiently append them to the internal state if {![llength $o_ansisplits]} { - #initialise o_count because we need to add to it. + #initialise o_count because we need to add to it. #The count method will do this by calling Makesplit only if it needs to. (which will create ansisplits for anything except empty string) my count } append o_string $catstr;# only append after updating using my count above if {![llength $o_ptlist]} { - #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits + #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits #even though we can use lset to add to a list - we can't for empty lappend o_ptlist $catstr #assertion - if o_ptlist is empty so is o_ansisplits lappend o_ansisplits $catstr } else { - lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] + lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] $catstr] } set last_codestack [lindex $o_sgrstacks end] @@ -6156,16 +6156,16 @@ tcl::namespace::eval punk::ansi::class { #set combined_plaintext [join $o_ptlist ""] #set o_count [my DoCount $combined_plaintext] assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} - return $o_string + return $o_string } else { - #update each element of internal state incrementally without reprocessing what is already there. + #update each element of internal state incrementally without reprocessing what is already there. append o_string $catstr - set newsplits [punk::ansi::ta::split_codes_single $catstr] + set newsplits [punk::ansi::ta::split_codes_single $catstr] set ptnew "" set codestack [lindex $o_sgrstacks end] set gx0_state [lindex $o_gx0states end] - set current_split_index [lindex $o_splitindex end] - #first pt must be merged with last element of o_ptlist + set current_split_index [lindex $o_splitindex end] + #first pt must be merged with last element of o_ptlist set new_pt_list [list] foreach {pt code} $newsplits { lappend new_pt_list $pt @@ -6216,7 +6216,7 @@ tcl::namespace::eval punk::ansi::class { #if {$o_count eq ""} { # #we have splits - but didn't count graphemes? - # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts + # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts #} else { # incr o_count [my DoCount $ptnew] #} @@ -6227,7 +6227,7 @@ tcl::namespace::eval punk::ansi::class { return $o_string } - #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. + #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. #This is 'often'? likely to be true - We don't have grapheme cluster support yet anyway. review. method appendobj {args} { if {![llength $o_ansisplits]} { @@ -6272,7 +6272,7 @@ tcl::namespace::eval punk::ansi::class { set firstnewidx [lindex $new_splitindex 0] set diffidx [expr {$lastidx - $firstnewidx}] ;#may be negative foreach v $new_splitindex { - lappend o_splitindex [expr {$v + $diffidx}] + lappend o_splitindex [expr {$v + $diffidx}] } incr o_count $new_count @@ -6323,7 +6323,7 @@ tcl::namespace::eval punk::ansi::class { set arrow_lr \u2194 set arrow_du \u2195 #2024 - there is no 4-arrow symbol or variations (common cursor and window icon) in unicode - despite requests and argument from the community that this has been in use for decades. - #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. + #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. #don't split into lines first - \n is valid within ST sections set output "" @@ -6338,7 +6338,7 @@ tcl::namespace::eval punk::ansi::class { set c1 [tcl::string::index $code 0] set c1c2 [tcl::string::range $code 0 1] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[ 7CSI\ \x9b 8CSI\ @@ -6346,9 +6346,9 @@ tcl::namespace::eval punk::ansi::class { \x1b\( 7GFX\ \x9d 8OSC\ \x1b 7ESC\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - #we leave the tail of the code unmapped for now + #we leave the tail of the code unmapped for now switch -- $leadernorm { 7CSI - 7OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] @@ -6401,7 +6401,7 @@ tcl::namespace::eval punk::ansi::class { H - f { set params [tcl::string::range $codenorm 4 end-1] lassign [split $params {;}] row col - #lassign $matchinfo _match row col + #lassign $matchinfo _match row col set displaycode [ansistring VIEW $code] if {$col eq ""} { #row only move @@ -6423,7 +6423,7 @@ tcl::namespace::eval punk::ansi::class { append output ${unk}[ansistring VIEW -lf 1 $code]$RST } } - } + } 7GFX { switch -- [tcl::string::index $codenorm 4] { "0" { @@ -6456,7 +6456,7 @@ tcl::namespace::eval punk::ansi::class { #set splits [punk::ansi::ta::split_codes_single $string] set output "" set codestack [list] - set gx_stack [list] ;#not actually a stack + set gx_stack [list] ;#not actually a stack set cursor_saved "" foreach {pt code} $o_ansisplits { if {[llength $args]} { @@ -6482,13 +6482,13 @@ tcl::namespace::eval punk::ansi::class { #cursor_restore set codestack [list $cursor_saved] } else { - #leave SGR stack as is + #leave SGR stack as is if {[punk::ansi::codetype::is_gx_open $code]} { set gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess } elseif {[punk::ansi::codetype::is_gx_close $code]} { set gx_stack [list] - } - } + } + } } } return $output @@ -6500,24 +6500,24 @@ tcl::namespace::eval punk::ansi { proc stripansi3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - #using detect costs us a couple of uS - but saves time on plain text + #using detect costs us a couple of uS - but saves time on plain text #we should probably leave this for caller - otherwise it ends up being called more than necessary - #if {![::punk::ansi::ta::detect $text]} { + #if {![::punk::ansi::ta::detect $text]} { # return $text #} #alternate graphics codes are not the norm - # - so save a few uS in the common case by only calling convert_g0 if we detect + # - so save a few uS in the common case by only calling convert_g0 if we detect if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] proc stripansiraw3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { #join [::punk::ansi::ta::split_at_codes $text] "" - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] } @@ -6533,7 +6533,7 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::namespace::ensemble create tcl::namespace::export length trim trimleft trimright INDEX COUNT VIEW VIEWCODES VIEWSTYLE INDEXABSOLUTE INDEXCOLUMNS COLUMNINDEX NEW #todo - expose _splits_ methods so caller can work efficiently with the splits themselves - #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single + #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single #\UFFFD - replacement char or \U2426 @@ -6647,7 +6647,7 @@ tcl::namespace::eval punk::ansi::ansistring { variable debug_visuals #modern (c0 seem to have more terminal/font support - C1 can show 8bit c1 codes - but also seems to be limited support) - + #Goal is not to map every control character? #Map of which elements we want to convert - done this way so we can see names of control's that are included: - ease of maintenance compared to just creating the tcl::string::map directly #ETX -ctrl-c @@ -6729,10 +6729,10 @@ tcl::namespace::eval punk::ansi::ansistring { #we'll hack in some stuff as needed - may override some of the visuals_c1 which is usually just empty/substitute glyphs #Being repurposed - these could potentially be confused with actual characters depending on the debugging context #To minimize potential confusion - we'll use a longer replacement sequence - which is not ideal from the perspective of terminal column layout debugging - #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator + #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator #(review - BOM should use different brackets to c1?) - #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. + #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. #for 8-bit controls - we will standardize on a fixed width of 4 bracketing with: #\u2987 and \u2988 from Miscellaneous Mathematical Symbols-B (D or fractional-moon shaped brackets) #\u2987 - Z Notation Left Image Bracket @@ -6750,7 +6750,7 @@ tcl::namespace::eval punk::ansi::ansistring { #unicode Tags block brackets set obt \u2993 ;set cbt \u2994 - #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now + #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now #set visuals_c1 [tcl::dict::create\ # BPH [list \x82 "${ob8}\ue022 $cb8"]\ # NBH [list \x83 "${ob8}\ue023 $cb8"]\ @@ -6826,10 +6826,10 @@ tcl::namespace::eval punk::ansi::ansistring { set vis [format %c $asciidec] if {[dict exists $map_c0 $vis]} { set vis [dict get $map_c0 $vis] - } + } tcl::dict::set visuals_tags TAG$asciidec [list [format %c $i] "${obt}$vis${cbt}"] } - + set hack [tcl::dict::create] tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) @@ -6840,13 +6840,13 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::dict::set hack SOS [list \x98 "${ob8}\u2380 $cb8"] ;#Insertion Symbol from Miscellaneous Technical - 1 wide + pad tcl::dict::set hack ST [list \x9c "${ob8}\u2383 $cb8"] ;#Emphasis Symbol from Miscellaneous Technical - 1 wide + pad (graphically related to \u2380) tcl::dict::set hack CSI [list \x9b "${ob8}\u2386 $cb8"] ;#Enter Symbol from Miscellaneous Technical - 1 wide + pad - tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) + tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) tcl::dict::set hack PM [list \x9e "${ob8}PM$cb8"] tcl::dict::set hack APC [list \x9f "${ob8}\U1f534$cb8"] ;#bright red ball from Miscellaneoust Symbols and Pictographs - 2 wide (APC also noted as a potential security risk) set debug_visuals [tcl::dict::merge $visuals_c0 $visuals_c1 $hack $visuals_tags] - #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient + #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient proc NEW {string} { punk::ansi::class::class_ansistring new $string } @@ -6894,8 +6894,8 @@ tcl::namespace::eval punk::ansi::ansistring { # -lf 2, -vt 2 and -ff 2 are useful for CRM mode (Show Control Character Mode) in the terminal - where a newline is expected to display after the character. - set visuals_opt $debug_visuals - set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] + set visuals_opt $debug_visuals + set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] if {$opt_esc} { tcl::dict::set visuals_opt ESC [list \x1b \u241b] @@ -6949,7 +6949,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #The implementation of viewcodes,viewstyle is more efficiently done in an object for the case where repeated calls of various methods can re-use the internal splits. - #for oneshots here - there is only minor overhead to use and destroy the object here. + #for oneshots here - there is only minor overhead to use and destroy the object here. proc VIEWCODES {args} { set string [lindex $args end] if {$string eq ""} { @@ -6961,7 +6961,7 @@ tcl::namespace::eval punk::ansi::ansistring { $ansistr destroy return $result } - #an attempt to show the codes and colour/style of the *input* + #an attempt to show the codes and colour/style of the *input* #ie we aren't looking at the row/column positioning - but we do want to keep track of cursor attribute saves and restores proc VIEWSTYLE {args} { set string [lindex $args end] @@ -6993,16 +6993,16 @@ tcl::namespace::eval punk::ansi::ansistring { #stripping diacritics only makes sense if we are counting them as combiners and also treating unicode grapheme combinations as single entities. #as Our ansistring INDEX function returns the character with diacritics, and will ultimately return grapheme clusters as a single element - we strip theme here as not counted. #todo - combiners/diacritics? just map them away here? - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set string [regsub -all $re_diacritics $string ""] - #we want length to return number of glyphs.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs.. not screen width. Has to be consistent with index function tcl::string::length [ansistrip $string] } #included as a test/verification - slightly slower. #grapheme split version may end up being used once it supports unicode grapheme clusters proc count2 {string} { - #we want count to return number of glyphs.. not screen width. Has to be consistent with index function + #we want count to return number of glyphs.. not screen width. Has to be consistent with index function return [llength [punk::char::grapheme_split [ansistrip $string]]] } @@ -7077,7 +7077,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc - #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. + #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. proc trimleft {string args} { set intext 0 set out "" @@ -7103,19 +7103,19 @@ tcl::namespace::eval punk::ansi::ansistring { } proc trim {string} { #make sure we do our ansi-scanning split only once - so use list-based trim operations - #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length + #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length #we save a single function call by calling both here rather than _splits_trim join [_splits_trimright [_splits_trimleft [split_codes $string]]] "" } - #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index + #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index proc INDEX {string index} { #*** !doctools #[call [fun index] [arg string] [arg index]] #[para]Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes) #[para]Returns the character (with applied ansi effect) at position index #[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output. - #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) + #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) #[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them. #[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards. #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index. @@ -7194,8 +7194,8 @@ tcl::namespace::eval punk::ansi::ansistring { } #any pt could be empty if using split_codes_single (or just first and last pt if split_codes) - set low -1 - set high -1 + set low -1 + set high -1 set pt_index -2 set pt_found -1 set char "" @@ -7209,8 +7209,8 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { set graphemes [punk::char::grapheme_split $pt] - set low [expr {$high + 1}] ;#last high - #incr high [tcl::string::length $pt] + set low [expr {$high + 1}] ;#last high + #incr high [tcl::string::length $pt] incr high [llength $graphemes] } @@ -7220,14 +7220,14 @@ tcl::namespace::eval punk::ansi::ansistring { set char [lindex $graphemes $index-$low] break } - + if {[punk::ansi::codetype::is_sgr_reset $code]} { - #we can throw away previous codestack + #we can throw away previous codestack set codestack [list] } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { set codestack [list $code] } else { - #may have partial resets + #may have partial resets #sgr_merge_list will handle at end #we don't apply non SGR codes to our output. This is probably what is wanted - but should be reviewed. #Review - consider if any other types of code make sense to retain in the output in this context. @@ -7244,8 +7244,8 @@ tcl::namespace::eval punk::ansi::ansistring { } } - #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi - #return empty string for each index that is out of range + #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi + #return empty string for each index that is out of range #review - this is possibly too slow to be very useful as is. # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string #see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. @@ -7326,11 +7326,11 @@ tcl::namespace::eval punk::ansi::ansistring { #we now have numeric or empty string indices - but haven't fully checked they are within the underlying payload length if {[join $testindices ""] eq ""} { - #don't calc ansistring length if no indices to check + #don't calc ansistring length if no indices to check return $testindices } if {$payload_len == -1} { - set payload_len [punk::ansi::ansistring::length $string] + set payload_len [punk::ansi::ansistring::length $string] } set indices [list] foreach ti $testindices { @@ -7356,7 +7356,7 @@ tcl::namespace::eval punk::ansi::ansistring { #single-width grapheme will return pair of integers of equal value #doulbe-width grapheme will return a pair of consecutive indices proc INDEXCOLUMNS {string idx} { - #There is an index per grapheme - whether it is 1 or 2 columns wide + #There is an index per grapheme - whether it is 1 or 2 columns wide set index [lindex [INDEXABSOLUTE $string $idx] 0] if {$index eq ""} { return "" @@ -7377,7 +7377,7 @@ tcl::namespace::eval punk::ansi::ansistring { foreach ptline $ptlines { set graphemes [punk::char::grapheme_split $ptline] if {$ptlineindex > 0} { - #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column + #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column #zero width set low [expr {$high + 1}] set lowc [expr {$highc + 1}] @@ -7393,7 +7393,7 @@ tcl::namespace::eval punk::ansi::ansistring { set lowc 0 set highc 0 } - set low [expr {$high + 1}] ;#last high + set low [expr {$high + 1}] ;#last high set lowc [expr {$highc + 1}] set high [expr {$low + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $ptline] -1}] @@ -7435,7 +7435,7 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { if {[tcl::string::last \n $pt] < 0} { set graphemes [punk::char::grapheme_split $pt] - set lowindex [expr {$highindex + 1}] ;#last high + set lowindex [expr {$highindex + 1}] ;#last high set lowc [expr {$highc + 1}] set highindex [expr {$lowindex + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $pt] -1}] @@ -7527,7 +7527,7 @@ namespace eval punk::ansi::colour { #https://sourceforge.net/p/irrational-numbers/code/HEAD/tree/pkgs/Colors/trunk/colors.tcl#l159 - # classic formula for luminance (0.0 .. 100.0) + # classic formula for luminance (0.0 .. 100.0) proc luminance {R G B} { return [expr {(0.3*$R + 0.59*$G + 0.11*$B)/255.0}] } @@ -7536,9 +7536,9 @@ namespace eval punk::ansi::colour { proc contrasting {R G B} { set lum [luminance $R $G $B] if {$lum < 0.597} { - set lum 0.9 + set lum 0.9 } else { - set lum 0.2 + set lum 0.2 } lassign [RGB2hsl $R $G $B] h s l return [hsl2RGB $h $s $lum] @@ -7569,11 +7569,11 @@ namespace eval punk::ansi::colour { } foreach c {R G B} { - if {$T($c) < [expr {1.0/6.0}]} { + if {$T($c) < (1.0/6.0)} { set T($c) [expr {$P+($Q-$P)*6.0*$T($c)}] } elseif {$T($c) < 0.5} { set T($c) $Q - } elseif {$T($c) < [expr {2.0/3.0}]} { + } elseif {$T($c) < (2.0/3.0)} { set T($c) [expr {$P+($Q-$P)*(2.0/3.0-$T($c))*6.0}] } else { set T($c) $P @@ -7585,7 +7585,7 @@ namespace eval punk::ansi::colour { } proc RGB2hsl { R G B } { set r [expr {$R/255.0}] - set g [expr {$G/255.0}] + set g [expr {$G/255.0}] set b [expr {$B/255.0}] set max $r @@ -7611,7 +7611,7 @@ namespace eval punk::ansi::colour { } set L [expr {($max+$min)/2}] - + if { $L == 0.0 || $max == $min } { set S 0.0 } elseif { $L <= 0.5 } { @@ -7651,7 +7651,7 @@ namespace eval punk::ansi::colour { set Bmax 1 } set L [expr {($min + $max) / 2.0}] - set H 0.0 + set H 0.0 set S 0.0 #REVIEW - java allows floating point division by 0.0 - producing positive infinity, negative infinity or NaN #This makes the original java algorithm a little more obscure @@ -7757,9 +7757,9 @@ tcl::namespace::eval punk::ansi::internal { } proc printing_length_addchar {i c} { - upvar outchars outc + upvar outchars outc upvar outsizes outs - set nxt [llength $outc] + set nxt [llength $outc] if {$i < $nxt} { lset outc $i $c } else { @@ -7801,10 +7801,10 @@ namespace eval ::punk::args::register { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ansi [tcl::namespace::eval punk::ansi { 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/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index 74a3ffc8..25b01d81 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::args 0 0.1.0] #[copyright "2024"] #[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] #[require punk::args] #[keywords module proc args arguments parse] #[description] -#[para]Utilities for parsing proc args +#[para]Utilities for parsing proc args # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -53,8 +53,8 @@ # @cmd -help "do some stuff with files e.g dofilestuff " # @opts -type string # #comment lines ok -# -directory -default "" -# -translation -default binary +# -directory -default "" +# -translation -default binary # #setting -type none indicates a flag that doesn't take a value (solo flag) # -nocomplain -type none # @values -min 1 -max -1 @@ -62,26 +62,26 @@ # # puts "translation is [dict get $opts -translation]" # foreach f [dict values $values] { -# puts "doing stuff with file: $f" +# puts "doing stuff with file: $f" # } # } #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values #[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. #[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. #[para]e.g the result from the punk::args call above may be something like: #[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments #[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments #[example { # proc dofilestuff {category args} { # lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary +# -directory -default "" +# -translation -default binary # -nocomplain -type none -# @values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 # } $args]] leaders opts values @@ -89,16 +89,16 @@ # puts "$category fileB: [dict get $values fileB]" # } #}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 #[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, #[para] or an additional call could be made to punk::args e.g #[example { # punk::args::get_dict { -# category -choices {cat1 cat2 cat3} +# category -choices {cat1 cat2 cat3} # another_leading_arg -type boolean # } [list $category $another_leading_arg] -#}] +#}] #*** !doctools #[subsection Notes] @@ -111,8 +111,8 @@ # proc test_switch {args} { # set opts [dict create\\ # -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ +# -frametype "heavy"\\ +# -show_edge 1\\ # -show_seps 0\\ # -x a\\ # -y b\\ @@ -173,12 +173,12 @@ #[enum]The tcllib set of TEPAM modules (pure tcl) #[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. #[list_end] -#[para] (* c implementation planned/proposed) +#[para] (* c implementation planned/proposed) #[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. #[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences #[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. #[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. #[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. #[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. @@ -188,7 +188,7 @@ #All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 #as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. #(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) #ensembles: array binary clock dict info namespace string @@ -221,7 +221,7 @@ package require Tcl 8.6- tcl::namespace::eval punk::args::register { #*** !doctools #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register + #[para] cooperative namespace punk::args::register #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. #[list_begin definitions] @@ -257,15 +257,15 @@ tcl::namespace::eval punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args { - + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - tcl::namespace::export {[a-z]*} + tcl::namespace::export {[a-z]*} variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} variable id_cache_rawdef [tcl::dict::create] variable id_cache_spec [tcl::dict::create] - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) variable argdata_cache [tcl::dict::create] @@ -273,7 +273,7 @@ tcl::namespace::eval punk::args { #*** !doctools #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args + #[para] Core API functions for punk::args #[list_begin definitions] #todo - some sort of punk::args::cherrypick operation to get spec from an existing set @@ -283,10 +283,10 @@ tcl::namespace::eval punk::args { #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix #e.g - # -corner -aliases {-corners} + # -corner -aliases {-corners} # -centre -aliases {-center -middle} #We mightn't want the prefix to be longer just because of an alias #we should get -co -ce and -m from the above as abbreviations @@ -301,10 +301,10 @@ tcl::namespace::eval punk::args { Returns a dictionary representing the argument specifications. The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. + @id -id value from the supplied definition. This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. This can be used purely for documentation or called within a function to parse a mix of leading values, switches/flags and trailing values. @@ -325,7 +325,7 @@ tcl::namespace::eval punk::args { text if they are properly braced or double quoted and Tcl escaping for inner quotes or unbalanced braces is maintained. The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for + (\\ at the end of the line) can be used to continue the set of arguments for a leading word. Leading words beginning with the @ character are directives controlling argument parsing and help display. @@ -347,13 +347,13 @@ tcl::namespace::eval punk::args { -body (text to replace autogenerated arg info) %B%@doc%N% ?opt val...? options: -name -url - %B%@seealso%N% ?opt val...? + %B%@seealso%N% ?opt val...? options: -name -url (for footer - unimplemented) Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults + to use with the @leaders @opts @values directives to set defaults for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be + These directives should occur in exactly this order - but can be repeated with custom argument lines interspersed. An @id line can only appear once and should be the first item. @@ -365,17 +365,17 @@ tcl::namespace::eval punk::args { Custom arguments are defined by using any word at the start of a line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so + (except that adding an additionl @ escapes this restriction so that @@somearg becomes an argument named @somearg) custom leading args, switches/options (names starting with -) and trailing values also take options: - -type + -type defaults to string. If no other restrictions - are specified, choosing string does the least validation. + are specified, choosing string does the least validation. recognised types: - none + none (used for switches only. Indicates this is a 'solo' flag ie accepts no value) int|integer @@ -400,14 +400,14 @@ tcl::namespace::eval punk::args { -default -multiple (for leaders & values defines whether subsequent received values are stored agains the same - argument name - only applies to final leader or value) + argument name - only applies to final leader or value) (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - no necessarily contiguously) + flag to appear multiple times - no necessarily contiguously) -choices {} A list of allowable values for an argument. The -default value doesn't have to be in the list. If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted + It will only be used for validation if the -choicerestricted option is set to false. -choicerestricted Whether values not specified in -choices or -choicegroups are @@ -421,7 +421,7 @@ tcl::namespace::eval punk::args { These choices should match exactly a choice entry in one of the settings -choices or -choicegroups. These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. + choice argument must be entered to select the choice. -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name. @@ -446,7 +446,7 @@ tcl::namespace::eval punk::args { " -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} are re-evaluated on each call. If the definition is being used not just as documentation, but is also used within the function to parse args, e.g using punk::args::get_by_id, @@ -463,7 +463,7 @@ tcl::namespace::eval punk::args { Using multiple text arguments may be useful to mix curly-braced and double-quoted strings to have finer control over interpolation when defining arguments. (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) + from existing definitions (by id) for re-use of argument specifications and help text) e.g the following definition passes 2 blocks as text arguments definition { @@ -486,7 +486,7 @@ tcl::namespace::eval punk::args { #Items that don't begin with * or - are value definitions v1 -type integer -default 0 thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" " }]] @@ -519,7 +519,7 @@ tcl::namespace::eval punk::args { -multiple 0\ -regexprepass {}\ -validationtransform {}\ - ] + ] set valspec_defaults [tcl::dict::create\ -type string\ -optional 0\ @@ -618,7 +618,7 @@ tcl::namespace::eval punk::args { variable argdefcache_unresolved - set cache_key $args + set cache_key $args #ideally we would use a fast hash algorithm to produce a short key with low collision probability. #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) #review - check if there is a built-into-tcl way to do this quickly @@ -668,8 +668,8 @@ tcl::namespace::eval punk::args { foreach a $textargs { lappend normargs [tcl::string::map {\r\n \n} $a] } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + set optionspecs [join $normargs \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 @@ -692,7 +692,7 @@ tcl::namespace::eval punk::args { #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices #default to 1 for convenience - #checks with no default + #checks with no default #-minsize -maxsize -range @@ -729,13 +729,13 @@ tcl::namespace::eval punk::args { #ansi colours can stop info complete from working (contain square brackets) #review - when exactly are ansi codes allowed/expected in record lines. # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket if {$has_punkansi} { set test_complete [punk::ansi::ansistrip $recordsofar] } else { - #review + #review #we only need to strip enough to stop interference with 'info complete' set test_complete [string map [list \x1b\[ ""] $recordsofar] } @@ -743,7 +743,7 @@ tcl::namespace::eval punk::args { #append linebuild [string trimleft $rawline] \n if {$in_record} { #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) @@ -761,7 +761,7 @@ tcl::namespace::eval punk::args { set in_record 1 regexp {(\s*).*} $rawline _all lastindent #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " + #puts "indent from rawline:$rawline " append linebuild $rawline \n } } else { @@ -769,14 +769,14 @@ tcl::namespace::eval punk::args { #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left if {[tcl::string::first "$lastindent " $rawline] == 0} { set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline + append linebuild $trimmedline } elseif {[tcl::string::first $lastindent $rawline] == 0} { set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline + append linebuild $trimmedline } else { append linebuild $rawline } - lappend records $linebuild + lappend records $linebuild set linebuild "" } } @@ -793,7 +793,7 @@ tcl::namespace::eval punk::args { #(common case of no leaders specified) set opt_any 0 set val_min 0 - set val_max -1 ;#-1 for no limit + set val_max -1 ;#-1 for no limit set DEF_definition_id $id #form_defs @@ -805,14 +805,14 @@ tcl::namespace::eval punk::args { set refs [dict create] set record_type "" - set record_number -1 ;# + set record_number -1 ;# foreach rec $records { set trimrec [tcl::string::trim $rec] switch -- [tcl::string::index $trimrec 0] { "" - # {continue} } incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict if {[llength $record_values] % 2 != 0} { #todo - avoid raising an error - store invalid defs keyed on id error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" @@ -853,19 +853,19 @@ tcl::namespace::eval punk::args { set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] + set form_ids_active [lindex $record_form_ids 0] } } foreach fid $record_form_ids { if {![dict exists $F $fid]} { if {$firstword eq "@form"} { - #only @form directly supplies keys + #only @form directly supplies keys dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] } else { dict set F $fid [New_command_form $fid] } } else { - #update form with current record opts, except -form + #update form with current record opts, except -form if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } } } @@ -912,7 +912,7 @@ tcl::namespace::eval punk::args { #global reference dict - independent of forms #ignore refs without an -id #store all keys except -id - #complete overwrite if refid repeated later on + #complete overwrite if refid repeated later on if {[dict exists $at_specs -id]} { dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] } @@ -938,7 +938,7 @@ tcl::namespace::eval punk::args { set doc_info [dict get $copyfrom doc_info] } foreach fid $record_form_ids { - #only use elements with matching form id? + #only use elements with matching form id? #probably this feature mainly useful for _default anyway so that should be ok #cooperative doc sets specified in same file could share via known form ids too #todo argdisplay_info by fid @@ -964,7 +964,7 @@ tcl::namespace::eval punk::args { # {4 anykeys {3 by}} # {5 anykeys {1 .. 1 to 3 by}} # }\ - # -fallback 1 + # -fallback 1 # ... # @parser -synopsis "start 'count' count ??'by'? step?"\ # -arities { @@ -976,7 +976,7 @@ tcl::namespace::eval punk::args { # 1 # {3 anykeys {1 by}} # } - # + # # see also after manual # @form -arities {1} # @form -arities { @@ -990,9 +990,9 @@ tcl::namespace::eval punk::args { if {[dict exists $at_specs -form]} { set idlist [dict get $at_specs -form] if {$idlist eq "*"} { - #* only applies to form ids that exist at the time + #* only applies to form ids that exist at the time set idlist [dict keys $F] - } + } set form_ids_active $idlist } #new form keys already created if they were needed (done for all records that have -form ) @@ -1001,7 +1001,7 @@ tcl::namespace::eval punk::args { set package_info [dict merge $package_info $at_specs] } cmd { - #allow arbitrary - review + #allow arbitrary - review set cmd_info [dict merge $cmd_info $at_specs] } doc { @@ -1009,7 +1009,7 @@ tcl::namespace::eval punk::args { } argdisplay { #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing set argdisplay_info [dict merge $argdisplay_info $at_specs] } opts { @@ -1063,8 +1063,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1154,8 +1154,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1246,8 +1246,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1315,12 +1315,12 @@ tcl::namespace::eval punk::args { foreach fid $record_form_ids { if {[dict get $F $fid argspace] eq "leaders"} { set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader + tcl::dict::set argdef_values -ARGTYPE leader #lappend leader_names $argname set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] if {$argname ni $temp_leadernames} { lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames } else { error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" } @@ -1330,7 +1330,7 @@ tcl::namespace::eval punk::args { } } else { set record_type value - tcl::dict::set argdef_values -ARGTYPE value + tcl::dict::set argdef_values -ARGTYPE value set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] lappend temp_valnames $argname tcl::dict::set F $fid VAL_NAMES $temp_valnames @@ -1370,7 +1370,7 @@ tcl::namespace::eval punk::args { tcl::dict::set spec_merged -type int } bool - boolean { - tcl::dict::set spec_merged -type bool + tcl::dict::set spec_merged -type bool } char - character { tcl::dict::set spec_merged -type char @@ -1386,7 +1386,7 @@ tcl::namespace::eval punk::args { } lappend opt_solos $argname } else { - #-solo only valid for flags + #-solo only valid for flags error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } } @@ -1444,7 +1444,7 @@ tcl::namespace::eval punk::args { set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id } else { if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] } else { puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" } @@ -1464,10 +1464,10 @@ tcl::namespace::eval punk::args { if {$is_opt} { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } else { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } tcl::dict::set F $fid ARG_INFO $argname $spec_merged #review existence of -default overriding -optional @@ -1496,7 +1496,7 @@ tcl::namespace::eval punk::args { } } } - } ;# end foreach fid record_form_ids + } ;# end foreach fid record_form_ids } ;# end foreach rec $records @@ -1527,9 +1527,9 @@ tcl::namespace::eval punk::args { #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } @@ -1547,17 +1547,17 @@ tcl::namespace::eval punk::args { #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - #in the above case we have no unique total_arity + #in the above case we have no unique total_arity #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" + #e.g given the invalid command "after cancel" # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from + #e.g commandline completion could show list of synopsis entries to select from set form_info [dict create] dict for {fid fdict} $F { @@ -1619,7 +1619,7 @@ tcl::namespace::eval punk::args { #return raw definition list as created with 'define' # - possibly with unresolved dynamic parts proc raw_def {id} { - variable id_cache_rawdef + variable id_cache_rawdef set realid [real_id $id] if {![dict exists $id_cache_rawdef $realid]} { return "" @@ -1632,8 +1632,8 @@ tcl::namespace::eval punk::args { variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} variable resolved_def_TYPE_CHOICEGROUPS { directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} } lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { @@ -1643,35 +1643,35 @@ tcl::namespace::eval punk::args { uses the 'spec' form to build a response in definition format. Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with + of tight coupling to the other function that should be done with care. Note that the directives @leaders @opts @values may appear multiple times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for + follow. When retrieving these - there is only a single result for each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before + When retrieving -types * each of these will be positioned before the arguments of that type - but this doesn't mean there was a single leading directive for this argument type in the source definition. Each argument has already had its complete specification recorded in its own result. - + When manually specifying -types, the order @leaders then @opts then @values must be maintained - but if they are placed before their corresponding arguments, they will not affect the retrieved arguments as these arguments are already fully spec'd. The defaults from the source can be removed by adding @leaders, @opts @values to the -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the + Each argument can have members of its spec overridden using the -override dictionary. " @leaders -min 0 -max 0 @opts -form -default 0 -help\ - "Ordinal index or name of command form" + "Ordinal index or name of command form" #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} -antiglobs -default {} -type list -help\ "Glob patterns for directive or argument/flags to be suppressed" @@ -1687,7 +1687,7 @@ tcl::namespace::eval punk::args { path for a command name" pattern -type string -optional 1 -default * -multiple 1 -help\ "glob-style patterns for retrieving value or switch - definitions. + definitions. If -type is * and pattern is * the entire definition including directive lines will be returned in line form. @@ -1698,8 +1698,8 @@ tcl::namespace::eval punk::args { will be returned. if -type is another directive such as @id, @doc etc the - patterns are ignored. - + patterns are ignored. + " }]] } @@ -1718,7 +1718,7 @@ tcl::namespace::eval punk::args { return } set patterns [list] - + #a definition id must not begin with "-" ??? review for {set i 0} {$i < [llength $args]} {incr i} { set a [lindex $args $i] @@ -1730,7 +1730,7 @@ tcl::namespace::eval punk::args { dict set opts $a [lindex $args $i] } else { set id [lindex $args $i] - set patterns [lrange $args $i+1 end] + set patterns [lrange $args $i+1 end] break } if {$i == [llength $args]-1} { @@ -1781,7 +1781,7 @@ tcl::namespace::eval punk::args { #set arg_info [dict get $specdict ARG_INFO] set arg_info [dict get $specdict FORMS $formname ARG_INFO] set argtypes [dict create leaders leader opts option values value] - + set opt_antiglobs [dict get $opts -antiglobs] set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] set suppressed_directives [list] @@ -1822,7 +1822,7 @@ tcl::namespace::eval punk::args { } } foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] + set dshort [string range $directive 1 end] if {"$directive" in $included_directives} { if {[dict exists $opt_override $directive]} { append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" @@ -1832,8 +1832,8 @@ tcl::namespace::eval punk::args { } } #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" switch -- $directive { @leaders {set defaults_key leaderspec_defaults} @opts {set defaults_key optspec_defaults} @@ -1925,7 +1925,7 @@ tcl::namespace::eval punk::args { } proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef + variable id_cache_rawdef set realid [real_id $id] if {$realid ne ""} { set speclist [tcl::dict::get $id_cache_rawdef $realid] @@ -1971,7 +1971,7 @@ tcl::namespace::eval punk::args { set deflist [raw_def $id] if {[dict exists $rawdef_cache $deflist -dynamic]} { return [dict get $rawdef_cache $deflist -dynamic] - } + } return [rawdef_is_dynamic $deflist] #@dynamic only has meaning as 1st element of a def in the deflist } @@ -2042,7 +2042,7 @@ tcl::namespace::eval punk::args { if {[tcl::dict::exists $aliases $id]} { return 1 } - variable id_cache_rawdef + variable id_cache_rawdef tcl::dict::exists $id_cache_rawdef $id } proc set_alias {alias id} { @@ -2061,7 +2061,7 @@ tcl::namespace::eval punk::args { } proc real_id {id} { - variable id_cache_rawdef + variable id_cache_rawdef variable aliases if {[tcl::dict::exists $aliases $id]} { set id [tcl::dict::get $aliases $id] @@ -2126,7 +2126,7 @@ tcl::namespace::eval punk::args { } append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" return $result } @@ -2136,7 +2136,7 @@ tcl::namespace::eval punk::args { if {[set gposn [lsearch $nslist {}]] >= 0} { lset nslist $gposn :: } - upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::NAMESPACES registered ;#list upvar ::punk::args::register::loaded_packages loaded_packages ;#list upvar ::punk::args::register::loaded_info loaded_info ;#dict upvar ::punk::args::register::scanned_packages scanned_packages ;#list @@ -2149,7 +2149,7 @@ tcl::namespace::eval punk::args { #e.g - gets called for each subcommand of an ensemble (could be many) # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- + # -- --- --- --- --- --- # common-case fast-path if {[llength $loaded_packages] == [llength $registered]} { @@ -2157,7 +2157,7 @@ tcl::namespace::eval punk::args { #assert - if all are registered - then all have been scanned ( return {} } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set unscanned [punklib_ldiff $registered $scanned_packages] if {[llength $unscanned]} { @@ -2191,7 +2191,7 @@ tcl::namespace::eval punk::args { dict lappend namespace_docpackages $documentedns $pkgns } lappend seen_documentedns $documentedns - } + } } } set ts_end [clock microseconds] @@ -2218,7 +2218,7 @@ tcl::namespace::eval punk::args { set docns ${pkgns}::argdoc if {[namespace exists $docns]} { if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns + lappend needed $docns } } if {[dict exists $namespace_docpackages $pkgns]} { @@ -2247,7 +2247,7 @@ tcl::namespace::eval punk::args { set epath [namespace path] set pkgns [namespace parent] if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail + namespace path [list {*}$epath $pkgns] ;#add to tail } } @@ -2259,7 +2259,7 @@ tcl::namespace::eval punk::args { namespace eval $evalns [list punk::args::define {*}$definitionlist] incr def_count } - } + } #process list of 2-element lists if {[info exists ${pkgns}::PUNKARGS_aliases]} { @@ -2322,7 +2322,7 @@ tcl::namespace::eval punk::args { # -------------------------------------- - #test of Get_caller + #test of Get_caller lappend PUNKARGS [list { @id -id ::punk::args::test1 @values -min 0 -max 0 @@ -2357,16 +2357,16 @@ tcl::namespace::eval punk::args { @cmd -name punk::args::arg_error -help\ "Generates a table (by default) of usage information for a command. A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept + switches and for subcommands or argument/switch values that accept a defined set of choices. These prefixes match the mechanism used to validate arguments (based on tcl::prefix::match). - This function is called during the argument parsing process + This function is called during the argument parsing process (if the definition is not only being used for documentation) It is also called by punk::args::usage which is in turn called by the punk::ns introspection facilities which creates on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. + oo objects where a manually defined one isn't present. " @leaders -min 2 -max 2 msg -type string -help\ @@ -2399,21 +2399,21 @@ tcl::namespace::eval punk::args { proc arg_error {msg spec_dict args} { #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. + #may be desirable to reduce overhead on catches. #consider per-namespace or namespace-tree configurability. #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. + #to resource availability etc - so the slower error generation time may not always be a problem. #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling #code which has no use for the enhanced error info. #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system #todo #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #todo - document unnamed leaders and unnamed values where -min and/or -max specified #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} #only |?-x?|string|... is shown in the output table. #should be something like: @@ -2435,7 +2435,7 @@ tcl::namespace::eval punk::args { namespace import ::punk::ansi::a ::punk::ansi::a+ } } - #limit colours to standard 16 so that themes can apply to help output + #limit colours to standard 16 so that themes can apply to help output variable arg_error_isrunning if {$arg_error_isrunning} { error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" @@ -2448,7 +2448,7 @@ tcl::namespace::eval punk::args { set arg_error_isrunning 1 set badarg "" - set returntype table ;#table as string + set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error set scheme error dict for {k v} $args { @@ -2487,14 +2487,14 @@ tcl::namespace::eval punk::args { } info - error {} default { - set scheme na + set scheme na } } #hack some basics for now. #for coloured schemes - use bold as well as brightcolour in case colour off. array set CLR {} set CLR(errormsg) [a+ brightred] - set CLR(title) "" + set CLR(title) "" set CLR(check) [a+ brightgreen] set CLR(solo) [a+ brightcyan] set CLR(choiceprefix) [a+ underline] @@ -2503,20 +2503,20 @@ tcl::namespace::eval punk::args { set CLR(cmdname) [a+ brightwhite] set CLR(groupname) [a+ bold] set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] switch -- $scheme { nocolour { set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] + set CLR(title) [a+ bold] set CLR(check) "" set CLR(solo) "" set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] + set CLR(cmdname) [a+ bold] set CLR(linebase_header) "" set CLR(linebase) "" - set CLR(ansibase_body) "" + set CLR(ansibase_body) "" } info { set CLR(errormsg) [a+ brightred bold] @@ -2525,8 +2525,8 @@ tcl::namespace::eval punk::args { set CLR(choiceprefix) [a+ brightgreen bold] set CLR(groupname) [a+ cyan bold] set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] } error { set CLR(errormsg) [a+ brightred bold] @@ -2535,8 +2535,8 @@ tcl::namespace::eval punk::args { set CLR(choiceprefix) [a+ brightgreen bold] set CLR(groupname) [a+ cyan bold] set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] } na { } @@ -2547,7 +2547,7 @@ tcl::namespace::eval punk::args { set RST "\x1b\[m" set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error #e.g list_as_table # use basic colours here to support terminals without extended colours @@ -2629,8 +2629,8 @@ tcl::namespace::eval punk::args { } if {$use_table} { set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col if {!$is_custom_argdisplay} { lappend blank_header_col "" @@ -2708,9 +2708,9 @@ tcl::namespace::eval punk::args { $t add_row [list "" $argdisplay_body] } else { if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header + lappend errlines $argdisplay_header } - lappend errlines {*}$argdisplay_body + lappend errlines {*}$argdisplay_body } } else { @@ -2719,18 +2719,18 @@ tcl::namespace::eval punk::args { set A_BADARG $CLR(badarg) set greencheck $CLR(check)\u2713$RST ;#green tick set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space } else { - set A_PREFIXEND $RST + set A_PREFIXEND $RST } set opt_names [list] - set opt_names_display [list] + set opt_names_display [list] if {[llength [dict get $spec_dict OPT_NAMES]]} { if {![catch {package require punk::trie}]} { set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] @@ -2752,14 +2752,14 @@ tcl::namespace::eval punk::args { lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] lappend opt_names $c - } + } } else { set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names + set opt_names_display $opt_names } } set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { # if {![string match -* $argname]} { @@ -2773,8 +2773,8 @@ tcl::namespace::eval punk::args { # set trailing_val_names $leading_val_names # set leading_val_names {} #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names #display options first then values foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { @@ -2788,7 +2788,7 @@ tcl::namespace::eval punk::args { set default "" } set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] + set allchoices_originalcase [list] set choices [Dict_getdef $arginfo -choices {}] set choicegroups [Dict_getdef $arginfo -choicegroups {}] set choicemultiple [dict get $arginfo -choicemultiple] @@ -2799,7 +2799,7 @@ tcl::namespace::eval punk::args { set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck + set multiple $greencheck set is_multiple 1 } else { set multiple "" @@ -2865,11 +2865,11 @@ tcl::namespace::eval punk::args { set idents [dict get [$trie shortest_idents ""] scanned] if {[dict get $arginfo -nocase]} { #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents + set actual_idents $idents foreach ch $allchoices_originalcase { if {![dict exists $idents $ch]} { #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict + #The actual testing is done in get_dict dict set actual_idents $ch [dict get $idents [string tolower $ch]] } } @@ -2899,12 +2899,12 @@ tcl::namespace::eval punk::args { append cdisplay \n [dict get $choicelabeldict $c] } dict lappend formattedchoices $groupname $cdisplay - } + } } } errM]} { #this failure can happen if -nocase is true and there are ambiguous entries #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" + puts stderr "prefix marking failed\n$errM" #append help "\n " [join [dict get $arginfo -choices] "\n "] if {[dict size $choicelabeldict]} { dict for {groupname clist} $choicegroups { @@ -2917,9 +2917,9 @@ tcl::namespace::eval punk::args { } } } else { - set formattedchoices $choicegroups + set formattedchoices $choicegroups } - + } } set choicetable_objects [list] @@ -2932,7 +2932,7 @@ tcl::namespace::eval punk::args { } if {$numcols > 0} { if {$use_table} { - #risk of recursing + #risk of recursing #TODO -title directly in list_as_table set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] lappend choicetable_objects $choicetableobj @@ -3053,7 +3053,7 @@ tcl::namespace::eval punk::args { -ansibase_body $CLR(ansibase_body)\ -ansibase_header $CLR(ansibase_header)\ -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) + -ansiborder_body $CLR(ansiborder) $t configure -maxwidth 80 ;#review if {$returntype ne "tableobject"} { @@ -3073,7 +3073,7 @@ tcl::namespace::eval punk::args { } set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) if {$use_table} { #assert returntype is one of table, tableobject @@ -3081,7 +3081,7 @@ tcl::namespace::eval punk::args { if {$returntype eq "tableobject"} { if {[info object isa object $t]} { set result $t - } + } } } else { set result $errmsg @@ -3109,8 +3109,8 @@ tcl::namespace::eval punk::args { IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. " -return -default table -choices {string table tableobject} } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { @@ -3136,7 +3136,7 @@ tcl::namespace::eval punk::args { @values -min 1 id arglist -type list -help\ - "list containing arguments to be parsed as per the + "list containing arguments to be parsed as per the argument specification identified by the supplied id." }] @@ -3154,7 +3154,7 @@ tcl::namespace::eval punk::args { #consider #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withid $id #parse ?-flag val?... -- $arglist withdef $def ?$def?... #an experiment.. ideally we'd like arglist at the end? @@ -3179,15 +3179,15 @@ tcl::namespace::eval punk::args { form1: parse $arglist ?-flag val?... withid $id form2: parse $arglist ?-flag val?... withdef $def ?$def? see punk::args::define" - @form -form {withid withdef} + @form -form {withid withdef} @leaders -min 1 -max 1 arglist -type list -optional 0 -help\ "Arguments to parse - supplied as a single list" - @opts + @opts -form -type list -default * -help\ "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a + Forms are the orthogonal sets of arguments a command can take - usually described in 'synopsis' entries." #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance @@ -3206,16 +3206,16 @@ tcl::namespace::eval punk::args { @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" withdef -type literal -help\ "The literal value 'withdef'" - + #todo - make -dynamic obsolete - use @dynamic directive instead def -type string -multiple 1 -optional 0 -help\ "Each remaining argument is a block of text defining argument definitions. - As a special case, -dynamic may be + As a special case, -dynamic may be specified as the 1st 2 arguments. These are treated as an indicator to punk::args about how to process the definition." - + }] proc parse {args} { set tailtype "" ;#withid|withdef @@ -3225,7 +3225,7 @@ tcl::namespace::eval punk::args { set parseargs [lindex $args 0] set tailargs [lrange $args 1 end] - set split [lsearch -exact $tailargs withid] + set split [lsearch -exact $tailargs withid] if {$split < 0} { set split [lsearch -exact $tailargs withdef] if {$split < 0} { @@ -3240,7 +3240,7 @@ tcl::namespace::eval punk::args { set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" + error "punk::args::parse Even number of -flag val pairs required after arglist" } set defaultopts [dict create\ -form {*}\ @@ -3253,7 +3253,7 @@ tcl::namespace::eval punk::args { } default { #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" } } } @@ -3312,7 +3312,7 @@ tcl::namespace::eval punk::args { } else { set arglist $a set got_arglist 1 - set tailtype [lindex $args $i+1] + set tailtype [lindex $args $i+1] if {$tailtype eq "withid"} { if {[llength $args] != $i+3} { error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" @@ -3335,7 +3335,7 @@ tcl::namespace::eval punk::args { } #assert tailtype eq withid|withdef if {$tailtype eq "withid"} { - #assert $id was provided + #assert $id was provided return "parse [llength $arglist] args withid $id, options:$opts" } else { #assert llength deflist >=1 @@ -3356,8 +3356,8 @@ tcl::namespace::eval punk::args { #see arg_error regarding considerations around unhappy-path performance #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? #can the above be made completely unambiguous for arbitrary arglist?? #e.g what if arglist = withdef and the first $def is also withdef ? @@ -3373,11 +3373,11 @@ tcl::namespace::eval punk::args { #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values #[para]Each optionspec line defining a flag must be of the form: #[para]-optionname -key val -key2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional #[para]Each optionspec line defining a positional argument is of the form: #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. #[arg_def list rawargs] @@ -3386,13 +3386,13 @@ tcl::namespace::eval punk::args { #[list_end] #[para] - #consider line-processing example below for which we need info complete to determine record boundaries + #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { # @opts # -opt1 -default {} # -opt2 -default { # etc - # } + # } # @values -multiple 1 #} $args @@ -3402,7 +3402,7 @@ tcl::namespace::eval punk::args { #if definition has been seen before, #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] # ----------------------------------------------- @@ -3415,7 +3415,7 @@ tcl::namespace::eval punk::args { set flagsreceived [list] ;#for checking if required flags satisfied #secondary purpose: #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. - #-default value must not be appended to if argname not yet in flagsreceived + #-default value must not be appended to if argname not yet in flagsreceived #todo: -minmultiple -maxmultiple ? @@ -3440,9 +3440,9 @@ tcl::namespace::eval punk::args { } if {$ridx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] + set leader_posn_name [lindex $LEADER_NAMES $ridx] if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 + set is_multiple 1 } } elseif {$ridx > [llength $LEADER_NAMES]-1} { #beyond names - retain name if -multiple was true @@ -3468,7 +3468,7 @@ tcl::namespace::eval punk::args { if {$leader_posn_name ne ""} { #there is a named leading positional for this position #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name incr ridx continue @@ -3480,7 +3480,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader + #optional leader #most adhoc arg processing will allocate based on number of args rather than matching choice values first #(because a choice value could be a legitimate data value) @@ -3501,19 +3501,19 @@ tcl::namespace::eval punk::args { if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { break } else { - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { #required if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional + #already accepted at least one value - requirement satisfied - now equivalent to optional if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { break - } + } } #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -3522,8 +3522,8 @@ tcl::namespace::eval punk::args { if {$ridx > $LEADER_MIN} { break } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -3553,7 +3553,7 @@ tcl::namespace::eval punk::args { #assert - rawargs has been reduced by leading positionals set leaders [list] - set arglist {} + set arglist {} set post_values {} #val_min, val_max #puts stderr "rawargs: $rawargs" @@ -3565,7 +3565,7 @@ tcl::namespace::eval punk::args { set vals_total_possible [llength $rawargs] set vals_remaining_possible $vals_total_possible } else { - set vals_total_possible $val_max + set vals_total_possible $val_max set vals_remaining_possible $vals_total_possible } for {set i 0} {$i <= $maxidx} {incr i} { @@ -3573,7 +3573,7 @@ tcl::namespace::eval punk::args { set remaining_args_including_this [expr {[llength $rawargs] - $i}] #lowest val_min is 0 if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here + # if current arg is -- it will pass through as a value here set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] break @@ -3586,7 +3586,7 @@ tcl::namespace::eval punk::args { if {$val_max != -1} { #finite max number of vals if {$remaining_args_including_this == $val_max} { - #assume it's a value. + #assume it's a value. set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] } else { @@ -3626,7 +3626,7 @@ tcl::namespace::eval punk::args { tcl::dict::lappend opts $fullopt $flagval } } else { - tcl::dict::set opts $fullopt $flagval + tcl::dict::set opts $fullopt $flagval } #incr i to skip flagval incr vals_remaining_possible -2 @@ -3664,21 +3664,21 @@ tcl::namespace::eval punk::args { } if {$opt_any} { set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS if {[tcl::dict::get $argstate $a -type] ne "none"} { if {[tcl::dict::get $argstate $a -multiple]} { tcl::dict::lappend opts $a $newval } else { - tcl::dict::set opts $a $newval + tcl::dict::set opts $a $newval } if {[incr i] > $maxidx} { arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a } incr vals_remaining_possible -2 } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none if {[tcl::dict::get $argstate $a -multiple]} { if {![tcl::dict::exists $opts $a]} { tcl::dict::set opts $a 1 @@ -3702,7 +3702,7 @@ tcl::namespace::eval punk::args { } } } else { - #not flaglike + #not flaglike set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] break @@ -3759,9 +3759,9 @@ tcl::namespace::eval punk::args { } set validx 0 - set in_multiple "" + set in_multiple "" set valnames_received [list] - set values_dict $val_defaults + set values_dict $val_defaults set num_values [llength $values] foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { @@ -3775,9 +3775,9 @@ tcl::namespace::eval punk::args { } else { tcl::dict::lappend values_dict $valname $val } - set in_multiple $valname + set in_multiple $valname } else { - tcl::dict::set values_dict $valname $val + tcl::dict::set values_dict $valname $val } lappend valnames_received $valname } else { @@ -3826,14 +3826,14 @@ tcl::namespace::eval punk::args { } } - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. - #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? @@ -3841,10 +3841,10 @@ tcl::namespace::eval punk::args { #struct::set difference {x} {a b} #normal interp 0.18 u2 vs safe interp 9.4us #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" #} #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { @@ -3907,7 +3907,7 @@ tcl::namespace::eval punk::args { } #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels @@ -3930,7 +3930,7 @@ tcl::namespace::eval punk::args { } #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - + switch -- [tcl::dict::get $thisarg -ARGTYPE] { leader { @@ -3973,7 +3973,7 @@ tcl::namespace::eval punk::args { if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } + } #----------------------------------- set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list @@ -3997,14 +3997,14 @@ tcl::namespace::eval punk::args { set choice_exact_match 0 if {$c_check in $allchoices} { #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check + set chosen $c_check set choice_in_list 1 set choice_exact_match 1 } elseif {$v_test in $choices_test} { #assert - if we're here, nocase must be true #we know choice is present as full-length match except for case #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #we don't set choice_exact_match - because we will need to override the optimistic existing val below #review foreach avail [lsort -unique $allchoices] { if {[string match -nocase $c $avail]} { @@ -4014,7 +4014,7 @@ tcl::namespace::eval punk::args { #assert chosen will always get set set choice_in_list 1 } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. #in this block we can treat empty result from prefix match as a non-match if {$nocase} { @@ -4033,7 +4033,7 @@ tcl::namespace::eval punk::args { set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] + set choice_in_list [expr {$chosen ne ""}] } else { set chosen $bestmatch set choice_in_list 1 @@ -4057,7 +4057,7 @@ tcl::namespace::eval punk::args { } #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { + if {$choice_in_list && !$choice_exact_match} { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { if {$is_multiple} { set existing [tcl::dict::get [set $dname] $argname] @@ -4091,7 +4091,7 @@ tcl::namespace::eval punk::args { # lset existing $idx $v_test # tcl::dict::set $dname $argname $existing #} else { - # tcl::dict::set $dname $argname $v_test + # tcl::dict::set $dname $argname $v_test #} lappend vlist_validate $c lappend vlist_check_validate $c_check @@ -4186,10 +4186,10 @@ tcl::namespace::eval punk::args { string - ansistring - globstring { #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail @@ -4197,7 +4197,7 @@ tcl::namespace::eval punk::args { set pass_quick_list_e [list] set pass_quick_list_e_check [list] set remaining_e $vlist - set remaining_e_check $vlist_check + set remaining_e_check $vlist_check #review - order of -regexprepass and -regexprefail in original rawargs significant? #for now -regexprepass always takes precedence if {$regexprepass ne ""} { @@ -4225,7 +4225,7 @@ tcl::namespace::eval punk::args { } switch -- $type { ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi #.. so we need to look at the original values in $vlist not $vlist_check #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? @@ -4271,7 +4271,7 @@ tcl::namespace::eval punk::args { } } int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive if {[tcl::dict::exists $thisarg -range]} { lassign [tcl::dict::get $thisarg -range] low high if {"$low$high" ne ""} { @@ -4290,7 +4290,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } - #highside unspecified - check only low + #highside unspecified - check only low if {$e_check < $low} { arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname } @@ -4300,7 +4300,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } - #high and low specified + #high and low specified if {$e_check < $low || $e_check > $high} { arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname } @@ -4312,7 +4312,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname } - } + } } } double { @@ -4465,7 +4465,7 @@ tcl::namespace::eval punk::args { set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] if {[llength $receivednames]} { #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] set i -1 set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] } else { @@ -4474,15 +4474,15 @@ tcl::namespace::eval punk::args { #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) #(e.g using 'dict exists $received -flag') # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements + #It is actually a list of paired elements return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] } #proc sample1 {p1 args} { # #*** !doctools # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" + # #[para]Description of sample1 + # return "ok" #} @@ -4513,14 +4513,14 @@ tcl::namespace::eval punk::args::lib { tcl::namespace::path [list [tcl::namespace::parent]] #*** !doctools #[subsection {Namespace punk::args::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 + # #[para]Description of utility1 + # return 1 #} proc flatzip {l1 l2} { @@ -4540,8 +4540,8 @@ tcl::namespace::eval punk::args::lib { lsearch -all [lrepeat $count 0] * } } - - + + #experiment with equiv of js template literals with ${expression} in templates #e.g tstr {This is the value of x in calling scope ${$x} !} #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} @@ -4552,7 +4552,7 @@ tcl::namespace::eval punk::args::lib { "A rough equivalent of js template literals Substitutions: - \$\{$varName\} + \$\{$varName\} \$\{[myCommand]\} (when -allowcommands flag is given)" -allowcommands -default 0 -type none -help\ @@ -4569,7 +4569,7 @@ tcl::namespace::eval punk::args::lib { -paramindents -default line -choices {none line position} -choicelabels { line\ " Use leading whitespace in - the line in which the + the line in which the placeholder occurs." position\ " Use the position in @@ -4578,21 +4578,21 @@ tcl::namespace::eval punk::args::lib { none\ " No indents applied to subsequent placeholder value - lines. This will usually - result in text awkwardly + lines. This will usually + result in text awkwardly ragged unless the source code has also been aligned with the left margin or the value has been manually padded." } -help\ - "How indenting is done for subsequent lines in a + "How indenting is done for subsequent lines in a multi-line placeholder substitution value. The 1st line or a single line value is always placed at the placeholder. - paramindents are performed after the main + paramindents are performed after the main template has been indented/undented. (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) + unicode double-wide or grapheme cluster widths) " #choicelabels indented by 1 char is clearer for -return string - and reasonable in table -return -default string -choices {dict list string args}\ @@ -4603,7 +4603,7 @@ tcl::namespace::eval punk::args::lib { 'errors'" string\ " Return a single result - being the string with + being the string with placeholders substituted." list\ " Return a 2 element list. @@ -4636,7 +4636,7 @@ tcl::namespace::eval punk::args::lib { For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. contained variables in that case should be braced or whitespace separated, or the variable name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" @values -min 0 -max 1 templatestring -help\ "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} @@ -4645,19 +4645,19 @@ tcl::namespace::eval punk::args::lib { It can contain commands in square brackets if -allowcommands is true e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - Escape sequences such as \\n and unicode escapes are processed within placeholders. + Escape sequences such as \\n and unicode escapes are processed within placeholders. " }] proc tstr {args} { #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only + # - we use punk::args within the unhappy path only #set argd [punk::args::get_by_id ::punk::lib::tstr $args] #set templatestring [dict get $argd values templatestring] #set opt_allowcommands [dict get $argd opts -allowcommands] #set opt_return [dict get $argd opts -return] #set opt_eval [dict get $argd opts -eval] - + set templatestring [lindex $args end] set arglist [lrange $args 0 end-1] set opts [dict create\ @@ -4773,7 +4773,7 @@ tcl::namespace::eval punk::args::lib { } if {$opt_eval} { if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] + lappend params [string cat \$\{ $expression \}] dict set errors [expr {[llength $params]-1}] $result } else { set result [string map [list \n "\n$leader"] $result] @@ -4790,7 +4790,7 @@ tcl::namespace::eval punk::args::lib { if {$opt_return eq "dict"} { return [dict create template $textchunks params $params errors $errors] - } + } if {[dict size $errors]} { set einfo "" dict for {i e} $errors { @@ -4828,7 +4828,7 @@ tcl::namespace::eval punk::args::lib { set lastline [string range $pt $lastline_posn+1 end] } if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent + regexp {(\s*).*} $lastline _all lastindent } else { #position #TODO - detect if there are grapheme clusters @@ -4847,8 +4847,8 @@ tcl::namespace::eval punk::args::lib { } } else { append out $pt $param - } - append lastline $param + } + append lastline $param } } return $out @@ -4859,9 +4859,9 @@ tcl::namespace::eval punk::args::lib { proc tstr_test_one {args} { set argd [punk::args::get_dict { @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. - example: + example: set id 2 - tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] } @values -min 2 -max 2 @@ -4882,8 +4882,8 @@ tcl::namespace::eval punk::args::lib { } set chars [split $templatestring ""] set in_placeholder 0 - set tchars "" - set echars "" + set tchars "" + set echars "" set parts [list] set i 0 foreach ch $chars { @@ -4912,7 +4912,7 @@ tcl::namespace::eval punk::args::lib { } else { append echars $ch } - } + } } incr i } @@ -4932,7 +4932,7 @@ tcl::namespace::eval punk::args::lib { } set list [list] set start 0 - #ideally re should allow curlies within but we will probably need a custom parser to do it + #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 {\$\{(?:(?!\$\{).)*\}} @@ -4945,14 +4945,14 @@ tcl::namespace::eval punk::args::lib { #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 + 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] + 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]} { @@ -4967,7 +4967,7 @@ tcl::namespace::eval punk::args::lib { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { - lappend result "" + lappend result "" } else { lappend result $prefix[string trimright $line] } @@ -5009,7 +5009,7 @@ tcl::namespace::eval punk::args::lib { #hacky proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be + #leader usually whitespace - but doesn't have to be if {$text eq ""} { return "" } @@ -5044,7 +5044,7 @@ tcl::namespace::eval punk::args::lib { } return [join $result \n] } - #A version of textutil::string::longestCommonPrefixList + #A version of textutil::string::longestCommonPrefixList proc longestCommonPrefix {items} { if {[llength $items] <= 1} { return [lindex $items 0] @@ -5061,9 +5061,9 @@ tcl::namespace::eval punk::args::lib { } set n [string length $min] set prefix "" - set i -1 + set i -1 while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c + append prefix $c } return $prefix } @@ -5099,7 +5099,7 @@ tcl::namespace::eval punk::args::package { " -package_about_namespace -type string -optional 0 -help\ "Namespace containing the package about procedures - Must contain " + Must contain " -return\ -type string\ -default table\ @@ -5140,7 +5140,7 @@ tcl::namespace::eval punk::args::package { set pkgname [${pkgns}::package_name] set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] + set all_topics [${pkgns}::about_topics] if {![dict exists $received topic]} { set topics $all_topics } else { @@ -5214,7 +5214,7 @@ tcl::namespace::eval punk::args::package { #can't do this here? - as there is circular dependency with punk::lib #tcl::namespace::eval punk::args { # foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist +# punk::args::define {*}$deflist # } # set PUNKARGS "" #} @@ -5227,7 +5227,7 @@ lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::p tcl::namespace::eval punk::args::system { #*** !doctools #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #dict get value with default wrapper for tcl 8.6 if {[info commands ::tcl::dict::getdef] eq ""} { @@ -5240,11 +5240,11 @@ tcl::namespace::eval punk::args::system { } } } else { - #we pay a minor perf penalty for the wrap + #we pay a minor perf penalty for the wrap interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef } - #name to reflect maintenance - home is punk::lib::ldiff + #name to reflect maintenance - home is punk::lib::ldiff proc punklib_ldiff {fromlist removeitems} { if {[llength $removeitems] == 0} {return $fromlist} set result {} @@ -5260,12 +5260,12 @@ tcl::namespace::eval punk::args::system { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args 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/punk/assertion-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm index 8ad0af62..80f4b14d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::assertion 0 0.1.0] #[copyright "2024"] #[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] -#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] +#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] #[require punk::assertion] #[keywords module assertion assert debug] #[description] @@ -99,9 +99,9 @@ tcl::namespace::eval punk::assertion::class { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin +#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin tcl::namespace::eval punk::assertion::primary { - #tcl::namespace::export {[a-z]*} + #tcl::namespace::export {[a-z]*} tcl::namespace::export assertActive assertInactive proc assertActive {expr args} { @@ -112,7 +112,7 @@ tcl::namespace::eval punk::assertion::primary { if {![tcl::string::is boolean -strict $res]} { return -code error "invalid boolean expression: $expr" } - + if {$res} {return} if {[llength $args]} { @@ -130,9 +130,9 @@ tcl::namespace::eval punk::assertion::primary { } tcl::namespace::eval punk::assertion::secondary { - tcl::namespace::export * + tcl::namespace::export * #we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want. - proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] + proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] proc assertInactive args {} } @@ -151,7 +151,7 @@ tcl::namespace::eval punk::assertion { } do_ns_import #puts --------BBB - rename assertActive assert + rename assertActive assert } @@ -162,20 +162,20 @@ tcl::namespace::eval punk::assertion { #*** !doctools #[subsection {Namespace punk::assertion}] - #[para] Core API functions for punk::assertion + #[para] Core API functions for punk::assertion #[list_begin definitions] #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]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" #} #like tcllib's control::assert - we are limited to the same callback for all namespaces. @@ -218,7 +218,7 @@ tcl::namespace::eval punk::assertion { if {$on_off} { #Enable it in calling namespace if {"assert" eq $info_command} { - #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) + #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] @@ -243,7 +243,7 @@ tcl::namespace::eval punk::assertion { } return 1 } else { - #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace + #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] if {[tcl::string::match ::punk::assertion::* $assertorigin]} { @@ -303,8 +303,8 @@ tcl::namespace::eval punk::assertion { return 0 } } else { - #no assert command reachable - #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path + #no assert command reachable + #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" return 0 } @@ -327,14 +327,14 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::assertion::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 + # #[para]Description of utility1 + # return 1 #} @@ -352,7 +352,7 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::eval punk::assertion::system { #*** !doctools #[subsection {Namespace punk::assertion::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #Maintenance - snarfed from punk::ns to reduce dependencies - punk::ns::nsprefix is the master version #nsprefix/nstail are string functions - they do not concern themselves with what namespaces are present in the system @@ -375,7 +375,7 @@ tcl::namespace::eval punk::assertion::system { proc nstail {nspath args} { #normalize the common case of :::: set nspath [tcl::string::map [list :::: ::] $nspath] - set mapped [tcl::string::map [list :: \u0FFF] $nspath] + set mapped [tcl::string::map [list :: \u0FFF] $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] @@ -411,11 +411,11 @@ tcl::namespace::eval punk::assertion::system { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::assertion [tcl::namespace::eval punk::assertion { variable pkg punk::assertion 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/punk/cap-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm index 68d3252e..2ede3723 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm @@ -26,7 +26,7 @@ #[para]punk::cap provides management of named capabilities and the provider packages and handler packages that implement a pluggable capability. #[para]see also [uri https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/pluginmgr/pluginmgr.md {tcllib pluginmgr}] for an alternative which uses safe interpreters #[subsection Concepts] -#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API +#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API # #[para][term {capability handler}] - a package/namespace which may provide validation and standardised ways of looking up provider data # registered (or not) using register_capabilityname @@ -49,7 +49,7 @@ package require oolib # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::cap { - variable pkgcapsdeclared [tcl::dict::create] + variable pkgcapsdeclared [tcl::dict::create] variable pkgcapsaccepted [tcl::dict::create] variable caps [tcl::dict::create] namespace eval class { @@ -71,8 +71,8 @@ tcl::namespace::eval punk::cap { #*** !doctools #[call class::interface_caphandler.registry [method pkg_register] [arg pkg] [arg capname] [arg capdict] [arg fullcapabilitylist]] #handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid - #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. - return 1 ;#default to permit + #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. + return 1 ;#default to permit } method pkg_unregister {pkg} { #*** !doctools @@ -106,9 +106,9 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.registration { #*** !doctools # [enum] CLASS [class interface_cappprovider.registration] - # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. + # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. # [para]If your package namespace is mypackages::providerpkg then the object command would be at mypackages::providerpkg::capsystem::capprovider.registration - # [para]Example code for your provider package to evaluate within its namespace: + # [para]Example code for your provider package to evaluate within its namespace: # [example { #namespace eval capsystem { # if {[info commands capprovider.registration] eq ""} { @@ -133,7 +133,7 @@ tcl::namespace::eval punk::cap { #[para] This method must be overridden by your provider using oo::objdefine cappprovider.registration as in the example above. # There must be at least one 2-element list in the result for the provider to be registerable. #[para]The first element of the list is the capabilityname - which can be custom to your provider/handler packages - or a well-known name that other authors may use/implement. - #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. + #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. error "interface_capprovider.registration not implemented by provider" } #*** !doctools @@ -142,11 +142,11 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.provider { #*** !doctools - # [enum] CLASS [class interface_capprovider.provider] - # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] + # [enum] CLASS [class interface_capprovider.provider] + # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] # [example { - # namespace eval mypackages::providerpkg { - # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg + # namespace eval mypackages::providerpkg { + # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg # } # }] # [list_begin definitions] @@ -229,7 +229,7 @@ tcl::namespace::eval punk::cap { #Not all capability names have to be registered. #A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated handler. - #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. + #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. #we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. proc register_capabilityname {capname capnamespace} { #puts stderr "REGISTER_CAPABILITYNAME $capname $capnamespace" @@ -243,10 +243,10 @@ tcl::namespace::eval punk::cap { } } #allow register of existing capname iff there is no current handler - #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package - #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers + #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package + #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers if {[set hdlr [capability_get_handler $capname]] ne ""} { - puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" + puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" return } #assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. @@ -295,14 +295,14 @@ tcl::namespace::eval punk::cap { if {$count == 0} { set pkgposn [lsearch $providers $pkg] if {$pkgposn >= 0} { - set updated_providers [lreplace $providers $posn $posn] + set updated_providers [lreplace $providers $posn $posn] tcl::dict::set caps $capname providers $updated_providers } } } } - + } } proc capability_exists {capname} { @@ -328,7 +328,7 @@ tcl::namespace::eval punk::cap { if {[tcl::dict::exists $caps $capname]} { return [tcl::dict::get $caps $capname handler] } - return "" + return "" } proc call_handler {capname args} { if {[set handler [capability_get_handler $capname]] eq ""} { @@ -461,7 +461,7 @@ tcl::namespace::eval punk::cap { #todo! proc unregister_package {pkg {capname *}} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] @@ -471,7 +471,7 @@ tcl::namespace::eval punk::cap { set capabilitylist [dict get $pkgcapsdeclared $pkg] foreach c $capabilitylist { set do_unregister 1 - lassign $c capname _capdict + lassign $c capname _capdict set cap_info [dict get $caps $capname] set pkglist [dict get $cap_info providers] set posn [lsearch $pkglist $pkg] @@ -479,9 +479,9 @@ tcl::namespace::eval punk::cap { if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { #review # it seems not useful to allow the callback to block this unregister action - #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter - #vetoing unregister would make this more complex for no particular advantage - #if per dataset deregistration required this should probably be a separate thing + #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter + #vetoing unregister would make this more complex for no particular advantage + #if per dataset deregistration required this should probably be a separate thing $capreg pkg_unregister $pkg $capname } set pkglist [lreplace $pkglist $posn $posn] @@ -510,7 +510,7 @@ tcl::namespace::eval punk::cap { } } proc pkgcaps {} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable pkgcapsaccepted set result [dict create] foreach {pkg capsdeclared} $pkgcapsdeclared { @@ -522,7 +522,7 @@ tcl::namespace::eval punk::cap { dict set result $pkg accepted $accepted } return $result - } + } proc capability {capname} { variable caps @@ -565,14 +565,14 @@ tcl::namespace::eval punk::cap { #[subsection {Namespace punk::cap::advanced}] #[para] punk::cap::advanced API. Functions here are generally not the preferred way to interact with punk::cap. #[para] In some cases they may allow interaction in less safe ways or may allow use of features that are unavailable in the base namespace. - #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. + #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. #[list_begin definitions] proc promote_provider {pkg} { #*** !doctools # [call advanced::[fun promote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. #[para] #[para] promote/demote doesn't always make a lot of sense .. should preferably be configurable per capapbility for multicap provider pkgs #[para]The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded @@ -615,7 +615,7 @@ tcl::namespace::eval punk::cap { #*** !doctools # [call advanced::[fun demote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { @@ -677,11 +677,11 @@ tcl::namespace::eval punk::cap { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap [namespace eval punk::cap { variable version variable pkg punk::cap - set version 0.1.0 + set version 0.1.0 variable README.md [string map [list %pkg% $pkg %ver% $version] { # punk capabilities system ## pkg: %pkg% version: %ver% diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm index 8fdce944..4a19666b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm @@ -43,10 +43,10 @@ namespace eval punk::cap::handlers::caphandler { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { variable pkg punk::cap::handlers::caphandler variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index 5624ec58..60764f07 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -23,7 +23,7 @@ package require punk::repo # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #register using: -# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates +# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates #By convention and for consistency, we don't register here during package loading - but require the calling app to do it. # (even if it tends to be done immediately after package require anyway) @@ -67,11 +67,11 @@ namespace eval punk::cap::handlers::templates { #for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called - #for template pathtype absolute - we can do the same. - #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. + #for template pathtype absolute - we can do the same. + #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. #adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time. - #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - + #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - #but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly. switch -- $pathtype { adhoc { @@ -95,7 +95,7 @@ namespace eval punk::cap::handlers::templates { } else { set tm_exists [file exists $tmfile] } - if {![file exists $tmfile]} { + if {!$tm_exists} { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" flush stderr return 0 @@ -128,7 +128,7 @@ namespace eval punk::cap::handlers::templates { } set extended_capdict $capdict - dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? + dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? } currentproject { if {[file pathtype $path] ne "relative"} { @@ -140,7 +140,7 @@ namespace eval punk::cap::handlers::templates { set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor } shellproject { if {[file pathtype $path] ne "relative"} { @@ -150,7 +150,7 @@ namespace eval punk::cap::handlers::templates { set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review set projectinfo [punk::repo::find_repos $shellbase] set projectbase [dict get $projectinfo closest] - + set extended_capdict $capdict dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase @@ -170,7 +170,7 @@ namespace eval punk::cap::handlers::templates { set projectbase [dict get $projectinfo closest] set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } absolute { @@ -188,7 +188,7 @@ namespace eval punk::cap::handlers::templates { #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict - dict set extended_capdict resolved_path $normpath + dict set extended_capdict resolved_path $normpath dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } @@ -199,7 +199,7 @@ namespace eval punk::cap::handlers::templates { } # -- --- --- --- --- --- --- ---- --- - # update package internal data + # update package internal data # -- --- --- --- --- --- --- ---- --- upvar ::punk::cap::handlers::templates::provider_info_$cname provider_info @@ -208,13 +208,13 @@ namespace eval punk::cap::handlers::templates { } if {![info exists provider_info] || $extended_capdict ni [dict get $provider_info $pkg]} { #this checks for duplicates from the same provider - but not if other providers already added the path - #review - + #review - dict lappend provider_info $pkg $extended_capdict } # -- --- --- --- --- --- --- ---- --- - # instantiation of api at punk::cap::handlers::templates::api_$capname + # instantiation of api at punk::cap::handlers::templates::api_$capname # -- --- --- --- --- --- --- ---- --- set apicmd "::punk::cap::handlers::templates::api_$capname" if {[info commands $apicmd] eq ""} { @@ -227,12 +227,12 @@ namespace eval punk::cap::handlers::templates { upvar ::punk::cap::handlers::templates::handled_caps hcaps foreach capname $hcaps { set cname [string map {. _} $capname] - upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info + upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info dict unset my_provider_info $pkg #destroy api objects? } } - } + } } } @@ -293,7 +293,7 @@ namespace eval punk::cap::handlers::templates { set found_paths_absolute [list] - foreach pkg $providerpkg { + foreach pkg $providerpkg { set found_paths [list] #set acceptedlist [dict get [punk::cap::pkgcap $pkg $capabilityname] accepted] @@ -314,13 +314,13 @@ namespace eval punk::cap::handlers::templates { set module_projectroot [dict get $capdecl_extended projectbase] dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] } elseif {$pathtype eq "currentproject_multivendor"} { - set searchbase $startdir + set searchbase $startdir set pathinfo [punk::repo::find_repos $searchbase] set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { set deckbase [file join $pwd_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -349,7 +349,7 @@ namespace eval punk::cap::handlers::templates { } } } elseif {$pathtype eq "currentproject"} { - set searchbase $startdir + set searchbase $startdir set pathinfo [punk::repo::find_repos $searchbase] set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { @@ -369,7 +369,7 @@ namespace eval punk::cap::handlers::templates { if {$shell_projectroot ne ""} { set deckbase [file join $shell_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -471,19 +471,19 @@ namespace eval punk::cap::handlers::templates { return $folderdict } method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { + set argd [punk::args::get_dict { @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" @opts -anyopts 1 #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here -startdir -default "" @values -maxvalues -1 - } $args] + } $args] set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { set searchbase [pwd] } else { - set searchbase $opt_startdir + set searchbase $opt_startdir } set refdict [my get_itemdict_projectlayoutrefs {*}$args] @@ -502,7 +502,7 @@ namespace eval punk::cap::handlers::templates { # e.g ref may be @vendor+punks+othersample@sample-0.1 or layoutalias-1.1@vendor+punk+othersample@sample-0.1 #there must always be an @ before vendor or custom . There is either a template-name alias or empty string before this first @ #trim off first @ part - set tailats [join [lrange $atparts 1 end] @] + set tailats [join [lrange $atparts 1 end] @] # @ parts after the first are part of the path within the project_layouts structure set subpathlist [split $tailats +] if {[dict exists $refinfo sourceinfo projectbase]} { @@ -553,7 +553,7 @@ namespace eval punk::cap::handlers::templates { if {$vendor ne "_project"} { set itemname $vendor.$itemname } - return $itemname + return $itemname }}} } set arglist [concat $config $args] @@ -623,7 +623,7 @@ namespace eval punk::cap::handlers::templates { }}}\ -command_get_item_name {apply {{vendor basefolder itempath} { - set relativepath [punk::path::relative $basefolder $itempath] + set relativepath [punk::path::relative $basefolder $itempath] set dirs [file dirname $relativepath] if {$dirs eq "."} { set dirs "" @@ -636,7 +636,7 @@ namespace eval punk::cap::handlers::templates { } if {$vendor ne "_project"} { set tname ${vendor}.$tname - } + } return $tname }}} } @@ -645,11 +645,11 @@ namespace eval punk::cap::handlers::templates { } #shared algorithm for get_itemdict_* methods - #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search + #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { + set argd [punk::args::get_dict { @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" @cmd -name _get_itemdict @opts -anyopts 0 @@ -657,7 +657,7 @@ namespace eval punk::cap::handlers::templates { -templatefolder_subdir -optional 0 -command_get_items_from_base -optional 0 -command_get_item_name -optional 0 - -not -default "" -multiple 1 + -not -default "" -multiple 1 @values -maxvalues -1 globsearches -default * -multiple 1 } $args] @@ -697,12 +697,12 @@ namespace eval punk::cap::handlers::templates { set items_here [dict create] ;#maintain a list keyed on name for sorting within this base only foreach itempath $matches { set itemname [{*}$opt_command_get_item_name $vendor $basefolder $itempath] - dict set items_here $itemname [list item $itempath baseinfo $baseinfo] + dict set items_here $itemname [list item $itempath baseinfo $baseinfo] #lappend items [list item $itempath baseinfo $baseinfo] } set ordered_names [lsort [dict keys $items_here]] - #add to the outer items list - foreach nm $ordered_names { + #add to the outer items list + foreach nm $ordered_names { set iteminfo [dict get $items_here $nm] lappend items [list originalname $nm iteminfo $iteminfo] } @@ -715,8 +715,8 @@ namespace eval punk::cap::handlers::templates { set itempath [dict get $iteminfo item] set baseinfo [dict get $iteminfo baseinfo] if {![dict exists $seen_dict $oname]} { - dict set seen_dict $oname 1 - dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number + dict set seen_dict $oname 1 + dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number } else { set n [dict get $seen_dict $oname] incr n @@ -730,7 +730,7 @@ namespace eval punk::cap::handlers::templates { set result [dict create] set keys [lreverse [dict keys $itemdict]] foreach k $keys { - set maybe "" + set maybe "" foreach g $globsearches { if {[string match $g $k]} { set maybe $k @@ -745,7 +745,7 @@ namespace eval punk::cap::handlers::templates { break } } - } + } if {$maybe ne "" && $not eq ""} { dict set result $k [dict get $itemdict $k] } @@ -762,10 +762,10 @@ namespace eval punk::cap::handlers::templates { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { variable pkg punk::cap::handlers::templates variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index 43dcd6b5..675f42b0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_punk::char 0 0.1.0] #[copyright "2024"] #[titledesc {character-set and unicode utilities}] [comment {-- Name section and table of contents description --}] -#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] +#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] #[require punk::char] #[keywords module encodings] #[description] @@ -49,11 +49,11 @@ #*** !doctools #[item] [package {overtype}] -#[para] - +#[para] - #[item] [package {textblock}] -#[para] - +#[para] - #[item] [package console] -#[para] - +#[para] - package require Tcl 8.6- #dependency on tcllib not ideal for bootstrapping as punk::char is core to many features.. (textutil::wcswidth is therefore included in bootsupport/include_modules.config) review @@ -92,20 +92,20 @@ tcl::namespace::eval punk::char { #just the 7-bit ascii. use [page ascii] for the 8-bit layout proc ascii {} {return { 00 NUL 01 SOH 02 STX 03 ETX 04 EOT 05 ENQ 06 ACK 07 BEL - 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI + 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI 10 DLE 11 DC1 12 DC2 13 DC3 14 DC4 15 NAK 16 SYN 17 ETB - 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US - 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' - 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / - 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 - 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? - 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G - 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O - 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W - 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ - 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g - 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o - 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w + 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US + 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' + 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / + 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 + 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? + 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G + 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O + 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W + 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ + 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g + 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o + 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w 78 x 79 y 7a z 7b { 7c | 7d } 7e ~ 7f DEL }} @@ -124,7 +124,7 @@ tcl::namespace::eval punk::char { } elseif {[tcl::string::length $v] == 0} { set v " " } - append out "$k $v " + append out "$k $v " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -143,7 +143,7 @@ tcl::namespace::eval punk::char { set out "" append out [page dingbats] \n set unicode_dict [charset_dictget Dingbats] - + append out " " set i 1 tcl::dict::for {k charinfo} $unicode_dict { @@ -155,7 +155,7 @@ tcl::namespace::eval punk::char { } else { set displayv $char } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -205,7 +205,7 @@ tcl::namespace::eval punk::char { tcl::dict::lappend d $encname $mname } } - } + } foreach enc [lsort $encnames] { set mime_enc [${encmimens}::mapencoding $enc] if {$mime_enc ne ""} { @@ -236,7 +236,7 @@ tcl::namespace::eval punk::char { tailcall page $encname {*}$args } - #This will not display for example, c0 glyphs for cp437 + #This will not display for example, c0 glyphs for cp437 # we could use the punk::ansi::cp437_map dict - but while that might be what some expect to see - it would probably be too much magic for this function - which is intended to align more with what Tcl's encoding convertfrom/to actually does. # for nonprinting members of the page, 2 and 3 letter codes are used rather than unicode visualisation replacements or even unicode equivalent replacements known to be appropriate for the page proc page {encname args} { @@ -255,7 +255,7 @@ tcl::namespace::eval punk::char { #set d_ascii [pagedict_raw ascii] set d_ascii [basedict] - set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi + set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi #The results of this are best seen by comparing the ebcdic and ascii pages set d_page [pagedict_raw $encname] @@ -285,7 +285,7 @@ tcl::namespace::eval punk::char { set displayv $bytedisplay } else { if {[tcl::string::length $rawchar] == 0} { - set displayv " " + set displayv " " } else { #presumed 1 set displayv " $rawchar " @@ -294,7 +294,7 @@ tcl::namespace::eval punk::char { } } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % $cols == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -318,7 +318,7 @@ tcl::namespace::eval punk::char { set outchar [encoding convertfrom $encpage $ch] } else { #here we will use \0xFFFD instead of our replacement string ??? - as the name pagechar implies always returning a single character. REVIEW. - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -348,7 +348,7 @@ tcl::namespace::eval punk::char { #set outchar [encoding convertto $encpage [format %c $num]] set outchar [format %c $num] } else { - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -381,7 +381,7 @@ tcl::namespace::eval punk::char { } proc pagedict_raw {encname} { - variable invalid ;# ="???" + variable invalid ;# ="???" set encname [encname $encname] set d [tcl::dict::create] for {set i 0} {$i < 256} {incr i} { @@ -409,7 +409,7 @@ tcl::namespace::eval punk::char { tcl::dict::set d $k [tcl::dict::get $a128 $k] } else { # - tcl::dict::set d $k $invalid + tcl::dict::set d $k $invalid } if {$i <=32} { @@ -457,7 +457,7 @@ tcl::namespace::eval punk::char { } return $d } - + proc basedict {} { #this gives same result independent of current value of 'encoding system' set d [tcl::dict::create] @@ -529,10 +529,10 @@ tcl::namespace::eval punk::char { return $d } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- # encoding convertfrom & encoding convertto can be somewhat confusing to think about. (Need to think in reverse.) # e.g encoding convertto dingbats will output something that doesn't look dingbatty on screen. - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- #must use Tcl instead of tcl (at least for 8.6) if {![package vsatisfies [package present Tcl] 8.7-]} { proc encodable "s {enc [encoding system]}" { @@ -574,7 +574,7 @@ tcl::namespace::eval punk::char { } } } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- proc test_japanese {{encoding jis0208}} { #A very basic test of 2char encodings such as jis0208 set yatbun 日本 ;# encoding convertfrom jis0208 F|K\\ @@ -584,7 +584,7 @@ tcl::namespace::eval punk::char { set ebun [encoding convertto $encoding $bun] puts "$encoding encoded: ${eyat} ${ebun}" puts "reencoded: [encoding convertfrom $encoding $eyat] [encoding convertfrom $encoding $ebun]" - return $yatbun + return $yatbun } proc test_grave {} { set g [format %c 0x300] @@ -692,7 +692,7 @@ tcl::namespace::eval punk::char { #ESC ( B ESC ) B ASCII Set #ESC ( 0 ESC ) 0 Special Graphics #ESC ( 1 ESC ) 1 Alternate Character ROM Standard Character Set - #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic + #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Unicode character sets - some hardcoded - some loadable from data files @@ -700,7 +700,7 @@ tcl::namespace::eval punk::char { variable charinfo [tcl::dict::create] variable charsets [tcl::dict::create] - + # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Aggregate character sets (ones that pick various ranges from underlying unicode ranges) # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -741,7 +741,7 @@ tcl::namespace::eval punk::char { } # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # Unicode ranges + # Unicode ranges # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- tcl::dict::set charsets "greek" [list ranges [list {start 880 end 1023} {start 7936 end 8191}] description "Greek and Coptic" settype "other"] @@ -975,9 +975,9 @@ tcl::namespace::eval punk::char { variable charset_extents_rangenames ;# dict keyed on start,end pointing to list of 2-tuples {setname rangeindex_within_set} #build 2 indexes for each range.(charsets are not just unicode blocks so can have multiple ranges) #Note that a range could be as small as a single char (startpoint = endpoint) so there can be many ranges with same start and end if charsets use some of the same subsets. - #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict - #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key - #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key + #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict + #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key + #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key proc _build_charset_extents {} { variable charsets variable charset_extents_startpoints @@ -995,7 +995,7 @@ tcl::namespace::eval punk::char { set end [tcl::dict::get [lindex $ranges 0] end] if {![tcl::dict::exists $charset_extents_startpoints $start] || $end ni [tcl::dict::get $charset_extents_startpoints $start]} { #assertion if end wasn't in startpoits list - then start won't be in endpoints list - tcl::dict::lappend charset_extents_startpoints $start $end + tcl::dict::lappend charset_extents_startpoints $start $end tcl::dict::lappend charset_extents_endpoints $end $start } tcl::dict::lappend charset_extents_rangenames ${start},${end} [list $setname 1] @@ -1023,14 +1023,14 @@ tcl::namespace::eval punk::char { #no need to sort charset_extents_rangenames - lookup only done using dict methods return [tcl::dict::size $charset_extents_startpoints] } - _build_charset_extents ;#rebuilds for all charsets + _build_charset_extents ;#rebuilds for all charsets #nerdfonts are within the Private use E000 - F8FF range proc load_nerdfonts {} { variable charsets variable charinfo package require fileutil - set ver [package provide punk::char] + set ver [package provide punk::char] if {$ver ne ""} { set ifneeded [package ifneeded punk::char [package provide punk::char]] #puts stderr "punk::char ifneeded script: $ifneeded" @@ -1038,7 +1038,7 @@ tcl::namespace::eval punk::char { set basedir [file dirname [lindex $sourceinfo end]] } else { #review - will only work at package load time - set scr [info script] + set scr [info script] if {$scr eq ""} { error "load_nerdfonts unable to determine package folder" } @@ -1048,7 +1048,7 @@ tcl::namespace::eval punk::char { set fname [file join $pkg_data_dir nerd-fonts-glyph-list.txt] if {[file exists $fname]} { #puts stderr "load_nerdfonts loading $fname" - set data [fileutil::cat -translation binary $fname] + set data [fileutil::cat -translation binary $fname] set short_seen [tcl::dict::create] set current_set_range [tcl::dict::create] set filesets_loading [list] @@ -1066,7 +1066,7 @@ tcl::namespace::eval punk::char { dict unset charset $setname } set newrange [list start $dec end $dec] - tcl::dict::set current_set_range $setname $newrange + tcl::dict::set current_set_range $setname $newrange tcl::dict::set charsets $setname [list ranges [list $newrange] description "nerd fonts $rawsetname" settype "nerdfonts privateuse"] lappend filesets_loading $setname @@ -1080,13 +1080,13 @@ tcl::namespace::eval punk::char { #overwrite last ranges element set rangelist [lrange [tcl::dict::get $charsets $setname ranges] 0 end-1] lappend rangelist [tcl::dict::get $current_set_range $setname] - tcl::dict::set charsets $setname ranges $rangelist + tcl::dict::set charsets $setname ranges $rangelist } else { #new range for set tcl::dict::set current_set_range $setname start $dec tcl::dict::set current_set_range $setname end $dec set rangelist [tcl::dict::get $charsets $setname ranges] - lappend rangelist [tcl::dict::get $current_set_range $setname] + lappend rangelist [tcl::dict::get $current_set_range $setname] tcl::dict::set charsets $setname ranges $rangelist } @@ -1130,7 +1130,7 @@ tcl::namespace::eval punk::char { proc package_base {} { #assume punk::char is in .tm form and we can use the package provide statement to determine base location - #review + #review set pkgver [package present punk::char] set pkginfo [package ifneeded punk::char $pkgver] set tmfile [lindex $pkginfo end] @@ -1156,7 +1156,7 @@ tcl::namespace::eval punk::char { if {[tcl::dict::exists $dictValue {*}$keys]} { return [tcl::dict::get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } } @@ -1181,7 +1181,7 @@ tcl::namespace::eval punk::char { } puts "ok.. loading" set fd [open $file r] - fconfigure $fd -translation binary + chan configure $fd -translation binary set data [read $fd] close $fd set block_count 0 @@ -1193,7 +1193,7 @@ tcl::namespace::eval punk::char { if {[set pcolon [tcl::string::first ";" $ln]] > 0} { set lhs [tcl::string::trim [tcl::string::range $ln 0 $pcolon-1]] set name [tcl::string::trim [tcl::string::range $ln $pcolon+1 end]] - set lhsparts [split $lhs .] + set lhsparts [split $lhs .] set start [lindex $lhsparts 0] set end [lindex $lhsparts end] #puts "$start -> $end '$name'" @@ -1207,9 +1207,9 @@ tcl::namespace::eval punk::char { return $block_count } - #unicode scripts + #unicode scripts - #unicode UnicodeData.txt + #unicode UnicodeData.txt @@ -1225,8 +1225,8 @@ tcl::namespace::eval punk::char { # -- --- #A = Ambiguous - All characters that can be sometimes wide and sometimes narrow. (wide in east asian legacy sets, narrow in non-east asian usage) (private use chars considered ambiguous) #F = East Asian Full-width - #H = East Asian Half-width - #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na + #H = East Asian Half-width + #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na #Na = East Asian Narrow - all other characters that are always narrow and have explicit full-width counterparts (e.g includes all of ASCII) #W = East Asian Wide - all other characters that are always wide (Occur only in the context of Eas Asian Typography) # -- --- @@ -1304,7 +1304,7 @@ tcl::namespace::eval punk::char { set initial_fields $known_fields if {"testwidth" ni $opt_fields} { if {"testwidth" ni $opt_except} { - lappend opt_except testwidth + lappend opt_except testwidth } } if {"char" ni $opt_fields} { @@ -1369,13 +1369,13 @@ tcl::namespace::eval punk::char { #testwidth is one of the main ones likely to be worthwhile excluding as querying the console via ansi takes time set existing_testwidth "" if {[tcl::dict::exists $charinfo $dec_char testwidth]} { - set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] + set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] } if {$existing_testwidth eq ""} { #no cached data - do expensive cursor-position test (Note this might not be 100% reliable - terminals lie e.g if ansi escape sequence has set to wide printing.) set char [format %c $dec_char] set chwidth [char_info_testwidth $char] - + tcl::dict::set returninfo testwidth $chwidth #cache it. todo - -verify flag to force recalc in case font/terminal changed in some way? tcl::dict::set charinfo $dec_char testwidth $chwidth @@ -1387,10 +1387,10 @@ tcl::namespace::eval punk::char { set char [format %c $dec_char] tcl::dict::set returninfo char $char } - memberof { + memberof { #memberof takes in the order of a few hundred microseconds if a simple scan of all ranges is taken - possibly worthwhile caching/optimising #note that memberof is not just unicode blocks - but scripts and other non-contiguous sets consisting of multiple ranges - some of which may include ranges of a single character. (e.g WGL4) - #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. + #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. #We could potentially populate it using a side-thread - but it seems reasonable to just cache result after first use here. #some efficiency could also be gained by pre-calculating the extents for each charset which isn't a simple unicode block. (and perhaps sorting by max char) set memberof [list] @@ -1435,7 +1435,7 @@ tcl::namespace::eval punk::char { set splen [tcl::dict::size $charset_extents_startpoints] set eplen [tcl::dict::size $charset_extents_endpoints] set s [lsearch -bisect -integer $skeys $dec] - set s_at_or_below [lrange $skeys 0 $s] + set s_at_or_below [lrange $skeys 0 $s] set e_of_s [list] foreach sk $s_at_or_below { lappend e_of_s {*}[tcl::dict::get $charset_extents_startpoints $sk] @@ -1472,16 +1472,16 @@ tcl::namespace::eval punk::char { set eps [list] } - + return [tcl::dict::create startpoints $splen endpoints $eplen midpoint [expr {floor($eplen/2)}] posn $e lhs_endpoints_to_check "[llength $reduced_endpoints]/[llength $e_of_s]=[llength $sps]ranges" rhs_startpoints_to_check "[llength $reduced_startpoints]/[llength $s_of_e]=[llength $eps]"] } #for just a few extra sets such as wgl4 and unicode blocks loaded - this gives e.g 5x + better performance than the simple search above, and up to twice as slow for tcl 8.6 #performance biased towards lower numbered characters (which is not too bad in the context of unicode) #todo - could be tuned to perform better at end by assuming a fairly even distribution of ranges - and so searching startpoint ranges first for items left of middle, endpoint ranges first for items right of middle - #review with scripts loaded and more defined ranges.. + #review with scripts loaded and more defined ranges.. #This algorithm supports arbitrary overlapping ranges and ranges with same start & endpoints #Should be much better than O(n) for n sets except for pathological case of member of all or nearly-all intervals ? - #review - compare with 'interval tree' algorithms. + #review - compare with 'interval tree' algorithms. proc char_info_dec_memberof {dec} { variable charset_extents_startpoints variable charset_extents_endpoints @@ -1563,7 +1563,7 @@ tcl::namespace::eval punk::char { set matchcount 0 foreach glob $and_globs { if {[tcl::string::match -nocase $glob $s] || [tcl::string::match -nocase $glob $d]} { - incr matchcount + incr matchcount } } if {$matchcount == [llength $and_globs]} { @@ -1595,12 +1595,12 @@ tcl::namespace::eval punk::char { } - #non-overlapping unicode blocks + #non-overlapping unicode blocks proc char_blocks {{name_or_glob *}} { variable charsets #todo - more efficient datastructures? if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { if {[tcl::dict::get $charsets $name_or_glob settype] eq "block"} { return [tcl::dict::create $name_or_glob [tcl::dict::get $charsets $name_or_glob]] @@ -1630,7 +1630,7 @@ tcl::namespace::eval punk::char { proc charset_names {{name_or_glob *}} { variable charsets if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { return [list $name_or_glob] } @@ -1641,7 +1641,7 @@ tcl::namespace::eval punk::char { } } else { if {$name_or_glob eq "*"} { - return [lsort [tcl::dict::keys $charsets]] + return [lsort [tcl::dict::keys $charsets]] } #tcl::dict::keys $dict doesn't have option for case insensitive searches return [lsort [lsearch -all -inline -nocase [tcl::dict::keys $charsets] $name_or_glob]] @@ -1655,7 +1655,7 @@ tcl::namespace::eval punk::char { variable charsets #dictionary sorting of the keys is slow! - we should obviously store it in sorted order instead of sorting entire list on retrieval - or just sort results #set sortedkeys [lsort -increasing -dictionary [tcl::dict::keys $charsets]] ;#NOTE must use -dictionary to use -sorted flag below - set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] + set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] if {$namesearch eq "*"} { return $sortedkeys } @@ -1664,7 +1664,7 @@ tcl::namespace::eval punk::char { return [lsearch -all -inline -nocase $sortedkeys $namesearch] ;#no point using -sorted flag when -all is used } else { #return [lsearch -sorted -inline -nocase $sortedkeys $namesearch] ;#no globs - bails out earlier if -sorted? - return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs + return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs } } proc charsets {{namesearch *}} { @@ -1738,7 +1738,7 @@ tcl::namespace::eval punk::char { set opt_ansi [tcl::dict::get $opts -ansi] set opt_lined [tcl::dict::get $opts -lined] # -- --- --- --- - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} if {$opt_ansi} { set a1 [a BLACK white bold] @@ -1768,7 +1768,7 @@ tcl::namespace::eval punk::char { } set i 1 append out \n $prefix $charsetname - append out \n + append out \n set marker_line $prefix set line $prefix @@ -1847,7 +1847,7 @@ tcl::namespace::eval punk::char { } else { set charset_dict [charset_dictget $charsetname] } - + set col_items_short [list] set col_items_desc [list] tcl::dict::for {k inf} $charset_dict { @@ -1873,7 +1873,7 @@ tcl::namespace::eval punk::char { return $out } - #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria + #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria proc charset_calibrate {namesearch args} { variable charsets variable charinfo @@ -1909,7 +1909,7 @@ tcl::namespace::eval punk::char { set twidth [tcl::dict::get $charinfo $dec testwidth] } if {$twidth eq ""} { - #puts -nonewline stdout "." ;#this + #puts -nonewline stdout "." ;#this set width [char_info_testwidth $ch] ;#based on console test rather than unicode props tcl::dict::set charinfo $dec testwidth $width } else { @@ -1925,10 +1925,10 @@ tcl::namespace::eval punk::char { #maint warning - also in overtype! #intended for single grapheme - but will work for multiple - #cannot contain ansi or newlines + #cannot contain ansi or newlines #(a cache of ansifreestring_width calls - as these are quite regex heavy) #review - effective memory leak on longrunning programs if never cleared - #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner + #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner proc grapheme_width_cached {ch {key ""}} { variable grapheme_widths #if key eq "*" - we won't be able to clear that cache individually. Perhaps that's ok @@ -1975,7 +1975,7 @@ tcl::namespace::eval punk::char { # - compare with wcswidth returning -1 for entire string containing such in python,perl proc wcswidth {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) #Tcl initial evaluation stack size is 2000 (? review) #REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!! set chunksize 2000 @@ -1984,14 +1984,14 @@ tcl::namespace::eval punk::char { set startidx 0 set endidx [expr {$startidx + $chunksize -1}] for {set i 0} {$i < $chunks_required} {incr i} { - set chunk [tcl::string::range $string $startidx $endidx] + set chunk [tcl::string::range $string $startidx $endidx] set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] foreach c $codes { if {$c <= 255 && !($c < 31 || $c == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$c < 917504 || $c > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $c] @@ -2023,7 +2023,7 @@ tcl::namespace::eval punk::char { set graphemes [list] while {$i < [tcl::string::length $string]} { set aftercluster [tk::endOfCluster $string $i] - lappend graphemes [string range $string $i $aftercluster-1] + lappend graphemes [string range $string $i $aftercluster-1] set i $aftercluster } return $graphemes @@ -2052,15 +2052,15 @@ tcl::namespace::eval punk::char { } } incr width $gw - + #if {[string first \u200d $g] >=0} { - # incr width 2 + # incr width 2 #} else { # #other joiners??? # incr width [wcswidth_unclustered $g] #} } else { - incr width [wcswidth_unclustered $g] + incr width [wcswidth_unclustered $g] } set i $aftercluster } @@ -2071,8 +2071,8 @@ tcl::namespace::eval punk::char { scan $char %c dec if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - return 1 + #todo - compare with python or other lang wcwidth + return 1 } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars return [textutil::wcswidth_char $dec] ;#note textutil::wcswidth_char takes a decimal codepoint! @@ -2086,8 +2086,8 @@ tcl::namespace::eval punk::char { scan $c %c dec if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $dec] ;#takes decimal codepoint @@ -2105,7 +2105,7 @@ tcl::namespace::eval punk::char { # - compare with wcswidth returning -1 for entire string containing such in python,perl proc wcswidth_unclustered {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) #Tcl initial evaluation stack size is 2000 (? review) #we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!. set chunksize 2000 @@ -2114,14 +2114,14 @@ tcl::namespace::eval punk::char { set startidx 0 set endidx [expr {$startidx + $chunksize -1}] for {set i 0} {$i < $chunks_required} {incr i} { - set chunk [tcl::string::range $string $startidx $endidx] + set chunk [tcl::string::range $string $startidx $endidx] set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] foreach dec $codes { if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $dec] @@ -2141,8 +2141,8 @@ tcl::namespace::eval punk::char { proc wcswidth0 {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ - #TODO + #..but - 'scan' is horrible for 400K+ + #TODO set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]] set width 0 foreach dec $codes { @@ -2150,9 +2150,9 @@ tcl::namespace::eval punk::char { if {$dec < 917504 || $dec > 917631} { if {$dec <= 255} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth + #todo - compare with python or other lang wcwidth if {!($dec < 31 || $dec == 127)} { - incr width + incr width } } else { #TODO - various other joiners and non-printing chars @@ -2179,11 +2179,11 @@ tcl::namespace::eval punk::char { #prerequisites - no ansi escapes - no newlines - utf8 encoding assumed #review - what about \r \t \b ? #NO processing of \b - already handled in ansi::printing_length which then calls this - #this version breaks string into sequences of ascii vs unicode + #this version breaks string into sequences of ascii vs unicode proc ansifreestring_width {text} { #caller responsible for calling ansistrip first if text may have ansi codes - and for ensuring no newlines #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2204,11 +2204,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] # -- --- --- --- --- --- --- @@ -2221,10 +2221,10 @@ tcl::namespace::eval punk::char { #for now - strip them out #ZWNJ \u200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u200b zero width space + #ZWSP \u200b zero width space #\uFFEFBOM/ ZWNBSP and others that should be zero width - #todo - work out proper way to mark/group zero width. + #todo - work out proper way to mark/group zero width. #set text [tcl::string::map [list \u200b "" \u200c "" \u200d "" \uFFEF ""] $text] set text [tcl::string::map [list \u200b "" \u200c "" \u200d ""] $text] @@ -2241,7 +2241,7 @@ tcl::namespace::eval punk::char { #c1 controls - first section of the Latin-1 Supplement block - all non-printable from a utf-8 perspective #some or all of these may have a visual representation in other encodings e.g cp855 seems to have 1 width for them all - #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here + #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here #they should also be unlikely to be present in an ansi-free string (as is a precondition for use of this function) set text [regsub -all {[\u0080-\u009f]+} $text ""] @@ -2262,7 +2262,7 @@ tcl::namespace::eval punk::char { #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] #tcl pre 2023-11 - braced high unicode regexes don't work #fixed in bug-4ed788c618 2023-11 - #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only #maintain unicode as sequences - todo - scan for grapheme clusters #set uc_sequences [punk::ansi::ta::_perlish_split "(?:\[\u0100-\U10FFFF\])+" $text] @@ -2291,7 +2291,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2312,11 +2312,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #review @@ -2325,7 +2325,7 @@ tcl::namespace::eval punk::char { #ZWNJ \u0200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u0200b zero width space + #ZWSP \u0200b zero width space #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2343,10 +2343,10 @@ tcl::namespace::eval punk::char { } #review - wcswidth should detect these - set re_ascii_fullwidth {[\uFF01-\uFF5e]} + set re_ascii_fullwidth {[\uFF01-\uFF5e]} set doublewidth_char_count 0 - set zerowidth_char_count 0 + set zerowidth_char_count 0 #split just to get the standalone character widths - and then scan for other combiners (?) #review #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] @@ -2354,7 +2354,7 @@ tcl::namespace::eval punk::char { #fixed in bug-4ed788c618 2023-11 #set uc_sequences [regexp -all -inline -indices {[\u0100-\U10FFFF]} $text] #set uc_sequences [regexp -all -inline -indices "\[\u0100-\U10FFFF\]" $text] ;#e.g for string: \U0001f9d1abc\U001f525ab returns {0 0} {4 4} - set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only foreach c $uc_chars { if {[regexp $re_ascii_fullwidth $c]} { incr doublewidth_char_count @@ -2364,12 +2364,12 @@ tcl::namespace::eval punk::char { # b)- textutil::wcswidth_char seems to be east-asian-width based - and not a reliable indicator of 'character cells taken by the character when printed to the terminal' despite this statement in tclllib docs. #(character width is a complex context-dependent topic) # c) by checking for a cached console testwidth first - we make this function less deterministic/repeatable depending on whether console tests have been run. - # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here + # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here #Despite all this - the mechanism is hoped to give best effort consistency for terminals - #further work needed for combining emojis etc - which can't be done in a per character loop + #further work needed for combining emojis etc - which can't be done in a per character loop #todo - see if wcswidth does any of this. It is very slow for strings that include mixed ascii/unicode - so perhaps we can use a perlish_split # to process sequences of unicode. - #- and the user has the option to test character sets first if terminal position reporting gives better results + #- and the user has the option to test character sets first if terminal position reporting gives better results if {[char_info_is_testwidth_cached $c]} { set width [char_info_testwidth_cached $c] } else { @@ -2378,7 +2378,7 @@ tcl::namespace::eval punk::char { set width [textutil::wcswidth_char [scan $c %c]] } if {$width == 0} { - incr zerowidth_char_count + incr zerowidth_char_count } elseif {$width == 2} { incr doublewidth_char_count } @@ -2395,7 +2395,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2416,11 +2416,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2437,7 +2437,7 @@ tcl::namespace::eval punk::char { return [tcl::string::length $text] } - #slow when ascii mixed with unicode (but why?) + #slow when ascii mixed with unicode (but why?) return [punk::char::wcswidth $text] } #This shouldn't be called on text containing ansi codes! @@ -2516,11 +2516,11 @@ tcl::namespace::eval punk::char { return [format $fmt {*}$declist] } - #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) + #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) proc combiner_split {text} { #split into odd numbered list (or zero) in a similar way to punk::ansi::ta::_perlish_split # - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set graphemes [list] if {[tcl::string::length $text] == 0} { return {} @@ -2528,12 +2528,12 @@ tcl::namespace::eval punk::char { set list [list] set start 0 set strlen [tcl::string::length $text] - #make sure our regexes aren't non-greedy - or we may not have exit condition for loop + #make sure our regexes aren't non-greedy - or we may not have exit condition for loop #review while {$start < $strlen && [regexp -start $start -indices -- {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} $text match]} { lassign $match matchStart matchEnd #puts "->start $start ->match $matchStart $matchEnd" - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] } lappend list [tcl::string::range $text $start end] @@ -2547,7 +2547,7 @@ tcl::namespace::eval punk::char { #This is difficult in Tcl without unicode property based Character Classes in the regex engine #review - this needs to be performant - it is used a lot by punk terminal/ansi features #todo - trie data structures for unicode? - #for now we can at least combine diacritics + #for now we can at least combine diacritics #should also handle the ZWJ (and the variation selectors? eg \uFE0F) character which should account for emoji clusters #Note - emoji cluster could be for example 11 code points/41 bytes (family emoji with skin tone modifiers for each member, 3 ZWJs) #This still leaves a whole class of clusters.. korean etc unhandled :/ @@ -2560,7 +2560,7 @@ tcl::namespace::eval punk::char { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] lappend graphemes [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2575,7 +2575,7 @@ tcl::namespace::eval punk::char { set combiner_decs [scan $combiners [tcl::string::repeat %c [tcl::string::length $combiners]]] lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] lappend graphemes {*}$pt_decs - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[scan [lindex $csplits end] [tcl::string::repeat %c [tcl::string::length [lindex $csplits end]]]] @@ -2592,7 +2592,7 @@ tcl::namespace::eval punk::char { lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] } lappend graphemes {*}$pt_decs - } + } return $graphemes } proc grapheme_split2 {text} { @@ -2601,7 +2601,7 @@ tcl::namespace::eval punk::char { foreach {pt combiners} [lrange $csplits 0 end-1] { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2645,10 +2645,10 @@ tcl::namespace::eval punk::char { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::char [tcl::namespace::eval punk::char { 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/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm index fbce0905..ac70e97b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -32,7 +32,7 @@ tcl::namespace::eval punk::config { if {$exename ne ""} { set exefolder [file dirname $exename] #default file logs to logs folder at same level as exe if writable, or empty string - set log_folder [file normalize $exefolder/../logs] + set log_folder [file normalize $exefolder/../logs] ;#~2ms #tcl::dict::set startup scriptlib $exefolder/scriptlib #tcl::dict::set startup apps $exefolder/../../punkapps 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 a8884746..a3f5d95c 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 @@ -777,13 +777,13 @@ namespace eval punk::console { set extension [lindex [split $waitvar($callid) -] 1] if {$extension eq ""} { puts "blank extension $waitvar($callid)" - puts "->[set $waitvar($callid]<-" + puts "->[set $waitvar($callid)]<-" } puts stderr "get_ansi_response_payload Extending timeout by $extension" after cancel $timeoutid($callid) set total_elapsed [expr {[clock millis] - $tslaunch($callid)}] set last_elapsed [expr {[clock millis] - $lastvwait}] - set remaining [expr {$remaining - $last_elapsed}] + set remaining [expr {$remaining - $last_elapsed}] if {$remaining < 0} {set remaining 0} set newtime [expr {$remaining + $extension}] set timeoutid($callid) [after $newtime [list set $waitvarname timedout]] @@ -797,7 +797,7 @@ namespace eval punk::console { } } } - #response handler automatically removes it's own chan event + #response handler automatically removes it's own chan event chan event $input readable {} ;#explicit remove anyway - review if {$waitvar($callid) ne "timedout"} { @@ -814,7 +814,7 @@ namespace eval punk::console { #it *might* be ok to restore entire state on an input channel #(it's not always on all channels - e.g stdout has -winsize which is read-only) #Safest to only restore what we think we've modified. - fconfigure $input -blocking [dict get $previous_input_state -blocking] + chan configure $input -blocking [dict get $previous_input_state -blocking] @@ -828,10 +828,10 @@ namespace eval punk::console { set prefixdata [string range $input_read {*}$prefix_indices] if {!$ignoreok && $prefixdata ne ""} { #puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (responsedata=[ansistring VIEW -lf 1 $responsedata])" - lappend input_chunks_waiting($input) $prefixdata + lappend input_chunks_waiting($input) $prefixdata } - } else { - #timedout - or eof? + } else { + #timedout - or eof? if {!$ignoreok} { puts stderr "get_ansi_response_payload callid:$callid regex match '$capturingendregex' to input_read '[ansistring VIEW -lf 1 -vt 1 $input_read]' not found" lappend input_chunks_waiting($input) $input_read @@ -872,11 +872,11 @@ namespace eval punk::console { flush stdout #concat and supply to existing handler in single text block - review - #Note will only + #Note will only set waitingdata [join $input_chunks_waiting($input) ""] set input_chunks_waiting($input) [list] #after idle [list after 0 [list {*}$existing_handler $waitingdata]] - after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review + after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review unset waitingdata } else { #! todo? for now, emit a clue as to what's happening. @@ -942,7 +942,7 @@ namespace eval punk::console { #review - reading 1 byte at a time and repeatedly running the small capturing/completion regex seems a little inefficient... but we don't have a way to peek or put back chars (?) #review (we do have the punk::console::input_chunks_waiting($chan) array to cooperatively put back data - but this won't work for user scripts not aware of this) #review - timeout - what if terminal doesn't put data on stdin? error vs stderr report vs empty results - #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? + #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? #e.g what happens to mouse-events while user code is executing? #we may still need this handler if such a loop doesn't exist. proc ansi_response_handler_regex {chan callid endregex} { @@ -973,14 +973,14 @@ namespace eval punk::console { chan event $chan readable {} set waits($callid) ok } else { - # 30ms 16ms? + # 30ms 16ms? set tsnow [clock millis] set total_elapsed [expr {[set tslaunch($callid)] - $tsnow}] set last_elapsed [expr {[set tsclock($callid)] - $tsnow}] if {[string length $chunks($callid)] % 10 == 0 || $last_elapsed > 16} { if {$total_elapsed > 3000} { #REVIEW - #too long since initial read handler launched.. + #too long since initial read handler launched.. #is other data being pumped into stdin? Eventloop starvation? Did we miss our codes? #For now we'll stop extending the timeout. after cancel $::punk::console::ansi_response_timeoutid($callid) @@ -1009,7 +1009,7 @@ namespace eval punk::console { chan event $chan readable {} # Something else puts stderr "ansi_response_handler_regex Situation shouldn't be possible. No error and no bytes read on channel $chan but not chan blocked or EOF" - set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof + set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof } } } ;#end namespace eval internal @@ -1034,7 +1034,7 @@ namespace eval punk::console { if {$ansi_wanted <= 0} { return } - #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here + #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here #tailcall punk::ansi::a+ {*}$args ::punk::ansi::a+ {*}$args } @@ -1092,7 +1092,7 @@ namespace eval punk::console { } default { set ansi_wanted 2 - } + } default { error "punk::console::ansi expected 0|1|on|off|true|false|yes|no|default" } @@ -1133,9 +1133,9 @@ namespace eval punk::console { } #test - find a better place to set terminal type - variable is_vt52 0 + variable is_vt52 0 proc vt52 {{onoff {}}} { - #todo - return to colour state beforehand?. support 0-15 vt52 colours? + #todo - return to colour state beforehand?. support 0-15 vt52 colours? #we shouldn't have to trun off colour to enter vt52 - we should make punk::console emit correct codes variable is_vt52 if {$onoff eq ""} { @@ -1146,7 +1146,7 @@ namespace eval punk::console { } if {$is_vt52} { if {!$onoff} { - puts -nonewline "\x1b<" + puts -nonewline "\x1b<" set is_vt52 0 colour on } @@ -1156,7 +1156,7 @@ namespace eval punk::console { set is_vt52 1 colour off } else { - puts -nonewline "\x1b<" + puts -nonewline "\x1b<" #emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ } } @@ -1222,10 +1222,10 @@ namespace eval punk::console { return $onoff } else { if {$onoff} { - {*}[auto_execok stty] echo + {*}[auto_execok stty] echo return 1 } else { - {*}[auto_execok stty] -echo + {*}[auto_execok stty] -echo return 0 } } @@ -1259,7 +1259,7 @@ namespace eval punk::console { set expected [dict get $opts -expected_ms] set capturingregex {(((.*)))$} ;#capture entire response same as response-payload - set ts_start [clock millis] + set ts_start [clock millis] set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] set ts_end [clock millis] puts stderr $response @@ -1273,7 +1273,7 @@ namespace eval punk::console { # -- --- --- --- --- --- --- #get_ansi_response functions - #review - can these functions sensibly be used on channels not attached to the local console? + #review - can these functions sensibly be used on channels not attached to the local console? #ie can we default to {stdin stdout} but allow other channel pairs? # -- --- --- --- --- --- --- proc get_cursor_pos {{inoutchannels {stdin stdout}}} { @@ -1284,13 +1284,13 @@ namespace eval punk::console { #e.g \033\[46;1R set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} ;#must capture prefix,entire-response,response-payload - set request "\033\[6n" + set request "\033\[6n" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] #some terminals fail to respond properly to \x1b\[6n but do respond to \x1b\[?6n and vice-versa :/ - #todo - what? + #todo - what? #often terminals that fail will just put the raw request code on stdin - we could detect that and then #try the other? - + return $payload } proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} { @@ -1333,7 +1333,7 @@ namespace eval punk::console { proc get_device_attributes {{inoutchannels {stdin stdout}}} { #DA1 variable last_da1_result - #first element in result is the terminal's architectural class 61,62,63,64.. ? + #first element in result is the terminal's architectural class 61,62,63,64.. ? #for vt100 we get things like: "ESC\[?1;0c" #for vt102 "ESC\[?6c" @@ -1368,7 +1368,7 @@ namespace eval punk::console { proc get_tabstops {{inoutchannels {stdin stdout}}} { #DECTABSR \x1b\[2\$w #response example " ^[P2$u9/17/25/33/41/49/57/65/73/81^[\ " (where ^[ is \x1b) - #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} + #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} #set capturingregex {(.*)(\x1bP2$u((?:[0-9]+)*(?:\/[0-9]+)*)\x1b\\)$} set capturingregex {(.*)(\x1bP2\$u(.*)\x1b\\)$} set request "\x1b\[2\$w" @@ -1387,7 +1387,7 @@ namespace eval punk::console { #either terminal failed to report - or none set. set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } #We don't support none - default to 8 return 8 @@ -1397,7 +1397,7 @@ namespace eval punk::console { if {[llength $tslist] == 1} { set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } return 8 } else { @@ -1441,7 +1441,7 @@ namespace eval punk::console { set cell_size "" set cell_size_fallback 10x20 - #todo - change -inoutchannels to -terminalobject with prebuilt default + #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::define { @id -id ::punk::console::cell_size @@ -1450,7 +1450,7 @@ namespace eval punk::console { newsize -default "" -help\ "character cell pixel dimensions WxH or omit to query cell size." - } + } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] @@ -1462,11 +1462,11 @@ namespace eval punk::console { if {$cell_size eq ""} { #not set - try to query terminal's overall dimensions set pixeldict [punk::console::get_xterm_pixels $inoutchannels] - lassign $pixeldict _w sw _h sh + lassign $pixeldict _w sw _h sh if {[string is integer -strict $sw] && [string is integer -strict $sh]} { lassign [punk::console::get_size] _cols columns _rows rows #review - is returned size in pixels always a multiple of rows and cols? - set w [expr {$sw / $columns}] + set w [expr {$sw / $columns}] set h [expr {$sh / $rows}] set cell_size ${w}x${h} return $cell_size @@ -1511,7 +1511,7 @@ namespace eval punk::console { return [expr {$payload in {Z K M}}] } - #todo - determine cursor on/off state before the call to restore properly. + #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { lassign $inoutchannels in out #we can't reliably use [chan names] for stdin,stdout. There could be stacked channels and they may have a names such as file22fb27fe810 @@ -1521,7 +1521,7 @@ namespace eval punk::console { } else { if {$is_eof} { error "punk::console::get_size eof on output channel $out ([info level 1])" - } + } } #we don't need to care about the input channel if chan configure on the output can give us the info. #short circuit ansi cursor movement method if chan configure supports the -winsize value @@ -1529,7 +1529,7 @@ namespace eval punk::console { if {[dict exists $outconf -winsize]} { #this mechanism is much faster than ansi cursor movements #REVIEW check if any x-platform anomalies with this method? - #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least + #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least lassign [dict get $outconf -winsize] cols lines if {[string is integer -strict $cols] && [string is integer -strict $lines]} { return [list columns $cols rows $lines] @@ -1542,7 +1542,7 @@ namespace eval punk::console { } else { if {$is_eof} { error "punk::console::get_size eof on input channel $in ([info level 1])" - } + } } #keep out of catch - no point in even trying a restore move if we can't get start position - just fail here. @@ -1565,7 +1565,7 @@ namespace eval punk::console { puts -nonewline $out [$func_coff][$movefunc 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols puts -nonewline $out [$movefunc $start_row $start_col][$func_con];flush stdout - set result [list columns $cols rows $lines] + set result [list columns $cols rows $lines] } errM]} { puts -nonewline $out [$movefunc $start_row $start_col] puts -nonewline $out [$func_con] @@ -1578,7 +1578,7 @@ namespace eval punk::console { #faster than get_size when it is using ansi mechanism - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore proc get_size_cursorrestore {{inoutchannels {stdin stdout}}} { lassign $inoutchannels in out - #we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly + #we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly set outconf [chan configure $out] if {[dict exists $outconf -winsize]} { lassign [dict get $outconf -winsize] cols lines @@ -1592,8 +1592,8 @@ namespace eval punk::console { #This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::cursor_save_dec][punk::ansi::move 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols - puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out - set result [list columns $cols rows $lines] + puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out + set result [list columns $cols rows $lines] } errM]} { puts -nonewline $out [punk::ansi::cursor_restore_dec] puts -nonewline $out [punk::ansi::cursor_on] @@ -1611,14 +1611,14 @@ namespace eval punk::console { set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[18t" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] - lassign [split $payload {;}] rows cols + lassign [split $payload {;}] rows cols return [list columns $cols rows $rows] } proc get_xterm_pixels {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[4;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[14t" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] - lassign [split $payload {;}] height width + lassign [split $payload {;}] height width return [list width $width height $height] } @@ -1629,7 +1629,7 @@ namespace eval punk::console { set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } - #Terminals generally default to LNM being reset (off) ie enter key sends a lone + #Terminals generally default to LNM being reset (off) ie enter key sends a lone #Terminals tested on windows either don't respond to this query, or respond with 0 (meaning mode not understood) #I presume from this that almost nobody is using LNM 1 (which sends both and ) proc get_mode_LNM {{inoutchannels {stdin stdout}}} { @@ -1689,7 +1689,7 @@ namespace eval punk::console { #terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate. #todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position. #todo - determine if these anomalies are independent of font - #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. + #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. #review - vertical movements (e.g /n /v will cause emit 0 to be ineffective - todo - disallow?) proc test_char_width {char_or_string {emit 0}} { #return 1 @@ -1797,7 +1797,7 @@ namespace eval punk::console { #don't set ansi_avaliable here - we want to be able to change things, retest etc. if {"windows" eq "$::tcl_platform(platform)"} { if {[package provide twapi] ne ""} { - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set existing_mode [twapi::GetConsoleMode $h_out] if {[expr {$existing_mode & 4}]} { #virtual terminal processing happens to be enabled - so it's supported @@ -1808,12 +1808,12 @@ namespace eval punk::console { #try temporarily setting it - if we get an error - ansi not supported if {[catch { - twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] } errM]} { return 0 } #restore - twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] return 1 } else { #todo - try a cursorpos query and read stdin to see if we got a response? @@ -1837,26 +1837,26 @@ namespace eval punk::console { set ansi_available [test_can_ansi] return $ansi_available } - return 1 + return 1 } - variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested + variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested #todo - flag to retest? (for consoles where grapheme cluster support can be disabled e.g via decmode 2027) proc grapheme_cluster_support {} { variable grapheme_cluster_support if {[dict size $grapheme_cluster_support]} { - return $grapheme_cluster_support + return $grapheme_cluster_support } if {[info exists ::env(TERM_PROGRAM)]} { #terminals known to support grapheme clusters, but unable to respond to decmode request 2027 #wezterm (on windows as at 2024-12 decmode 2027 doesn't work) - #REVIEW - what if terminal is remote wezterm? can/will this env variable + #REVIEW - what if terminal is remote wezterm? can/will this env variable # iterm and apple terminal also set TERM_PROGRAM if {[string tolower $::env(TERM_PROGRAM)] in [list wezterm]} { set is_available 1 - return [dict create available 1 mode set] + return [dict create available 1 mode set] } } #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) @@ -1884,7 +1884,7 @@ namespace eval punk::console { set m "BAD_RESPONSE" } } - return [dict create available $is_available mode $m] + return [dict create available $is_available mode $m] } @@ -1947,7 +1947,7 @@ namespace eval punk::console { set was_raw 1 } puts -nonewline stdout \033\[6n ;flush stdout - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 set info [read stdin 20] ;# after 1 if {[string first "R" $info] <=0} { @@ -2015,8 +2015,8 @@ namespace eval punk::console { (aka: cursor home) The sequence emitted will depend on the mode of the - terminal as stored in the consolehandle. - Directly setting the mode via raw escape sequences: + terminal as stored in the consolehandle. + Directly setting the mode via raw escape sequences: e.g unset_mode DECANM for vt52 or puts \x1b< to return to ANSI will not necessarily update the application of @@ -2036,7 +2036,7 @@ namespace eval punk::console { This sequence will generally not be understood by terminals that are not in vt52 mode even if higher modes are supported. - + } @values -min 2 -max 2 row -type integer -help\ @@ -2045,7 +2045,7 @@ namespace eval punk::console { "column number - starting at 1" }] proc move {row col} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { return [punk::ansi::move $row $col] } else { @@ -2053,7 +2053,7 @@ namespace eval punk::console { } } proc move_forward {n} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_forward $n] } else { @@ -2061,7 +2061,7 @@ namespace eval punk::console { } } proc move_back {n} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_back $n] } else { @@ -2075,7 +2075,7 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::move_down $n] } proc move_column {col} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_column $col] } else { @@ -2086,7 +2086,7 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::move_row $row] } proc move_emit {row col data args} { - upvar ::punk::console::is_v52 is_vt52 + upvar ::punk::console::is_v52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] } else { @@ -2226,7 +2226,7 @@ namespace eval punk::console { } proc titleset {windowtitle} { puts -nonewline stdout [punk::ansi::titleset $windowtitle] - } + } proc test_decaln {} { puts -nonewline stdout [punk::ansi::test_decaln] } @@ -2239,10 +2239,10 @@ namespace eval punk::console { if { $ansi_wanted <= 0} { punk::console::local::titleset $windowtitle } else { - ansi::titleset $windowtitle + ansi::titleset $windowtitle } } - #no known pure-ansi solution + #no known pure-ansi solution proc titleget {} { return [local::titleget] } @@ -2272,14 +2272,14 @@ namespace eval punk::console { #experimental proc rhs_prompt {col text} { package require textblock - lassign [textblock::size $text] _w tw _h th + lassign [textblock::size $text] _w tw _h th if {$th > 1} { #move up first.. need to know current line? } #set blanks [string repeat " " [expr {$col + $tw}]] #puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text #puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] - cursor_save_dec + cursor_save_dec #move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text #puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text puts -nonewline [punk::ansi::erase_eol][punk::ansi::move_column $col]$text @@ -2323,7 +2323,7 @@ namespace eval punk::console { 18 30 60 C0 60 30 18 00 00 00 7E 00 7E 00 00 00 60 30 18 0C 18 30 60 00 - 3C 66 0C 18 18 00 18 00 + 3C 66 0C 18 18 00 18 00 } #libungif extras append fontmap1 { @@ -2491,7 +2491,7 @@ namespace eval punk::console { #curses attr off reverse #a noreverse set reverse 0 - set output "" + set output "" set charno 0 foreach char [split $str {}] { binary scan $char c f @@ -2528,9 +2528,9 @@ namespace eval punk::console { } proc display {} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5] punk::console::move $orig_row $orig_col @@ -2539,9 +2539,9 @@ namespace eval punk::console { proc displaystr {str} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr $str 10 5] punk::console::move $orig_row $orig_col @@ -2571,13 +2571,13 @@ namespace eval punk::console { if {$dingbat_heavy_plus_width == 2} { set can_terminal_report_dingbat_width 1 } else { - puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." + puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." } set diacritic_width [punk::console::test_char_width a\u0300] if {$diacritic_width == 1} { set can_terminal_report_diacritic_width 1 } else { - puts stderr "punk::console warning: terminal unable to report diacritic width properly." + puts stderr "punk::console warning: terminal unable to report diacritic width properly." } if {$can_high_unicode && $can_regex_high_unicode && $can_terminal_report_dingbat_width && $can_terminal_report_diacritic_width} { @@ -2617,7 +2617,7 @@ namespace eval punk::console::check { } return $has_bug_legacysymbolwidth } - return 1 + return 1 } variable has_bug_zwsp -1 ;#undetermined proc has_bug_zwsp {} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm index 1f02859b..ca222524 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -9,7 +9,7 @@ # @@ Meta Begin # Application punk::fileline 0.1.0 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::fileline 0 0.1.0] #[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 --}] +#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] #[require punk::fileline] #[keywords module text parse file encoding BOM] #[description] @@ -33,7 +33,7 @@ #[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]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] @@ -42,13 +42,13 @@ # 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 +# 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]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. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -141,7 +141,7 @@ namespace eval punk::fileline::class { variable o_line_epoch variable o_payloadlist variable o_linemap - variable o_LF_C + variable o_LF_C variable o_CRLF_C @@ -158,7 +158,7 @@ namespace eval punk::fileline::class { #[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] - # fconfigure $fd -translation binary + # chan configure $fd -translation binary # set chunkdata [lb]read $fd[rb]] #or # set chunkdata [lb]fileutil::cat -translation binary[rb] @@ -191,7 +191,7 @@ namespace eval punk::fileline::class { set o_bom "" ;#review set o_chunk $datachunk - set o_line_epoch [list] + 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\ @@ -206,11 +206,11 @@ namespace eval punk::fileline::class { } } 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" @@ -261,7 +261,7 @@ namespace eval punk::fileline::class { #[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 + #[para] objName chunk 0 end return [string range $o_chunk $chunkstart $chunkend] } method chunklen {} { @@ -273,7 +273,7 @@ namespace eval punk::fileline::class { 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]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\ @@ -331,7 +331,7 @@ namespace eval punk::fileline::class { if {$opt_ansi} { set ::punk::fileline::ansi::enabled 1 } else { - set ::punk::fileline::ansi::enabled 0 + set ::punk::fileline::ansi::enabled 0 } if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { proc ::punk::fileline::a {args} { @@ -350,7 +350,7 @@ namespace eval punk::fileline::class { } proc ::punk::fileline::ansistrip {str} { if {$::punk::fileline::ansi::enabled} { - tailcall ::punk::fileline::ansi::ansistrip $str + tailcall ::punk::fileline::ansi::ansistrip $str } else { return $str } @@ -361,10 +361,10 @@ namespace eval punk::fileline::class { #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 + #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) " + 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] @@ -402,7 +402,7 @@ namespace eval punk::fileline::class { } else { set linebase $maxline } - set linebase ${sign}$linebase + set linebase ${sign}$linebase } elseif {[string match start* $tail]} { set endmath [string range $tail 5 end] if {[string length $endmath]} { @@ -489,7 +489,7 @@ namespace eval punk::fileline::class { 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 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] @@ -503,11 +503,11 @@ namespace eval punk::fileline::class { set e [dict get $lineinfo end] set boundarymarker "" - set displayidx "" + 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 [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] @@ -527,29 +527,29 @@ namespace eval punk::fileline::class { set linenum_display ${linenum_display},$idx } - set lhs_status $opt_cmark ;#default + 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 + set lhs_status $opt_tmark + set rhs_status $opt_tmark } elseif {"left" in $tside} { - set lhs_status $opt_tmark + set lhs_status $opt_tmark } elseif {"right" in $tside} { set rhs_status $opt_tmark } } else { - set line [my line $lineidx] + set line [my line $lineidx] } if {$displayidx ne ""} { - set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] + 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 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 *] @@ -586,12 +586,12 @@ namespace eval punk::fileline::class { 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]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 + 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] @@ -641,13 +641,13 @@ namespace eval punk::fileline::class { set opt_strategy [dict get $opts -strategy] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_start [dict get $opts -start] - set opt_start [expr {$opt_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 + set opt_end $max_line_index } #TODO if {$opt_end < $max_line_index} {error "-end less than max_line_index unimplemented"} @@ -705,7 +705,7 @@ namespace eval punk::fileline::class { #[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 + lassign [my numeric_linerange $lineindex 0] lineindex return [lindex $o_payloadlist $lineindex] } method linepayloads {startindex endindex} { @@ -722,17 +722,17 @@ namespace eval punk::fileline::class { #[list_begin itemized] #[item] le #[para] A string representing the type of line-ending: crlf|lf|none - #[item] linelen + #[item] linelen #[para] The number of characters/bytes in the whole line including line-ending if any - #[item] payloadlen + #[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 + #[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 + lassign [my numeric_linerange $lineindex 0] lineindex dict get $o_linemap $lineindex } method lineinfo {lineindex} { @@ -797,7 +797,7 @@ namespace eval punk::fileline::class { 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 + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set linestart -1 for {set i 0} {$i < [llength $o_payloadlist]} {incr i} { @@ -829,7 +829,7 @@ namespace eval punk::fileline::class { #[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 + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set defaults [dict create\ -show_truncated 0\ ] @@ -840,9 +840,9 @@ namespace eval punk::fileline::class { } } 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] @@ -878,8 +878,8 @@ namespace eval punk::fileline::class { 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 + dict set first truncated $truncated + dict set first truncatedleft $lhs } } ########################### @@ -908,7 +908,7 @@ namespace eval punk::fileline::class { if {$chunkend < [dict get $end_info end]} { #there is rhs truncation if {[dict get $first is_truncated]} { - dict set first truncatedside [list left right] + dict set first truncatedside [list left right] } else { dict set first is_truncated 1 dict set first truncatedside [list right] @@ -925,7 +925,7 @@ namespace eval punk::fileline::class { 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 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]} { @@ -971,13 +971,13 @@ namespace eval punk::fileline::class { set payload_and_le "${payload}${le_chars}" set split [expr {$chunkend - $line_start}] - set truncated [string range $payload_and_le 0 $split] + 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' + #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' } } @@ -991,7 +991,7 @@ namespace eval punk::fileline::class { ########################### #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. + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. return $infolist } @@ -1017,12 +1017,12 @@ namespace eval punk::fileline::class { #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 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. @@ -1035,7 +1035,7 @@ namespace eval punk::fileline::class { #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] } @@ -1061,13 +1061,13 @@ namespace eval punk::fileline::class { 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]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 + #[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 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] { @@ -1078,9 +1078,9 @@ namespace eval punk::fileline::class { set index $max } "*-*" { - #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions + #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions lassign [split $index -] A B - if {$A eq "end"} { + if {$A eq "end"} { set index [expr {$max - $B}] } else { set index [expr {$A - $B}] @@ -1088,7 +1088,7 @@ namespace eval punk::fileline::class { } "*+*" { lassign [split $index +] A B - if {$A eq "end"} { + 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}] @@ -1098,9 +1098,9 @@ namespace eval punk::fileline::class { } 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. + #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 + #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 } @@ -1109,13 +1109,13 @@ namespace eval punk::fileline::class { } } } - #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. + #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" + 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)" + error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" } return [list $startidx $endidx] } @@ -1136,7 +1136,7 @@ namespace eval punk::fileline::class { 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 lf_lines [split $normalised_data $o_LF_C] set idx 0 set lf_count 0 @@ -1145,14 +1145,14 @@ namespace eval punk::fileline::class { set i 0 set imax [expr {[llength $lf_lines]-1}] foreach lfln $lf_lines { - set crlf_parts [split $lfln $o_CRLF_C] + 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 + #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 @@ -1177,7 +1177,7 @@ namespace eval punk::fileline::class { 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 filedata_offset $linelen incr crlf_count incr idx } @@ -1200,7 +1200,7 @@ namespace eval punk::fileline::class { set le lf } - lappend o_payloadlist $lfpart + 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 @@ -1221,8 +1221,11 @@ namespace eval punk::fileline::class { #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 + #??? + #set } @@ -1248,19 +1251,19 @@ namespace eval punk::fileline { #*** !doctools #[subsection {Namespace punk::fileline}] - #[para] Core API functions for punk::fileline + #[para] Core API functions for punk::fileline #[list_begin definitions] - punk::args::define { + 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 + -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]] @@ -1272,7 +1275,7 @@ namespace eval punk::fileline { #[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]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. @@ -1285,10 +1288,10 @@ namespace eval punk::fileline { # -- --- --- --- if {$opt_file ne ""} { - set filename $opt_file - set fd [open $filename r] - fconfigure $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 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]} { @@ -1335,7 +1338,7 @@ namespace eval punk::fileline { 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) + #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 @@ -1360,7 +1363,7 @@ namespace eval punk::fileline { set bomenc "binary" ;# utf-8??? set startdata 3 } elseif {$maybe_bom eq "84319533"} { - if {![dict exists [punk::char::page_names_dict gb18030]]} { + 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 { @@ -1374,7 +1377,7 @@ namespace eval punk::fileline { 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!" + 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 @@ -1433,7 +1436,7 @@ namespace eval punk::fileline { } 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]] @@ -1443,7 +1446,7 @@ namespace eval punk::fileline { #!? if {$bomenc eq "binary"} { set datachunk [string range $rawchunk $startdata end] - set encoding_selected binary + set encoding_selected binary } else { set datachunk [encoding convertfrom utf-8 [string range $rawchunk $startdata end]] set encoding_selected utf-8 @@ -1485,7 +1488,7 @@ namespace eval punk::fileline { proc file_boundary_display {filename startbyte endbyte chunksize args} { set fd [open $filename r] ;#use default error if file not readable - fconfigure $fd -translation binary + chan configure $fd -translation binary set rawfiledata [read $fd] close $fd set textobj [class::textinfo new $rawfiledata] @@ -1510,7 +1513,7 @@ namespace eval punk::fileline::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::fileline::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] @@ -1532,12 +1535,12 @@ namespace eval punk::fileline::lib { #[para]e.g #[example_begin] # range_spans_chunk_boundaries 10 1750 512 - # is_span 1 boundaries {512 1024 1536} + # is_span 1 boundaries {512 1024 1536} #[example_end] - #[para]The -offset option + #[para]The -offset option #[example_begin] # range_spans_chunk_boundaries 10 1750 512 -offset 2 - # is_span 1 boundaries {514 1026 1538} + # 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-}]} { @@ -1576,12 +1579,12 @@ namespace eval punk::fileline::lib { namespace eval punk::fileline::system { #*** !doctools #[subsection {Namespace punk::fileline::system}] - #[para] Internal functions that are not part of the API + #[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 + return [binary format S* $elements] ;#format big endian } proc wordswap32 {data} { binary scan $data i* elements @@ -1622,7 +1625,7 @@ namespace eval punk::fileline::system { 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 @@ -1632,7 +1635,7 @@ namespace eval punk::fileline::system { } else { set overflow 0 } - set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] + set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] if {$overflow} { #we don't know how many overflowed.. set inrange [list] @@ -1668,7 +1671,7 @@ namespace eval punk::fileline::system { set opt_offset [dict get $opts -offset] # -- --- --- --- - set is_span 0 + set is_span 0 set smod [expr {$start % $chunksize}] if {$smod != 0} { set start [expr {$start + ($chunksize - $smod)}] @@ -1681,7 +1684,7 @@ namespace eval punk::fileline::system { 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 + incr btrack $chunksize set boff [expr {$btrack + $opt_offset}] } set bstart $btrack @@ -1689,9 +1692,9 @@ namespace eval punk::fileline::system { set bstart $start } for {set b $bstart} {[set boff [expr {$b + $opt_offset}]] <= $end} {incr b $chunksize} { - lappend boundaries $boff - } - + lappend boundaries $boff + } + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries offset $opt_offset] } @@ -1707,7 +1710,7 @@ 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 + #[para]See [package punk::ansi] for documentation #[list_begin definitions] variable enabled 1 #*** !doctools @@ -1720,11 +1723,11 @@ namespace eval punk::fileline::ansi { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::fileline [namespace eval punk::fileline { variable pkg punk::fileline 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/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm index 09a73385..b6c6dd4a 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application punk::lib 0.1.1 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::lib 0 0.1.1] #[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 --}] +#[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]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 # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -34,7 +34,7 @@ #[section Overview] #[para] overview of punk::lib #[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[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. @@ -108,7 +108,7 @@ tcl::namespace::eval punk::lib::ensemble { tcl::namespace::eval $extension [ list namespace ensemble create -command $routine -unknown [ list apply {{renamed ensemble routine args} { - list $renamed $routine + list $renamed $routine }} $renamed ] ] @@ -126,7 +126,7 @@ tcl::namespace::eval punk::lib::check { uplevel #0 $script set rep1 [tcl::unsupported::representation $::j] set script "" - set rep2 [tcl::unsupported::representation $::j] + set rep2 [tcl::unsupported::representation $::j] set nostring1 [string match "*no string" $rep1] set nostring2 [string match "*no string" $rep2] @@ -185,15 +185,15 @@ tcl::namespace::eval punk::lib::check { #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 + 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 + #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} { @@ -244,7 +244,7 @@ tcl::namespace::eval punk::lib::compat { 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 + #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 ""} { @@ -305,7 +305,7 @@ tcl::namespace::eval punk::lib::compat { 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 + #[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] @@ -356,7 +356,7 @@ tcl::namespace::eval punk::lib::compat { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -454,7 +454,7 @@ namespace eval punk::lib { #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) proc aliases {{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] + 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]]} { @@ -464,7 +464,7 @@ namespace eval punk::lib { set segcount [llength $segments] ;#only match number of segments matching current ns - set all_aliases [interp aliases {}] + set all_aliases [interp aliases {}] set matched [list] foreach a $all_aliases { #normalize with leading :: @@ -477,7 +477,7 @@ namespace eval punk::lib { set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] set acount [llength $asegs] #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {[expr {$acount - 1}] == $segcount} { + 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 @@ -485,7 +485,7 @@ namespace eval punk::lib { } } } - } + } #set matched_abs [lsearch -all -inline $all_aliases $glob] return $matched @@ -513,7 +513,7 @@ namespace eval punk::lib { set target [interp alias "" $aliasorglob] if {[llength $target]} { return $target - } + } if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { set aliaslist [punk::lib::aliases $aliasorglob] @@ -611,7 +611,7 @@ namespace eval punk::lib { } } 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. @@ -619,10 +619,10 @@ namespace eval punk::lib { #also 1b3 == 1b0003 if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "tm_version_required_canonical - invalid version specification" + 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 + #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'" @@ -634,7 +634,7 @@ namespace eval punk::lib { error "$errmsg '$versionspec'" } } else { - # min- or min-max + # 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 @@ -700,29 +700,29 @@ namespace eval punk::lib { #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 + #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) set a_index [lindex_resolve $l $a] set a_msg "" switch -- $a_index { -2 { - set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" + set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" } -3 { - set a_msg "1st supplied index $a is below the lower bound for the list (0)" + set a_msg "1st supplied index $a is below the lower bound for the list (0)" } } set z_index [lindex_resolve $l $z] set z_msg "" switch -- $z_index { -2 { - set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" - } + set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" + } -3 { - set z_msg "2nd supplied index $z is below the lower bound for the list (0)" + set z_msg "2nd supplied index $z is below the lower bound for the list (0)" } } - set errmsg "lswap cannot swap indices $a and $z" + set errmsg "lswap cannot swap indices $a and $z" if {$a_msg ne ""} { append errmsg \n $a_msg } @@ -732,7 +732,7 @@ namespace eval punk::lib { error $errmsg } set item2 [lindex $l $z] - lset l $z [lindex $l $a] + lset l $z [lindex $l $a] lset l $a $item2 return $l } @@ -760,20 +760,20 @@ namespace eval punk::lib { #proc swap_intvars2 {swapv1 swapv2} { # upvar $swapv1 _x $swapv2 _y # set _x [expr {$_x ^ $_y}] - # set _y [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 _x $_y # set _y $z #} #*** !doctools #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib + #[para] Core API functions for punk::lib #[list_begin definitions] if {[info commands lseq] ne ""} { @@ -785,7 +785,7 @@ namespace eval punk::lib { } } else { #lseq accepts basic expressions e.g 4-2 for both arguments - #e.g we can do lseq 0 [llength $list]-1 + #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] @@ -798,16 +798,16 @@ namespace eval punk::lib { incr from -1 return [lmap v [lrepeat $count 0] {incr from}] } - #slower methods. + #slower methods. #2) - #set i -1 + #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] + # lappend L [incr from] #} #return $L } elseif {$from > $to} { @@ -821,14 +821,14 @@ namespace eval punk::lib { } #2) - #set i -1 + #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] + # lappend L [incr from -1] #} #return $L } else { @@ -839,7 +839,7 @@ namespace eval punk::lib { proc lzip {args} { switch -- [llength $args] { - 0 {return {}} + 0 {return {}} 1 {return [lindex $args 0]} 2 {return [lzip2lists {*}$args]} 3 {return [lzip3lists {*}$args]} @@ -874,7 +874,7 @@ namespace eval punk::lib { } proc Build_lzipn {n} { - set arglist [list] + 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 " @@ -890,7 +890,7 @@ namespace eval punk::lib { puts "proc punk::lib::lzip${n}lists {$arglist} \{" puts "$body" puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body + proc ::punk::lib::lzip${n}lists $arglist $body } #fastest is to know the number of lists to be zipped @@ -923,7 +923,7 @@ namespace eval punk::lib { } #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - + # review - proc lzipn_alt args { #stackoverflow - courtesy glenn jackman (modified) foreach l $args { @@ -961,7 +961,7 @@ namespace eval punk::lib { 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 $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] ledit flatlist $s [expr {$s + $len - 1}] {*}$list incr s $numcolumns } @@ -977,7 +977,7 @@ namespace eval punk::lib { set numcolumns [::tcl::mathfunc::max {*}$lens] set flatlist [list] foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] } lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} } @@ -988,9 +988,9 @@ namespace eval punk::lib { set numcolumns [::tcl::mathfunc::max {*}$lens] set flatlist [list] foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] } - set zip_l {} + set zip_l {} set cols_remaining $numcolumns for {set c 0} {$c < $numcolumns} {incr c} { if {$cols_remaining == 1} { @@ -1006,14 +1006,14 @@ namespace eval punk::lib { #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] } - + namespace import ::punk::args::lib::tstr - + proc invoke command { @@ -1030,7 +1030,7 @@ namespace eval punk::lib { #}] #see https://wiki.tcl-lang.org/page/open - lassign [chan pipe] chanout chanin + lassign [chan pipe] chanout chanin lappend command 2>@$chanin set fh [open |$command] set stdout [read $fh] @@ -1045,7 +1045,7 @@ namespace eval punk::lib { } elseif {$sysmsg eq {CHILDSTATUS}} { return [list $stdout $stderr $exit] } else { - return -options $e $stderr + return -options $e $stderr } } return [list $stdout $stderr 0] @@ -1055,7 +1055,7 @@ namespace eval punk::lib { package require punk::args variable has_punk_ansi if {!$has_punk_ansi} { - set sep " = " + set sep " = " } else { #set sep " [a+ Web-seagreen]=[a] " set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " @@ -1081,18 +1081,18 @@ namespace eval punk::lib { 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) + 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. + 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 + 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 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 */%# + 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* + 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. @@ -1101,9 +1101,9 @@ namespace eval punk::lib { 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 segement 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. + 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::get_dict $argspec $args] @@ -1152,7 +1152,7 @@ namespace eval punk::lib { @cmd -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject -return -default "tailtohead" -choices {tailtohead sidebyside} - -channel -default none + -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 @@ -1181,7 +1181,7 @@ namespace eval punk::lib { }] $args] #for punk::lib - we want to reduce pkg dependencies. - # - so we won't even use the tcllib debug pkg here + # - 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 ""} { @@ -1222,18 +1222,18 @@ namespace eval punk::lib { 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 + #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: + #we currently return: #0 = v0 #1 = v1 #2 = v2 @@ -1245,7 +1245,7 @@ namespace eval punk::lib { #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}} { @@ -1263,7 +1263,7 @@ namespace eval punk::lib { set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] #puts stderr "showdict-->_split_patterns: $patterninfo" foreach v_idx $patterninfo { - lassign $v_idx v idx + 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 "!"} { @@ -1283,28 +1283,28 @@ namespace eval punk::lib { set keys [dict keys $dval] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p 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 } } %# { - 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 + dict set pattern_this_structure $p list lappend keyset # lappend keyset_structure list } ## { - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict lappend keyset [list ## query] - lappend keyset_structure dict + lappend keyset_structure dict } @* { #puts "showdict ---->@*<----" @@ -1323,19 +1323,19 @@ namespace eval punk::lib { #returns keys only lappend keyset [list $p query] lappend keyset_structure dict - dict set pattern_this_structure $p 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 + 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 + #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 @@ -1351,7 +1351,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @@* { #exact match key - review - should raise error to match punk pipe behaviour? @@ -1360,10 +1360,10 @@ namespace eval punk::lib { if {[dict exists $dval $k]} { set keys [dict keys [dict remove $dval $k]] lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] + lappend keyset_structure {*}[lrepeat [llength $keys] dict] } else { lappend keyset {*}[dict keys $dval] - lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] } } else { if {[dict exists $dval $k]} { @@ -1371,7 +1371,7 @@ namespace eval punk::lib { lappend keyset_structure dict } } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @k@* - @K@* { #TODO get_not @@ -1380,7 +1380,7 @@ namespace eval punk::lib { lappend keyset $k lappend keyset_structure dict } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*@*} { #return list of values @@ -1392,7 +1392,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*.@*} { #TODO get_not @@ -1400,61 +1400,61 @@ namespace eval punk::lib { set keys [dict keys $dval $k] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p 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'" + #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 + 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 + 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 + 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 + dict set pattern_this_structure $p dict } default { - set this_type $opt_roottype + set this_type $opt_roottype if {[string match @* $p]} { - #list mode - trim optional list specifier @ + #list mode - trim optional list specifier @ set p [string range $p 1 end] - dict set pattern_this_structure $p list - set this_type list + dict set pattern_this_structure $p list + set this_type list } elseif {[string match %* $p]} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string lappend keyset $p - lappend keyset_structure string + lappend keyset_structure string set this_type string } if {$this_type eq "list"} { - dict set pattern_this_structure $p 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] + lappend keyset_structure {*}[lrepeat [llength $keys] list] } else { lappend keyset $p - lappend keyset_structure list + lappend keyset_structure list } } elseif {[string match "?*-?*" $p]} { #could be either - don't change type @@ -1469,7 +1469,7 @@ namespace eval punk::lib { #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds if {${lower_resolve} == -2} { ##x - #lower bound is above upper list range + #lower bound is above upper list range #match with decreasing indices is still possible set lower [expr {[llength $dval]-1}] ;#set to max } elseif {$lower_resolve == -3} { @@ -1510,15 +1510,15 @@ namespace eval punk::lib { } else { lappend keyset [list @$p query] } - lappend keyset_structure list - } + lappend keyset_structure list + } } elseif {$this_type eq "string"} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string } elseif {$this_type eq "dict"} { #default equivalent to @\*@* - dict set pattern_this_structure $p dict + 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] + set keys [dict keys $dval $p] if {$get_not} { set keys [dict keys [dict remove $dval {*}$keys]] } @@ -1533,9 +1533,9 @@ namespace eval punk::lib { } } - # -- --- --- --- + # -- --- --- --- #check next pattern-segment for substructure type to use - # -- --- --- --- + # -- --- --- --- set substructure "" set pnext [lindex $segments 1] set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] @@ -1556,7 +1556,7 @@ namespace eval punk::lib { set substructure dict } # { - set substructure list + set substructure list } ## { set substructure dict @@ -1579,7 +1579,7 @@ namespace eval punk::lib { if {[string match @* $pnext]} { set substructure list } elseif {[string match %* $pnext]} { - set substructure string + set substructure string } else { #set substructure $opt_roottype #set substructure [dict get $pattern_this_structure $pattern_nest] @@ -1590,13 +1590,13 @@ namespace eval punk::lib { } } } else { - #e.g /@0,%str,.../ + #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 @@ -1629,7 +1629,7 @@ namespace eval punk::lib { } #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" } else { - puts stdout "unrecognised roottype: $opt_roottype" + puts stdout "unrecognised roottype: $opt_roottype" return $dval } @@ -1684,7 +1684,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] set subansibasekeys [lrange $opt_ansibase_keys 1 end] @@ -1692,7 +1692,7 @@ namespace eval punk::lib { #dict set nextopts -substructure $nextsub dict set nextopts -keytemplates $nextkeytemplates dict set nextopts -ansibase_keys $subansibasekeys - dict set nextopts -roottype $nextsub + dict set nextopts -roottype $nextsub dict set nextopts -channel none #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" @@ -1724,7 +1724,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] dict set nextopts -roottype $nextsub dict set nextopts -channel none @@ -1751,22 +1751,22 @@ namespace eval punk::lib { set thisval [ansistring VIEWSTYLE -lf 1 $dval] } elseif {[string match *lpad-* $key]} { set hidekey 1 - lassign [split $key -] _ extra + 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 + 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 + 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 + 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 { @@ -1789,14 +1789,14 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - #set nextopts [dict get $argd opts] + #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} { @@ -1838,7 +1838,7 @@ namespace eval punk::lib { } } "sidebyside" { - # TODO - fix + # 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?) @@ -1942,7 +1942,7 @@ namespace eval punk::lib { #also struct::set difference with critcl is faster proc setdiff {A B} { if {[llength $A] == 0} {return {}} - set d [dict create] + set d [dict create] foreach x $A {dict set d $x {}} foreach x $B {dict unset d $x} return [dict keys $d] @@ -1950,7 +1950,7 @@ namespace eval punk::lib { #bulk dict remove is slower than a foreach with dict unset #proc setdiff2 {fromlist removeitems} { # #if {[llength $fromlist] == 0} {return {}} - # set d [dict create] + # set d [dict create] # foreach x $fromlist { # dict set d $x {} # } @@ -1975,8 +1975,8 @@ namespace eval punk::lib { struct::set union $list {} } } else { - puts stderr "WARNING: struct::set union no longer dedupes!" - #we could also test a sequence of: struct::set add + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add } } @@ -2026,9 +2026,9 @@ namespace eval punk::lib { } 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] + } } [info vars] } ] # -- --- --- set cvars [tcl::dict::get $capture vars] @@ -2039,13 +2039,13 @@ namespace eval punk::lib { 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% }] @@ -2075,7 +2075,7 @@ namespace eval punk::lib { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -2110,7 +2110,7 @@ namespace eval punk::lib { # if {[tcl::dict::exists $dictValue {*}$keys]} { # return [tcl::dict::get $dictValue {*}$keys] # } else { - # return [lindex $args end] + # return [lindex $args end] # } #} if {[info commands ::tcl::dict::getdef] eq ""} { @@ -2123,7 +2123,7 @@ namespace eval punk::lib { } } } else { - #we pay a minor perf penalty for the wrap + #we pay a minor perf penalty for the wrap interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef } @@ -2131,13 +2131,13 @@ namespace eval punk::lib { #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" #} #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features @@ -2158,14 +2158,14 @@ namespace eval punk::lib { } } - # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side + # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side proc lindex_resolve {list index} { #*** !doctools #[call [fun lindex_resolve] [arg list] [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 #[para]Users may define procs which accept a list 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]Sometimes the actual integer index is desired. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]lindex_resolve will parse the index expression and return: #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) @@ -2183,13 +2183,13 @@ namespace eval punk::lib { #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { - #can match +i -i + #can match +i -i if {$index < 0} { return -3 } elseif {$index >= [llength $list]} { - return -2 + return -2 } else { - #integer may still have + sign - normalize with expr + #integer may still have + sign - normalize with expr return [expr {$index}] } } else { @@ -2223,7 +2223,7 @@ namespace eval punk::lib { set index [expr {([llength $list]-1) - $offset}] } if {$index < 0} { - return -3 + return -3 } else { return $index } @@ -2258,30 +2258,30 @@ namespace eval punk::lib { #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) #[para] returns -1 for out of range at either end, or a valid integer index #[para] 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 Tcl which has the builtin lseq command + #[para] This is only likely to be faster than average over lindex_resolve 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 + #[para] For pure integer indices the performance should be equivalent #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ - # - which + # - which #for {set i 0} {$i < [llength $list]} {incr i} { # lappend indices $i - #} + #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { - #can match +i -i + #can match +i -i #avoid even the lseq overhead when the index is simple if {$index < 0 || ($index >= [llength $list])} { #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. return -1 } else { - #integer may still have + sign - normalize with expr + #integer may still have + sign - normalize with expr return [expr {$index}] } - } + } if {[llength $list]} { set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. - #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) + #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) } else { set indices [list] } @@ -2290,7 +2290,7 @@ namespace eval punk::lib { #we have no way to determine if out of bounds is at lower vs upper end return -1 } else { - return $idx + return $idx } } proc lindex_get {list index} { @@ -2308,26 +2308,26 @@ namespace eval punk::lib { 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]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. + #[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] 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) + 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 + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for ) $ } $bytes @@ -2347,7 +2347,7 @@ namespace eval punk::lib { 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) + #[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 :-) ^ (?: @@ -2362,7 +2362,7 @@ namespace eval punk::lib { 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] 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. @@ -2377,9 +2377,9 @@ namespace eval punk::lib { [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) ) + } $rawbytes completeChars]} { - return $completeChars - } - return "" + return $completeChars + } + return "" } proc hex2dec {args} { #*** !doctools @@ -2403,10 +2403,10 @@ namespace eval punk::lib { 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} { @@ -2427,7 +2427,7 @@ namespace eval punk::lib { 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}}]] + 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]]] @@ -2460,7 +2460,7 @@ namespace eval punk::lib { 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] { @@ -2504,7 +2504,7 @@ namespace eval punk::lib { #[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 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 expr {log($x)/log($b)} } proc factors {x} { @@ -2513,14 +2513,14 @@ namespace eval punk::lib { #[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]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]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. + #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]* 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 @@ -2537,7 +2537,7 @@ namespace eval punk::lib { proc oddFactors {x} { #*** !doctools #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order + #[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] @@ -2572,7 +2572,7 @@ namespace eval punk::lib { set max [expr {sqrt($x)}] while {$j <= $max} { if {$x % $j == 0} { - return [expr {$x / $j}] + return [expr {$x / $j}] } incr j 2 } @@ -2597,14 +2597,14 @@ namespace eval punk::lib { if {$other % 2 == 0} { set god $j } else { - set god [expr {$x / $j}] + set god [expr {$x / $j}] #lowest j - so other side must be highest break } } incr j 2 } - return $god + return $god } proc greatestOddFactor {x} { #*** !doctools @@ -2660,7 +2660,7 @@ namespace eval punk::lib { #[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]] + return [factors [gcd $x $y]] } #experimental only - there are better/faster ways @@ -2701,8 +2701,8 @@ namespace eval punk::lib { 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. + #[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 } @@ -2720,7 +2720,7 @@ namespace eval punk::lib { proc substring_count {str substring} { #*** !doctools #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of 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} @@ -2736,7 +2736,7 @@ namespace eval punk::lib { #[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] + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] } proc askuser {question} { @@ -2744,7 +2744,7 @@ namespace eval punk::lib { #[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]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 @@ -2755,12 +2755,12 @@ namespace eval punk::lib { # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { # puts "Proceeding" # } else { - # puts "Cancelled by user" + # puts "Cancelled by user" # } #[example_end] puts stdout $question flush stdout - set stdin_state [fconfigure stdin] + set stdin_state [chan configure stdin] if {[catch { package require punk::console set console_raw [tsv::get console is_raw] @@ -2769,7 +2769,7 @@ namespace eval punk::lib { set console_raw 0 } try { - fconfigure stdin -blocking 1 + chan configure stdin -blocking 1 if {$console_raw} { punk::console::disableRaw set answer [gets stdin] @@ -2778,7 +2778,7 @@ namespace eval punk::lib { set answer [gets stdin] } } finally { - fconfigure stdin -blocking [tcl::dict::get $stdin_state -blocking] + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] } return $answer } @@ -2788,7 +2788,7 @@ namespace eval punk::lib { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { - lappend result "" + lappend result "" } else { lappend result $prefix[string trimright $line] } @@ -2827,7 +2827,7 @@ namespace eval punk::lib { } return [join $result \n] } - #A version of textutil::string::longestCommonPrefixList + #A version of textutil::string::longestCommonPrefixList proc longestCommonPrefix {items} { if {[llength $items] <= 1} { return [lindex $items 0] @@ -2844,9 +2844,9 @@ namespace eval punk::lib { } set n [string length $min] set prefix "" - set i -1 + set i -1 while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c + append prefix $c } return $prefix } @@ -2855,7 +2855,7 @@ namespace eval punk::lib { proc linesort {args} { #*** !doctools #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] - #[para]Sort lines in 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} { @@ -2871,7 +2871,7 @@ namespace eval punk::lib { #*** !doctools #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] #[para]This simply joines 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]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 @@ -2903,8 +2903,8 @@ namespace eval punk::lib { #*** !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 + #[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 @@ -2928,7 +2928,7 @@ namespace eval punk::lib { } #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 + #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) @@ -2938,14 +2938,14 @@ namespace eval punk::lib { } $args]] 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" + error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] set text [string map {\r\n \n} $text] ;#review - option? @@ -2957,7 +2957,7 @@ namespace eval punk::lib { -commandprefix ""\ -ansiresets auto\ -ansireplays 0\ - ] + ] foreach {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets - -ansireplays { @@ -2989,16 +2989,16 @@ namespace eval punk::lib { } if {"trimall" in $opt_block} { #no other block options make sense in combination with this - set opt_block [list "trimall"] + set opt_block [list "trimall"] } - #TODO + #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } - + # -- --- --- --- --- --- set opt_line [tcl::dict::get $opts -line] @@ -3056,7 +3056,7 @@ namespace eval punk::lib { } } elseif {$tl_left} { foreach ln $nlsplit { - lappend linelist [string trimleft $ln] + lappend linelist [string trimleft $ln] } } elseif {$tl_right} { foreach ln $nlsplit { @@ -3074,7 +3074,7 @@ namespace eval punk::lib { set last "-" } else { if {$last ne ""} { - lappend linelist "" + lappend linelist "" } set last "" } @@ -3090,11 +3090,11 @@ namespace eval punk::lib { set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { - break + break } else { set lastempty $idx } - incr idx + incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] @@ -3107,7 +3107,7 @@ namespace eval punk::lib { set i 0 foreach ln $revlinelist { if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] + set linelist [lreverse [lrange $revlinelist $i end]] break } incr i @@ -3131,13 +3131,13 @@ namespace eval punk::lib { } #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 + #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" + set RST "\x1b\[0m" } else { set RST "" } @@ -3157,7 +3157,7 @@ namespace eval punk::lib { } } else { - #INLINE punk::ansi::codetype::is_sgr_reset + #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 @@ -3176,30 +3176,30 @@ namespace eval punk::lib { #leave replaycodes as is for next line set nextreplay $replaycodes } else { - set tail $RST + 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 + 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 + 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 + #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 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 + set tail $RST #determine effective replay for line set codestack [list start] foreach code $ansisplits { @@ -3211,7 +3211,7 @@ namespace eval punk::lib { 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. + #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 @@ -3241,7 +3241,7 @@ namespace eval punk::lib { } } else { set nextreplay $replaycodes - } + } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay @@ -3260,7 +3260,7 @@ namespace eval punk::lib { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] - } + } set linelist $transformed } @@ -3271,14 +3271,14 @@ namespace eval punk::lib { 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 + #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" + error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] set text [string map {\r\n \n} $text] ;#review - option? @@ -3290,7 +3290,7 @@ namespace eval punk::lib { -commandprefix ""\ -ansiresets auto\ -ansireplays 0\ - ] + ] foreach {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets - -ansireplays { @@ -3322,16 +3322,16 @@ namespace eval punk::lib { } if {"trimall" in $opt_block} { #no other block options make sense in combination with this - set opt_block [list "trimall"] + set opt_block [list "trimall"] } - #TODO + #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } - + # -- --- --- --- --- --- set opt_line [tcl::dict::get $opts -line] @@ -3389,7 +3389,7 @@ namespace eval punk::lib { } } elseif {$tl_left} { foreach ln $nlsplit { - lappend linelist [string trimleft $ln] + lappend linelist [string trimleft $ln] } } elseif {$tl_right} { foreach ln $nlsplit { @@ -3407,7 +3407,7 @@ namespace eval punk::lib { set last "-" } else { if {$last ne ""} { - lappend linelist "" + lappend linelist "" } set last "" } @@ -3423,11 +3423,11 @@ namespace eval punk::lib { set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { - break + break } else { set lastempty $idx } - incr idx + incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] @@ -3440,7 +3440,7 @@ namespace eval punk::lib { set i 0 foreach ln $revlinelist { if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] + set linelist [lreverse [lrange $revlinelist $i end]] break } incr i @@ -3464,13 +3464,13 @@ namespace eval punk::lib { } #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 + #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" + set RST "\x1b\[0m" } else { set RST "" } @@ -3490,7 +3490,7 @@ namespace eval punk::lib { } } else { - #INLINE punk::ansi::codetype::is_sgr_reset + #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 @@ -3507,28 +3507,28 @@ namespace eval punk::lib { #leave replaycodes as is for next line set nextreplay $replaycodes } else { - set tail $RST + 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 + 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 + 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 + #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 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 + set tail $RST #determine effective replay for line set codestack [list start] foreach {pt code} $ansisplits { @@ -3540,7 +3540,7 @@ namespace eval punk::lib { 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. + #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 @@ -3570,7 +3570,7 @@ namespace eval punk::lib { } } else { set nextreplay $replaycodes - } + } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay @@ -3589,7 +3589,7 @@ namespace eval punk::lib { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] - } + } set linelist $transformed } @@ -3600,17 +3600,17 @@ namespace eval punk::lib { 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 + #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 + 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 + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance set i 0 - set times {} + set times {} if {$iters < 2} {set iters 2} for {set i 0} {$i < $iters} {incr i} { @@ -3629,8 +3629,8 @@ namespace eval punk::lib { set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] } - set sigma [expr {int(sqrt($s2))}] - set average [expr int($average)] + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] return "$average +/- $sigma microseconds per iteration" } @@ -3673,9 +3673,9 @@ namespace eval punk::lib { default { return [list $dec $c] } - } + } + - } @@ -3686,7 +3686,7 @@ namespace eval punk::lib { 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. + #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" @@ -3701,7 +3701,7 @@ namespace eval punk::lib { set data [tcl::unsupported::disassemble method $obj $method] } } else { - error "show_jump_tables expected a procname or a class/object and method" + error "show_jump_tables expected a procname or a class/object and method" } set result "" set in_jt 0 @@ -3786,10 +3786,10 @@ namespace eval punk::lib { } #todo - get configured user defaults if {$delim eq ""} { - set delim $default_delim + set delim $default_delim } if {$groupsize eq ""} { - set groupsize $default_groupsize + set groupsize $default_groupsize } lappend results [delimit_number $number $delim $groupsize] @@ -3820,10 +3820,10 @@ namespace eval punk::lib { # 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 [expr $point + 1] end]; + set PostDecimal [string range $number $point+1 end]; set PostDecimalP 1; } else { - set point [expr [string length $number] + 1] + set point [expr {[string length $number] + 1}] set PostDecimal ""; set PostDecimalP 0; } @@ -3834,16 +3834,16 @@ namespace eval punk::lib { incr ind; } set FirstNonSpace $ind; - set LastSpace [expr $FirstNonSpace - 1]; + 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 [expr $point -1]]; + 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 Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; set DelimitedMain ""; #First we deal with the extra stuff. @@ -3851,7 +3851,7 @@ namespace eval punk::lib { append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; } set FirstInGroup $Phase; - set LastInGroup [expr $FirstInGroup + $GroupSize -1]; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; while {$LastInGroup < $Length} { if {$FirstInGroup > 0} { append DelimitedMain $delim; @@ -3869,7 +3869,7 @@ namespace eval punk::lib { } } - + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib ---}] @@ -3884,10 +3884,10 @@ tcl::namespace::eval punk::lib::flatgrid { #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 {$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]] @@ -3895,7 +3895,7 @@ tcl::namespace::eval punk::lib::flatgrid { set rows [list] set i 1 foreach s [lrange $splits 0 end-1] { - lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] incr i } return $rows @@ -3958,16 +3958,20 @@ tcl::namespace::eval punk::lib::flatgrid { } } +tcl::namespace::eval punk::lib::test { + +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #todo - way to generate 'internal' docs separately? #*** !doctools #[section Internal] tcl::namespace::eval punk::lib::system { - #*** !doctools + #*** !doctools #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #[list_begin definitions] @@ -3975,7 +3979,7 @@ tcl::namespace::eval punk::lib::system { ##*** !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) + #[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} { @@ -3988,9 +3992,9 @@ tcl::namespace::eval punk::lib::system { return [list number $most numfactors $mostcount] } proc factorCountBelow_punk {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[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! @@ -4001,9 +4005,9 @@ tcl::namespace::eval punk::lib::system { return $tally } proc factorCountBelow_numtheory {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[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) @@ -4070,7 +4074,7 @@ tcl::namespace::eval punk::lib::system { lappend innerpartials "" } else { if {[lindex $waiting end] eq {"}} { - #this quote is endquote + #this quote is endquote set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { @@ -4078,7 +4082,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting {"} lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4089,7 +4093,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\]" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4098,7 +4102,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\}" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4109,13 +4113,13 @@ tcl::namespace::eval punk::lib::system { set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } } } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } set escaped 0 @@ -4192,20 +4196,20 @@ tcl::namespace::eval punk::lib::system { } #get info about punk nestindex key ie type: list,dict,undetermined - # pdict devel + # pdict devel proc nestindex_info {args} { set argd [punk::args::get_dict { -parent -default "" - nestindex + nestindex } $args] 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 + 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 @@ -4221,11 +4225,11 @@ namespace eval ::punk::args::register { lappend ::punk::args::register::NAMESPACES ::punk::lib } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::lib [tcl::namespace::eval punk::lib { variable pkg punk::lib 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/mix/base-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm index c5ec5551..69f2f5cb 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -18,7 +18,7 @@ namespace eval punk::mix::base { set extension "" } #--------- - + uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] } proc _cli {args} { @@ -69,7 +69,7 @@ namespace eval punk::mix::base { } #puts stderr "arglen:[llength $args]" #puts stdout "_unknown '$ns' '$args'" - + set d_commands [get_commands -extension $extension] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] @@ -98,11 +98,11 @@ namespace eval punk::mix::base { } tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns } else { - if {[regexp {.*[*?].*} $subcommand]} { + if {[regexp {.*[*?].*} $subcommand]} { set d_commands [get_commands -extension $from_ns] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] set matched_commands [lsearch -all -inline $all_commands $subcommand] - set commands "" + set commands "" foreach m $matched_commands { append commands $m \n } @@ -113,12 +113,12 @@ namespace eval punk::mix::base { } proc _split_args {arglist} { #don't assume arglist is fully paired. - set posn [lsearch $arglist -extension] + set posn [lsearch $arglist -extension] set opts [list] if {$posn >= 0} { if {$posn+2 <= [llength $arglist]} { set opts [list -extension [lindex $arglist $posn+1]] - set argsremaining [lreplace $arglist $posn $posn+1] + set argsremaining [lreplace $arglist $posn $posn+1] } else { #no value supplied to -extension error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." @@ -151,7 +151,7 @@ namespace eval punk::mix::base { if {![string length $extension]} { set extension [namespace qualifiers [lindex [info level -1] 0]] } - + set maincommands [list] #extension may still be blank e.g if punk::mix::base::get_commands called directly if {[string length $extension]} { @@ -164,7 +164,7 @@ namespace eval punk::mix::base { } foreach c $nscommands { set cmd [namespace tail $c] - lappend maincommands $cmd + lappend maincommands $cmd } set maincommands [lsort $maincommands] } @@ -190,29 +190,29 @@ namespace eval punk::mix::base { set basecommands [lsort $basecommands] - return [list main $maincommands base $basecommands] + return [list main $maincommands base $basecommands] } proc help {args} { #' **%ensemblecommand% help** *args* - #' + #' #' Help for ensemble commands in the command line interface - #' - #' + #' + #' #' Arguments: - #' + #' #' * args - first word of args is the helptopic requested - usually a command name #' - calling help with no arguments will list available commands - #' + #' #' Returns: help text (text) - #' + #' #' Examples: - #' + #' #' ``` #' %ensemblecommand% help #' ``` - #' - #' - + #' + #' + #extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| # >} inspect -label a {| @@ -220,7 +220,7 @@ namespace eval punk::mix::base { # pipecase ,0/1/#= $switchargs {| # e/0 # >} .=>. {set e} - # pipecase /1,1/1/#= $switchargs + # pipecase /1,1/1/#= $switchargs #} |@@ok/result> " opts $opts] } @@ -620,7 +620,7 @@ namespace eval punk::mix::base { if {$path eq $base} { #attempting to cksum at root/volume level of a filesystem.. extra work - #This needs fixing for general use.. not necessarily just for project repos + #This needs fixing for general use.. not necessarily just for project repos puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" return [list error unsupported_path opts $opts] } @@ -671,8 +671,8 @@ namespace eval punk::mix::base { set archivename $tmplocation/[punk::mix::util::tmpfile].tar cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) - - #temp emission to stdout.. todo - repl telemetry channel + + #temp emission to stdout.. todo - repl telemetry channel puts stdout "cksum_path: creating temporary tar archive for $path" puts -nonewline stdout " at: $archivename ..." set tsstart [clock millis] @@ -692,7 +692,7 @@ namespace eval punk::mix::base { set ms [expr {$tsend - $tsstart}] puts stdout " tar::create done ($ms ms)" puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing" - } + } if {$ftype eq "file"} { set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)" @@ -718,7 +718,7 @@ namespace eval punk::mix::base { set cksum [{*}$cksum_command $path] } } else { - error "cksum_path unsupported $opts for path type [file type $path]" + error "cksum_path unsupported $opts for path type [file type $path]" } } set result [dict create] @@ -733,7 +733,7 @@ namespace eval punk::mix::base { #base can be empty string in which case paths must be absolute #expect dict_path_cksum to be a dict keyed on relpath where each value is a dictionary with keys cksum and opts # ie subdict for can be created from output of cksum_path (for already known values not requiring filling) - # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) + # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { if {$base eq ""} { set error_paths [list] @@ -775,7 +775,7 @@ namespace eval punk::mix::base { } } if {$base ne ""} { - set fullpath [file join $base $path] + set fullpath [file join $base $path] } else { set fullpath $path } @@ -820,7 +820,7 @@ namespace eval punk::mix::base { #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will honour valid-looking prefilled cksum values (ie will pass them through) #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) proc get_relativecksum_from_base {base specifiedpath args} { - if {$base ne ""} { + if {$base ne ""} { #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix if {[file pathtype $specifiedpath] eq "relative"} { @@ -846,9 +846,9 @@ namespace eval punk::mix::base { #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" } - set targetpath $specifiedpath + set targetpath $specifiedpath set storedpath [punk::path::relative $base $specifiedpath] - + } } else { if {[file type $specifiedpath] eq "relative"} { @@ -863,7 +863,7 @@ namespace eval punk::mix::base { # #NOTE: specifiedpath can be a relative path (to cwd) when base is empty - #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc + #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc #possibly also: base: somewhere targetpath: ../elsewhere/etc # #todo - write tests @@ -881,7 +881,7 @@ namespace eval punk::mix::base { set ckopts [cksum_filter_opts {*}$args] set ckinfo [cksum_path $targetpath {*}$ckopts] - + set keyvals $args ;# REVIEW dict set keyvals cksum [dict get $ckinfo cksum] #dict set keyvals cksum_all_opts [dict get $ckinfo opts] @@ -891,7 +891,7 @@ namespace eval punk::mix::base { } #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop - #storedpath is relative if possible + #storedpath is relative if possible return [dict create $storedpath $keyvals] } @@ -910,7 +910,7 @@ namespace eval punk::mix::base { dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] } - #buildruntime.exe obsolete.. + #buildruntime.exe obsolete.. set fullpath_buildruntime $buildfolder/buildruntime.exe set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] @@ -944,7 +944,7 @@ namespace eval punk::mix::base { } proc get_all_build_cksums_stored {path} { set buildfolder [get_build_workdir $path] - + set vfscontainer [file dirname $buildfolder] set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] set dict_cksums [dict create] @@ -963,7 +963,7 @@ namespace eval punk::mix::base { } set vfscontainer [file dirname $vfsfolder] set buildfolder $vfscontainer/_build - set dict_vfs [get_vfs_build_cksums $vfsfolder] + set dict_vfs [get_vfs_build_cksums $vfsfolder] set data "" dict for {path cksum} $dict_vfs { append data "$path $cksum" \n diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 5d38fad8..3cf64b33 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::mix::cli 0.3.1 +# Application punk::mix::cli 0.3.1 # Meta platform tcl # Meta license # @@ Meta End @@ -19,7 +19,7 @@ ##e.g package require frobz package require punk::repo package require punk::ansi -package require punkcheck ;#checksum and/or timestamp records +package require punkcheck ;#checksum and/or timestamp records @@ -33,7 +33,7 @@ namespace eval punk::mix::cli { namespace ensemble create variable initialised 0 - #lazy _init - called by punk::mix::base::_cli when ensemble used + #lazy _init - called by punk::mix::base::_cli when ensemble used proc _init {args} { variable initialised if {$initialised} { @@ -52,7 +52,7 @@ namespace eval punk::mix::cli { catch { package require punk::mix::commandset::project punk::overlay::import_commandset project . ::punk::mix::commandset::project - punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection } if {[catch { package require punk::mix::commandset::layout @@ -91,12 +91,12 @@ namespace eval punk::mix::cli { } proc stat {{workingdir ""} args} { - dict set args -v 0 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 0 + punk::mix::cli::lib::get_status $workingdir {*}$args } proc status {{workingdir ""} args} { - dict set args -v 1 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 1 + punk::mix::cli::lib::get_status $workingdir {*}$args } @@ -128,13 +128,13 @@ namespace eval punk::mix::cli { set project_base [punk::repo::find_candidate] set sourcefolder $project_base/src puts stderr "WARNING - project not under git or fossil control" - puts stderr "Using base folder $project_base" + puts stderr "Using base folder $project_base" } else { set sourcefolder $startdir } } - #review - why can't we be anywhere in the project? + #review - why can't we be anywhere in the project? #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { puts stderr "dev make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" @@ -157,7 +157,7 @@ namespace eval punk::mix::cli { if {![string length $project_base]} { puts stderr "WARNING no git or fossil repository detected." - puts stderr "Using base folder $startdir" + puts stderr "Using base folder $startdir" set project_base $startdir } @@ -178,7 +178,7 @@ namespace eval punk::mix::cli { } } #cd $sourcefolder - + #use run so that stdout visible as it goes if {![catch {run --timeout=55000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { #todo - notify if exit because of timeout! @@ -198,7 +198,7 @@ namespace eval punk::mix::cli { puts stdout "OK make finished " return true } - } + } proc Kettle {args} { tailcall lib::kettle_call lib {*}$args @@ -241,7 +241,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- if {$opt_strict} { if {[regexp {[A-Z]} $modulename]} { - error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" + error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" } } @@ -272,7 +272,7 @@ namespace eval punk::mix::cli { } elseif {[regexp {[A-Z]} $modulename]} { set msg "module names containing uppercase are not recommended (see tip 590).\n" append msg "Please retype the module name '$modulename' to proceed.\n" - append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" append msg "Retype it all in lowercase to use recommended naming" set answer [util::askuser $msg] if {[regexp {[A-Z]} $answer]} { @@ -285,11 +285,11 @@ namespace eval punk::mix::cli { } set modulename $answer } else { - #user has resupplied modulename all as lowercase + #user has resupplied modulename all as lowercase if {$answer eq [string tolower $modulename]} { set finalised 1 } else { - #.. but it doesn't match original - require rerun + #.. but it doesn't match original - require rerun } set modulename $answer } @@ -332,7 +332,7 @@ namespace eval punk::mix::cli { if {[string first "::" $projectname] >= 0} { error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" } - return $projectname + return $projectname } proc validate_name_not_empty_or_spaced {name args} { set opts [list\ @@ -394,7 +394,7 @@ namespace eval punk::mix::cli { set result "" if {$workingdir ne ""} { if {[file pathtype $workingdir] ne "absolute"} { - set workingdir [file normalize $workingdir] + set workingdir [file normalize $workingdir] } set active_dir $workingdir } else { @@ -403,10 +403,10 @@ namespace eval punk::mix::cli { set defaults [dict create\ -v 1\ ] - set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- set opt_v [dict get $opts -v] - # -- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- set repopaths [punk::repo::find_repos [pwd]] @@ -417,7 +417,7 @@ namespace eval punk::mix::cli { append result [dict get $repopaths warnings] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { - #review - multiple process launches to fossil a bit slow on windows.. + #review - multiple process launches to fossil a bit slow on windows.. #could we query global db in one go instead? # set fossil_prog [auto_execok fossil] @@ -444,14 +444,14 @@ namespace eval punk::mix::cli { if {"project" in $repotypes} { #punk project if {![catch {package require textblock; package require patternpunk}]} { - set result [textblock::join -- [>punk . logo] " " $result] + set result [textblock::join -- [>punk . logo] " " $result] append result \n - } - } + } + } set timeline [exec fossil timeline -n 5 -t ci] set timeline [string map {\r\n \n} $timeline] - append result $timeline + append result $timeline if {$opt_v} { set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] append result \n [punk::repo::workingdir_state_summary $repostate] @@ -516,7 +516,7 @@ namespace eval punk::mix::cli { puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" exit 2 } - set srcdirname [file tail $srcdir] + set srcdirname [file tail $srcdir] set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir if {[llength $subdirlist] == 0} { @@ -578,7 +578,7 @@ namespace eval punk::mix::cli { } set fileparts [split [file rootname $modpath] -] #set tmfile_versionsegment [lindex $fileparts end] - lassign [split_modulename_version $modpath] basename tmfile_versionsegment + lassign [split_modulename_version $modpath] basename tmfile_versionsegment if {$tmfile_versionsegment eq ""} { #split_modulename_version version part will be empty if not valid tcl version #last segment doesn't look even slightly versiony - fail. @@ -634,8 +634,8 @@ namespace eval punk::mix::cli { set modulefile $buildfolder/$basename-$module_build_version.tm - $build_event targetset_init INSTALL $podtree_copy - $build_event targetset_addsource $current_source_dir/$modpath + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath if {$tmfile_versionsegment eq $magicversion} { $build_event targetset_addsource $versionfile } @@ -667,7 +667,7 @@ namespace eval punk::mix::cli { if {[file exists $tmfile]} { set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm file rename $tmfile $newname - set tmfile $newname + set tmfile $newname } set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd set data [string map [list $magicversion $module_build_version] $data] @@ -745,12 +745,12 @@ namespace eval punk::mix::cli { $build_event targetset_end SKIPPED } $build_event destroy - $build_installer destroy + $build_installer destroy - #JMN - review + #JMN - review if {!$had_error} { - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm - $event targetset_addsource $modulefile + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile if {\ [llength [dict get [$event targetset_source_changes] changed]]\ || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ @@ -759,12 +759,12 @@ namespace eval punk::mix::cli { $event targetset_started # -- --- --- --- --- --- if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} - lappend module_list $modulefile + lappend module_list $modulefile if {[catch { file copy -force $modulefile $target_module_dir } errMsg]} { puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir" - $event targetset_end FAILED -note "could not copy $modulefile" + $event targetset_end FAILED -note "could not copy $modulefile" } else { puts stderr "Copied zip modpod module $modulefile to $target_module_dir" # -- --- --- --- --- --- @@ -782,7 +782,7 @@ namespace eval punk::mix::cli { } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar } file { set m $modpath @@ -808,12 +808,12 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #rebuild the .tm from the #tarjar + #rebuild the .tm from the #tarjar if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - + } else { - + } #REVIEW - should be in same structure/depth as $target_module_dir in _build? @@ -824,22 +824,22 @@ namespace eval punk::mix::cli { set tmfile $buildfolder/$basename-$module_build_version.tm file delete -force $buildfolder/#tarjar-$basename-$module_build_version file delete -force $tmfile - - + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version # #bsdtar doesn't seem to work.. or I haven't worked out the right options? #exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version package require tar - tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version if {![file exists $tmfile]} { puts stdout "ERROR: failed to build tarjar file $tmfile" exit 4 } #copy the file? - #set target $target_module_dir/$basename-$module_build_version.tm + #set target $target_module_dir/$basename-$module_build_version.tm #file copy -force $tmfile $target - + lappend module_list $tmfile } else { #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. @@ -851,7 +851,7 @@ namespace eval punk::mix::cli { # #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm $event targetset_addsource $versionfile $event targetset_addsource $current_source_dir/$m @@ -902,7 +902,7 @@ namespace eval punk::mix::cli { #------------------------------ } - + continue } ##------------------------------ @@ -917,7 +917,7 @@ namespace eval punk::mix::cli { #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] #set changed_list [dict get $changed_unchanged changed] #---------- - $event targetset_init INSTALL $target_module_dir/$m + $event targetset_init INSTALL $target_module_dir/$m $event targetset_addsource $current_source_dir/$m if {\ [llength [dict get [$event targetset_source_changes] changed]]\ @@ -981,7 +981,7 @@ namespace eval punk::mix::cli { } if {$CALLDEPTH == 0} { $event destroy - $installer destroy + $installer destroy } return $module_list } @@ -1017,7 +1017,7 @@ namespace eval punk::mix::cli { } dict set kettle_reset_args $p $arglist } - } + } } #call kettle_reinit to ensure recipes point to current project @@ -1095,14 +1095,14 @@ namespace eval punk::mix::cli { kettle_reinit } } - set first [lindex $args 0] + set first [lindex $args 0] if {[string match @* $first]} { error "deck kettle doesn't support special operations - try calling tclsh kettle directly" } if {$first eq "-f"} { set args [lassign $args __ path] } else { - set path $startdir/build.tcl + set path $startdir/build.tcl } set opts [list] @@ -1123,9 +1123,9 @@ namespace eval punk::mix::cli { } } - #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names + #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) - #REVIEW - needs to be updated to keep in sync with kettle. + #REVIEW - needs to be updated to keep in sync with kettle. set knownopts [list\ --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ @@ -1202,7 +1202,7 @@ namespace eval punk::mix::cli { package require punk::mix::base package require punk::overlay if {[catch { - punk::overlay::custom_from_base [namespace current] ::punk::mix::base + punk::overlay::custom_from_base [namespace current] ::punk::mix::base } errM]} { puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" error "punk::mix::cli error: $errM" @@ -1213,9 +1213,9 @@ namespace eval punk::mix::cli { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::cli [namespace eval punk::mix::cli { variable version - set version 0.3.1 + set version 0.3.1 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm index dab5312f..63b5335c 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm @@ -47,7 +47,7 @@ namespace eval punk::mix::templates { lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. #review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. - #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. + #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. return $decls } } @@ -86,9 +86,9 @@ namespace eval punk::mix::templates { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::templates [namespace eval punk::mix::templates { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file 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 79150d6c..8e4699dc 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 @@ -57,7 +57,7 @@ namespace eval punk::mix::util { incr i set last_opt $i } else { - set last_opt [expr {$i - 1}] + set last_opt [expr {$i - 1}] break } } @@ -73,7 +73,7 @@ namespace eval punk::mix::util { #puts stderr "opts: $opts paths: $paths" - #let's proceed, but warn the user if an apparent option is in paths + #let's proceed, but warn the user if an apparent option is in paths foreach opt [list -encoding -eofchar -translation] { if {$opt in $paths} { puts stderr "fcat WARNING: apparent option $opt found after file argument(s) (expected them before filenames). Passing to fileutil::cat anyway - but for at least some versions, these options may be ignored. commandline 'fcat $args'" @@ -142,7 +142,7 @@ namespace eval punk::mix::util { } #---------------------------------------- - #namespace import ::punk::ns::nsimport_noclobber + #namespace import ::punk::ns::nsimport_noclobber proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { set source_ns [namespace qualifiers $pattern] @@ -153,7 +153,7 @@ namespace eval punk::mix::util { set nscaller [uplevel 1 {namespace current}] set ns [punk::nsjoin $nscaller $ns] } - set a_export_patterns [namespace eval $source_ns {namespace export}] + set a_export_patterns [namespace eval $source_ns {namespace export}] set a_commands [info commands $pattern] set a_tails [lmap v $a_commands {namespace tail $v}] set a_exported_tails [list] @@ -359,9 +359,9 @@ namespace eval punk::mix::util { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::util [namespace eval punk::mix::util { 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/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 140f2678..bce44dee 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::nav::fs 0 0.1.0] #[copyright "2024"] #[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] -#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] +#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] #[require punk::nav::fs] #[keywords module filesystem terminal] #[description] @@ -117,9 +117,9 @@ tcl::namespace::eval punk::nav::fs { #Both tcl's notion of pwd and VIRTUAL_CWD can be out of sync with the process CWD. This happens when in a VFS. #We can also have VIRTUAL_CWD navigate to spaces that Tcl's cd can't - review - variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint + variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint if {![interp issafe]} { - set VIRTUAL_CWD [pwd] + set VIRTUAL_CWD [pwd] } else { set VIRTUAL_CWD "" } @@ -127,25 +127,25 @@ tcl::namespace::eval punk::nav::fs { variable VIRTUAL_CWD set cwd [pwd] if {$cwd ne $VIRTUAL_CWD} { - puts stderr "pwd: $cwd" + puts stderr "pwd: $cwd" } return $::punk::nav::fs::VIRTUAL_CWD } - #TODO - maintain per 'volume/server' CWD - #e.g cd and ./ to: - # d: + #TODO - maintain per 'volume/server' CWD + #e.g cd and ./ to: + # d: # //zipfs: # //server # https://example.com # should return to the last CWD for that volume/server - + #VIRTUAL_CWD follows pwd when changed via cd set stackrecord [commandstack::rename_command -renamer punk::nav::fs cd {args} { if {![catch { $COMMANDSTACKNEXT {*}$args } errM]} { - set ::punk::nav::fs::VIRTUAL_CWD [pwd] + set ::punk::nav::fs::VIRTUAL_CWD [pwd] } else { error $errM } @@ -153,7 +153,7 @@ tcl::namespace::eval punk::nav::fs { #*** !doctools #[subsection {Namespace punk::nav::fs}] - #[para] Core API functions for punk::nav::fs + #[para] Core API functions for punk::nav::fs #[list_begin definitions] @@ -170,7 +170,7 @@ tcl::namespace::eval punk::nav::fs { #This seems unfortunate - as a multithreaded set of test runs might otherwise have made some sense.. but perhaps for tests more serious isolation is a good idea. #It also seems common to cd when loading certain packages e.g tls from starkit. #While in most/normal cases the library will cd back to the remembered working directory after only a brief time - there seem to be many opportunities for issues - #if the repl is used to launch/run a number of things in the one process + #if the repl is used to launch/run a number of things in the one process proc d/ {args} { variable VIRTUAL_CWD @@ -205,7 +205,7 @@ tcl::namespace::eval punk::nav::fs { } set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] - set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) + set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) #set location [file normalize [dict get $matchinfo location]] set location [dict get $matchinfo location] @@ -217,7 +217,7 @@ tcl::namespace::eval punk::nav::fs { set filesizes [lsearch -all -inline -not $filesizes na] set filebytes [tcl::mathop::+ {*}$filesizes] lappend result filebytes [punk::lib::format_number $filebytes] - } + } if {[punk::nav::fs::system::codethread_is_running]} { if {[llength [info commands ::punk::console::titleset]]} { #if ansi is off - punk::console::titleset will try 'local' api method - which can fail @@ -252,18 +252,18 @@ tcl::namespace::eval punk::nav::fs { set a1 [lindex $args 0] switch -exact -- $a1 { . - ./ { - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } .. - ../ { if {$VIRTUAL_CWD eq "//zipfs:/" && ![string match //zipfs:/* [pwd]]} { #exit back to last nonzipfs path that was in use set VIRTUAL_CWD [pwd] - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } - #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) - # [file join //server ..] would become /server/.. - use normjoin to get //server - # file dirname //server/share would stay as //server/share + #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) + # [file join //server ..] would become /server/.. - use normjoin to get //server + # file dirname //server/share would stay as //server/share #set up1 [file dirname $VIRTUAL_CWD] set up1 [punk::path::normjoin $VIRTUAL_CWD ..] if {[string match //zipfs:/* $up1]} { @@ -277,7 +277,7 @@ tcl::namespace::eval punk::nav::fs { cd $up1 #set VIRTUAL_CWD [file normalize $a1] } - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } } @@ -318,13 +318,13 @@ tcl::namespace::eval punk::nav::fs { } } if {[file type $target] eq "directory"} { - set VIRTUAL_CWD $target + set VIRTUAL_CWD $target } } tailcall punk::nav::fs::d/ } set curdir $VIRTUAL_CWD - } else { + } else { set curdir [pwd] } @@ -365,7 +365,7 @@ tcl::namespace::eval punk::nav::fs { set location $path set glob * if {$searchspec_relative} { - set searchbase [pwd] + set searchbase [pwd] } else { set searchbase $path } @@ -373,19 +373,19 @@ tcl::namespace::eval punk::nav::fs { set location [file dirname $path] set glob [file tail $path] ;#search for exact match file if {$searchspec_relative} { - set searchbase [pwd] + set searchbase [pwd] } else { set searchbase [file dirname $path] } } } - set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] + set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] #puts stderr "=--->$matchinfo" set location [file normalize [dict get $matchinfo location]] if {[string match //xzipfs:/* $location] || $location ne $last_location} { - #REVIEW - zipfs test disabled with leading x + #REVIEW - zipfs test disabled with leading x #emit previous result if {[dict size $this_result]} { dict set this_result filebytes [punk::lib::format_number [dict get $this_result filebytes]] @@ -398,7 +398,7 @@ tcl::namespace::eval punk::nav::fs { set this_result [dict create] set dircount 0 set filecount 0 - } + } incr dircount [llength [dict get $matchinfo dirs]] incr filecount [llength [dict get $matchinfo files]] @@ -406,7 +406,7 @@ tcl::namespace::eval punk::nav::fs { dict set this_result location $location dict set this_result dircount $dircount dict set this_result filecount $filecount - + set filesizes [dict get $matchinfo filesizes] if {[llength $filesizes]} { set filesizes [lsearch -all -inline -not $filesizes na] @@ -468,7 +468,7 @@ tcl::namespace::eval punk::nav::fs { } set normpath [file normalize $path] cd $normpath - set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] + set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] set location [file normalize [dict get $matchinfo location]] @@ -479,7 +479,7 @@ tcl::namespace::eval punk::nav::fs { set filesizes [lsearch -all -inline -not $filesizes na] set filebytes [tcl::mathop::+ {*}$filesizes] lappend result filebytes [punk::lib::format_number $filebytes] - } + } set out [dirfiles_dict_as_lines -stripbase 1 $matchinfo] #return $out\n[pwd] @@ -583,7 +583,7 @@ tcl::namespace::eval punk::nav::fs { set ext [file extension $path] set extlower [string tolower $ext] if {$extlower in $tcl_extensions} { - set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first set ::argv0 $path set ::argc [llength $newargs] set ::argv $newargs @@ -609,7 +609,7 @@ tcl::namespace::eval punk::nav::fs { } } if {$tcl_indicator} { - set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. set ::argv0 $path set ::argc [llength $newargs] set ::argv $newargs @@ -645,7 +645,7 @@ tcl::namespace::eval punk::nav::fs { } proc dirfiles {args} { set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] - lassign [dict values $argd] leaders opts values_dict + lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] set opt_formatsizes [dict get $opts -formatsizes] @@ -663,11 +663,11 @@ tcl::namespace::eval punk::nav::fs { #dirfiles_dict would handle simple cases of globs within paths anyway - but we need to explicitly set tailglob here in all branches so that next level doesn't need to do file vs dir checks to determine user intent. #(dir-listing vs file-info when no glob-chars present is inherently ambiguous so we test file vs dir to make an assumption - more explicit control via -tailglob can be done manually with dirfiles_dict) if {$relativepath} { - set searchbase [pwd] + set searchbase [pwd] if {!$has_tailglobs} { if {[file isdirectory [file join $searchbase $searchspec]]} { set location [file join $searchbase $searchspec] - set tailglob * + set tailglob * } else { set location [file dirname [file join $searchbase $searchspec]] set tailglob [file tail $searchspec] ;#use exact match as a glob - will retrieve size,attributes etc. @@ -700,29 +700,29 @@ tcl::namespace::eval punk::nav::fs { return [dirfiles_dict_as_lines -stripbase $opt_stripbase -formatsizes $opt_formatsizes $contents] } - #todo - package as punk::nav::fs + #todo - package as punk::nav::fs #todo - in thread #todo - streaming version #glob patterns in path prior to final segment should already be resolved before using dirfiles_dict - as the underlying filesystem mechanisms can't do nested globbing themselves. #dirfiles_dict will assume the path up to the final segment is literal even if globchars are included therein. #final segment globs will be recognised only if -tailglob is passed as empty string #if -tailglob not supplied and last segment has globchars - presume searchspec parendir is the container and last segment is globbing within that. - #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * + #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * #caller should use parentdir as location and set tailglob to search-pattern or exact match if location is intended to match a file rather than a directory #examples: # somewhere/files = search is effectively somewhere/files/* (location somewhere/files glob is *) # somewhere/files/* = (as above) - # -tailglob * somewhere/files = (as above) + # -tailglob * somewhere/files = (as above) # # -tailglob "" somewhere/files = search somewhere folder for exactly 'files' (location somewhere glob is files) # -tailglob files somewhere = (as above) # # somewhere/f* = search somewhere folder for f* (location somewhere glob is f*) - # -tailglob f* somewhere = (as above) - # + # -tailglob f* somewhere = (as above) + # # This somewhat clumsy API is so that simple searches can be made in a default sensible manner without requiring extra -tailglob argument for the common cases - with lack of trailing glob segment indicating a directory listing # - but we need to distinguish somewhere/files as a search of that folder vs somewhere/files as a search for exactly 'files' within somewhere, hence the -tailglob option to fine-tune. - # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. + # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. # #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied @@ -733,7 +733,7 @@ tcl::namespace::eval punk::nav::fs { -searchbase -default "" -tailglob -default "\uFFFF" #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) - -with_sizes -default "\uFFFF" -type string + -with_sizes -default "\uFFFF" -type string -with_times -default "\uFFFF" -type string @values -min 0 -max -1 -type string } @@ -743,7 +743,7 @@ tcl::namespace::eval punk::nav::fs { #puts stderr "searchspecs: $searchspecs [llength $searchspecs]" #puts stdout "arglist: $opts" - + if {[llength $searchspecs] > 1} { #review - spaced paths ? error "dirfiles_dict: multiple listing not *yet* supported" @@ -757,7 +757,7 @@ tcl::namespace::eval punk::nav::fs { # -- --- --- --- --- --- --- #we don't want to normalize.. - #for example if the user supplies ../ we want to see ../result + #for example if the user supplies ../ we want to see ../result set is_relativesearchspec [expr {[file pathtype $searchspec] eq "relative"}] if {$opt_searchbase eq ""} { @@ -770,7 +770,7 @@ tcl::namespace::eval punk::nav::fs { switch -- $opt_tailglob { "" { if {$searchspec eq ""} { - set location + set location } else { if {$is_relativesarchspec} { #set location [file dirname [file join $opt_searchbase $searchspec]] @@ -821,13 +821,13 @@ tcl::namespace::eval punk::nav::fs { set location $searchspec } } - set match_contents $opt_tailglob + set match_contents $opt_tailglob } } #puts stdout "searchbase: $searchbase searchspec:$searchspec" - #file attr //cookit:/ returns {-vfs 1 -handle {}} + #file attr //cookit:/ returns {-vfs 1 -handle {}} #we will treat it differently for now - use generic handler REVIEW set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit. if {[llength [package provide vfs]]} { @@ -873,11 +873,11 @@ tcl::namespace::eval punk::nav::fs { #we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name? set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob) } else { - #we could use 'file attr' here to test if {-vfs 1} - #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) + #we could use 'file attr' here to test if {-vfs 1} + #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) #instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume } - + } } @@ -885,7 +885,7 @@ tcl::namespace::eval punk::nav::fs { #relative vs absolute? review - cwd valid for //zipfs:/ ?? set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } elseif {$in_cookit} { - #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ + #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ #don't use twapi #could possibly use du_dirlisting_tclvfs REVIEW #files and folders are all returned with the -types hidden option for glob on windows @@ -928,12 +928,12 @@ tcl::namespace::eval punk::nav::fs { lappend dirs $vfsmount } } - } + } #NOTE: -types {hidden d} * may return . & .. on unix platforms - but will not show them on windows. #A mounted vfs exe (e.g sometclkit.exe) may be returned by -types {hidden d} on windows - but at the same time has "-hidden 0" in the result of file attr. - + #non-unix platforms may have attributes to indicate hidden status even if filename doesn't have leading dot. #mac & windows have these #windows doesn't consider dotfiles as hidden - mac does (?) @@ -946,8 +946,8 @@ tcl::namespace::eval punk::nav::fs { set flaggedhidden [punk::lib::lunique_unordered $flaggedhidden] } - set dirs [lsort $dirs] ;#todo - natsort - + set dirs [lsort $dirs] ;#todo - natsort + #foreach d $dirs { @@ -958,7 +958,7 @@ tcl::namespace::eval punk::nav::fs { #glob -types {hidden} will not always return the combination of glob -types {hidden f} && -types {hidden d} (on windows anyway) - # -- --- + # -- --- #can't lsort files without lsorting filesizes #Note - the sort by index would convert an empty filesizes list to a list of empty strings - one for each entry in files #We want to preserve the empty list if that's what the dirlisting mechanism returned (presumably because -with_sizes was 0 or explicitly excluded files) @@ -971,22 +971,22 @@ tcl::namespace::eval punk::nav::fs { set sorted_filesizes [list] foreach i $sortorder { lappend sorted_files [lindex $files $i] - lappend sorted_filesizes [lindex $filesizes $i] + lappend sorted_filesizes [lindex $filesizes $i] } } set files $sorted_files set filesizes $sorted_filesizes - # -- --- + # -- --- #jmn foreach nm [list {*}$dirs {*}$files] { if {[punk::winpath::illegalname_test $nm]} { lappend nonportable $nm - } + } } - set front_of_dict [dict create location $location searchbase $opt_searchbase] + set front_of_dict [dict create location $location searchbase $opt_searchbase] set listing [dict merge $front_of_dict $listing] set updated [dict create dirs $dirs files $files filesizes $filesizes nonportable $nonportable flaggedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes] @@ -1045,7 +1045,7 @@ tcl::namespace::eval punk::nav::fs { set prefix_test_list [tcl::prefix all $searchbases [lindex $shortest_to_longest 0 0]] #if shortest doesn't match all searchbases - we have no common base if {[llength $prefix_test_list] == [llength $searchbases]} { - set common_base [lindex $shortest_to_longest 0 0]; #we + set common_base [lindex $shortest_to_longest 0 0]; #we } } } @@ -1082,11 +1082,11 @@ tcl::namespace::eval punk::nav::fs { } set $fileset $stripped } - #Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. + #Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. } # -- --- --- --- --- --- --- --- --- --- --- - #assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out + #assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out #As at 2024-09 for windows symlinks - Tcl can't do file readlink on symlinks created with mklink /D name target (SYMLINKD) or mklink name target (SYMLINK) #We can't read the target information - best we can do is classify it as a file or a dir #we can't use 'file type' as that will report just 'link' - but file isfile and file isdirectory work and should work for links on all platforms - REVIEW @@ -1110,7 +1110,7 @@ tcl::namespace::eval punk::nav::fs { } } } else { - #fallback if no target_type + #fallback if no target_type if {[file isfile $s]} { lappend file_symlinks $s #will be appended in finfo_plus later @@ -1125,9 +1125,9 @@ tcl::namespace::eval punk::nav::fs { } #we now have the issue that our symlinks aren't sorted within the dir/file categorisation - they currently will have to appear at beginning or end - TODO # -- --- --- --- --- --- --- --- --- --- --- - - - #todo - sort whilst maintaining order for metadata? + + + #todo - sort whilst maintaining order for metadata? #we need to co-sort files only with filesizes (other info such as times is keyed on fname so cosorting not required) @@ -1135,7 +1135,7 @@ tcl::namespace::eval punk::nav::fs { if {$opt_formatsizes} { set filesizes [punk::lib::format_number $filesizes] ;#accepts a list and will process each } - + #col2 (file info) with subcolumns set widest2a [tcl::mathfunc::max {*}[lmap v [list {*}$files {*}$file_symlinks ""] {string length $v}]] @@ -1162,7 +1162,7 @@ tcl::namespace::eval punk::nav::fs { set mtime [dict get $contents times $key m] set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] } else { - #set ts [string repeat { } 19] + #set ts [string repeat { } 19] set ts "$key vs [dict keys [dict get $contents times]]" } set note "" @@ -1181,7 +1181,7 @@ tcl::namespace::eval punk::nav::fs { set mtime [dict get $contents times $key m] set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] } else { - set ts "[string repeat { } 19]" + set ts "[string repeat { } 19]" } set note "link" ;#default only if {[dict exists $contents linkinfo $key linktype]} { @@ -1207,24 +1207,24 @@ tcl::namespace::eval punk::nav::fs { set fname [dict get $fdict file] if {[file extension $fname] eq ".lnk"} { if {![catch {package require punk::winlnk}]} { - set shortcutinfo [punk::winlnk::file_get_info $fname] + set shortcutinfo [punk::winlnk::file_get_info $fname] set target_type "file" ;#default/fallback if {[dict exists $shortcutinfo link_target]} { - set is_valid_lnk 1 + set is_valid_lnk 1 set tgt [dict get $shortcutinfo link_target] if {[file exists $tgt]} { #file type could return 'link' - we will use isfile/isdirectory if {[file isfile $tgt]} { set target_type file } elseif {[file isdirectory $tgt]} { - set target_type directory + set target_type directory } else { set target_type file ;## ? } } else { #todo - see if punk::winlnk has info about the type at the time of linking #for now - treat as file - } + } } else { #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. set is_valid_lnk 0 @@ -1239,7 +1239,7 @@ tcl::namespace::eval punk::nav::fs { } directory { #target of link is a dir - for display/categorisation purposes we want to see it as a dir - #will be styled later based on membership of dir_shortcuts + #will be styled later based on membership of dir_shortcuts lappend dirs $fname lappend dir_shortcuts $fname } @@ -1292,7 +1292,7 @@ tcl::namespace::eval punk::nav::fs { set fdisp "" if {[string length $d]} { if {$d in $flaggedhidden} { - set d1 [punk::ansi::a+ cyan normal] + set d1 [punk::ansi::a+ cyan normal] } if {$d in $vfsmounts} { if {$d in $flaggedhidden} { @@ -1313,7 +1313,7 @@ tcl::namespace::eval punk::nav::fs { } } else { if {$d in $nonportable} { - set d1 [punk::ansi::a+ red bold] + set d1 [punk::ansi::a+ red bold] } } #dlink-style & dshortcut_style are for underlines - can be added with colours already set @@ -1336,11 +1336,11 @@ tcl::namespace::eval punk::nav::fs { } lappend displaylist [overtype::left $col1 $d1$d$RST]$f1$fdisp$RST } - + return [punk::lib::list_as_lines $displaylist] - } + } - #pass in base and platform to head towards purity/testability. + #pass in base and platform to head towards purity/testability. #this function can probably never be pure in such a simple form - as it needs to read state from the os storage system configuration #consider haskells approach of well-typed paths for cross-platform paths: https://hackage.haskell.org/package/path #review: punk::winpath calls cygpath! @@ -1360,8 +1360,8 @@ tcl::namespace::eval punk::nav::fs { set path_absolute [punk::unixywindows::towinpath $path] #puts stderr "winpath: $path" } else { - #todo handle volume-relative paths with volume specified c:etc c: - #note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd + #todo handle volume-relative paths with volume specified c:etc c: + #note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd #not clear whether tcl can/will fix this - but it means these paths are dangerous. #The cwd of the process can get out of sync with what tcl thinks is the working directory when you swap drives #Arguably if ...? @@ -1421,14 +1421,14 @@ tcl::namespace::eval punk::nav::fs::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::nav::fs::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 + # #[para]Description of utility1 + # return 1 #} @@ -1446,7 +1446,7 @@ tcl::namespace::eval punk::nav::fs::lib { tcl::namespace::eval punk::nav::fs::system { #*** !doctools #[subsection {Namespace punk::nav::fs::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #ordinary emission of chunklist when no repl proc emit_chunklist {chunklist} { @@ -1471,18 +1471,18 @@ tcl::namespace::eval punk::nav::fs::system { proc codethread_is_running {} { if {[info commands ::punk::repl::codethread::is_running] ne ""} { - return [punk::repl::codethread::is_running] + return [punk::repl::codethread::is_running] } return 0 } } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::nav::fs [tcl::namespace::eval punk::nav::fs { variable pkg punk::nav::fs 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/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 feee9d87..a64eef0f 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 @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::repl::codethread 0 0.1.1] #[copyright "2024"] #[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] -#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] +#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] #[require punk::repl::codethread] #[keywords module repl] #[description] -#[para] This is part of the infrastructure required for the punk::repl to operate +#[para] This is part of the infrastructure required for the punk::repl to operate # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -122,7 +122,7 @@ tcl::namespace::eval punk::repl::codethread { #*** !doctools #[subsection {Namespace punk::repl::codethread}] - #[para] Core API functions for punk::repl::codethread + #[para] Core API functions for punk::repl::codethread #[list_begin definitions] @@ -130,13 +130,13 @@ tcl::namespace::eval punk::repl::codethread { #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" #} variable run_command_cache @@ -145,7 +145,7 @@ tcl::namespace::eval punk::repl::codethread { #if {[catch {interp children}]} { # #8.6.10 doesn't have it.. when was it introduced? #} else { - + #} proc is_running {} { @@ -153,14 +153,14 @@ tcl::namespace::eval punk::repl::codethread { return $running } proc runscript {script} { - + #puts stderr "->runscript" - variable replthread_cond + variable replthread_cond #variable output_stdout "" #variable output_stderr "" #expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available - #if a thread::send is done from the commandline in a codethread - Tcl will + #if a thread::send is done from the commandline in a codethread - Tcl will if {![interp exists code] || ![info exists replthread_cond]} { #in case someone tries calling from codethread directly - don't do anything or change any state #(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) @@ -233,12 +233,12 @@ tcl::namespace::eval punk::repl::codethread { flush stderr #interp transfer code $errhandle "" - #flush $errhandle + #flush $errhandle #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code [list set ::punk::repl::codethread::output_stdout]]] end] - set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] + set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] #note we could be in a *large* ansi segment such as sixel data - #review - why do we need to ansistrip? + #review - why do we need to ansistrip? set lastoutchar [string index [punk::ansi::ansistrip $lastoutpart] end] #set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] @@ -247,7 +247,7 @@ tcl::namespace::eval punk::repl::codethread { #puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" set tid [thread::id] - tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] + tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] tsv::set codethread_$tid status $status tsv::set codethread_$tid result $result tsv::set codethread_$tid errorcode $::errorCode @@ -277,14 +277,14 @@ tcl::namespace::eval punk::repl::codethread::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::repl::codethread::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 + # #[para]Description of utility1 + # return 1 #} @@ -302,17 +302,17 @@ tcl::namespace::eval punk::repl::codethread::lib { tcl::namespace::eval punk::repl::codethread::system { #*** !doctools #[subsection {Namespace punk::repl::codethread::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::repl::codethread [tcl::namespace::eval punk::repl::codethread { variable pkg punk::repl::codethread 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/punkcheck-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm index db8a3db5..fbf9a4e4 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 @@ -69,7 +69,7 @@ namespace eval punkcheck { } - proc load_records_from_file {punkcheck_file} { + proc load_records_from_file {punkcheck_file} { set record_list [list] if {[file exists $punkcheck_file]} { set tdlscript [punk::mix::util::fcat $punkcheck_file] @@ -86,7 +86,7 @@ namespace eval punkcheck { set linecount [llength [split $newtdl \n]] #puts stdout $newtdl set fd [open $punkcheck_file w] - fconfigure $fd -translation binary + chan configure $fd -translation binary puts -nonewline $fd $newtdl close $fd return [list recordcount [llength $recordlist] linecount $linecount] @@ -94,7 +94,7 @@ namespace eval punkcheck { #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? - #an installtrack objects represents an installation path from sourceroot to targetroot + #an installtrack objects represents an installation path from sourceroot to targetroot #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. # set objname [namespace current]::installtrack @@ -104,7 +104,7 @@ namespace eval punkcheck { #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD #each FILEINFO body being a list of SOURCE records oo::class create targetset { - variable o_targets + variable o_targets variable o_keep_installrecords variable o_keep_skipped variable o_keep_inprogress @@ -132,7 +132,7 @@ namespace eval punkcheck { -keep_inprogress $o_keep_inprogress\ body $o_records } - + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS method get_last_record {fileset_record} { set body [dict_getwithdefault $fileset_record body [list]] @@ -189,11 +189,11 @@ namespace eval punkcheck { } set o_ts_end [dict get $opts -tsend] set o_types [dict get $opts -types] - set o_configdict [dict get $opts -config] + set o_configdict [dict get $opts -config] set o_rel_sourceroot $rel_sourceroot set o_rel_targetroot $rel_targetroot - } + } destructor { #puts "[self] destructor called" } @@ -339,14 +339,14 @@ namespace eval punkcheck { set installing_record [lindex $fileinfo_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset fileinfo_body end $installing_record - + return [dict set o_fileset_record body $fileinfo_body] } else { #legacy call @@ -368,7 +368,7 @@ namespace eval punkcheck { } set status [string toupper $status] - set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] if {$o_operation_start_ts eq ""} { error "[self] targetset_end $status - no current operation - call targetset_started first" } @@ -383,7 +383,7 @@ namespace eval punkcheck { error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" } set operation_end_ts [clock microseconds] - set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] set file_record_body [dict get $o_fileset_record body] set installing_record [lindex $file_record_body end] set punkcheck_file [$o_installer get_checkfile] @@ -414,12 +414,12 @@ namespace eval punkcheck { } } set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] - dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -targets_cksums $new_targets_cksums dict set installing_record -cksum_all_opts $cksum_all_opts dict set installing_record -cksum_us $cksum_us } lset file_record_body end $installing_record - dict set o_fileset_record body $file_record_body + dict set o_fileset_record body $file_record_body set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] @@ -436,8 +436,8 @@ namespace eval punkcheck { set o_operation "" return $o_fileset_record } - #can supply empty cksum value - # - that will influence the opts used if there is no existing install record + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record method targetset_cksumcache_set {path_cksum_dict} { set o_path_cksum_cache $path_cksum_dict } @@ -504,12 +504,12 @@ namespace eval punkcheck { variable o_ts variable o_keep_events variable o_checkfile - variable o_sourceroot + variable o_sourceroot variable o_rel_sourceroot variable o_targetroot variable o_rel_targetroot variable o_record_list - variable o_active_event + variable o_active_event variable o_events constructor {installername punkcheck_file} { set o_active_event "" @@ -546,7 +546,7 @@ namespace eval punkcheck { #$o_events add $e [dict get $e -id] $o_events add $eobj [dict get $e -id] } - + } destructor { #puts "[self] destructor called" @@ -562,7 +562,7 @@ namespace eval punkcheck { } #call set_source_target before calling start_event/end_event - #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. method set_source_target {sourceroot targetroot} { if {[file pathtype $sourceroot] ne "absolute"} { error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" @@ -605,7 +605,7 @@ namespace eval punkcheck { } method save_installer_record {} { set file_records [punkcheck::load_records_from_file $o_checkfile] - + set this_installer_record [my as_record] set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] @@ -658,13 +658,13 @@ namespace eval punkcheck { set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] } method get_recordlist {} { - return $o_recordlist + return $o_recordlist } method end_event {} { if {$o_active_event eq ""} { error "[self] end_event error - no active event" } - $o_active_event end + $o_active_event end } method get_event {} { return $o_active_event @@ -720,7 +720,7 @@ namespace eval punkcheck { append msg "Call in order:" \n append msg " start_installer_event (get dict with eventid and recordset keys)" append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n - append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n append msg " ( - possibly with same algorithm as previous installrecord)" \n append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n append msg "Finalize by calling:" \n @@ -749,7 +749,7 @@ namespace eval punkcheck { set punkcheck_file [file join $punkcheck_folder/.punkcheck] set record_list [load_records_from_file $punkcheck_file] - + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] set installer_record_position [dict get $resultinfo position] if {$installer_record_position == -1} { @@ -805,7 +805,7 @@ namespace eval punkcheck { #validate any passed cached_cksums foreach cacheinfo $cached_cksums { if {[llength $cacheinfo] % 2 != 0} { - error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" } dict for {k v} $cacheinfo { switch -- $k { @@ -814,7 +814,7 @@ namespace eval punkcheck { #todo - validate $v keys } default { - error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" } } @@ -837,7 +837,7 @@ namespace eval punkcheck { } } } - #check that this relpath not already added as child of *-INPROGRESS + #check that this relpath not already added as child of *-INPROGRESS set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body set installing_record [lindex $file_record_body end] set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] @@ -871,14 +871,14 @@ namespace eval punkcheck { #use first entry in cached_cksums if we can if {[llength $cached_cksums]} { set use_cache 1 - set use_cache_record [lindex $cached_cksums 0] + set use_cache_record [lindex $cached_cksums 0] } } #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) #if same cksum_opts - then use cached data instead of checksumming here. - #allow nonexistant as a source + #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] if {![file exists $fpath]} { set ftype "missing" @@ -939,14 +939,14 @@ namespace eval punkcheck { set installing_record [lindex $file_record_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] - + dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset file_record_body end $installing_record - + dict set file_record body $file_record_body @@ -983,7 +983,7 @@ namespace eval punkcheck { dict set installing_record tag "INSTALL-RECORD" lset file_record_body end $installing_record - dict set file_record body $file_record_body + dict set file_record body $file_record_body set file_record [punkcheck::recordlist::file_record_prune $file_record] @@ -1016,8 +1016,8 @@ namespace eval punkcheck { set tsnow [clock microseconds] set elapsed_us [expr {$tsnow - $ts_start}] dict set installing_record -elapsed_us $elapsed_us - dict set installing_record tag "INSTALL-SKIPPED" - + dict set installing_record tag "INSTALL-SKIPPED" + lset file_record_body end $installing_record dict set file_record body $file_record_body @@ -1076,7 +1076,7 @@ namespace eval punkcheck { #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL proc install_record_get_matching_source_record {install_record source_relpath} { - set body [dict_getwithdefault $install_record body [list]] + set body [dict_getwithdefault $install_record body [list]] foreach src $body { if {[dict get $src tag] eq "SOURCE"} { if {[dict_getwithdefault $src -path ""] eq $source_relpath} { @@ -1124,7 +1124,7 @@ namespace eval punkcheck { set do_normalize 1 } } else { - #case differences in volumes is common on windows + #case differences in volumes is common on windows set do_normalize 1 } if {$do_normalize} { @@ -1207,7 +1207,7 @@ namespace eval punkcheck { if {[dict exists $dictValue {*}$keys]} { return [dict get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } lappend PUNKARGS [list { @@ -1273,11 +1273,11 @@ namespace eval punkcheck { # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target # -overwrite all-targets will copy regardless of timestamp at target - # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry # review - timestamps unreliable - # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? - # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? # if such a content-mismatch - what default behaviour and what options would make sense? # probably it's reasonable that only all-targets would overwrite such files. @@ -1369,7 +1369,7 @@ namespace eval punkcheck { if {[llength [file split $af]] > 1} { error "punkcheck::install received invalid -antiglob_file entry '$af'. -antiglob_file entries are meant to match to a file name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] if {$opt_antiglob_dir_core eq "\uFFFF"} { @@ -1383,7 +1383,7 @@ namespace eval punkcheck { if {[llength [file split $ad]] > 1} { error "punkcheck::install received invalid -antiglob_dir entry '$ad'. -antiglob_dir entries are meant to match to a directory name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment @@ -1482,7 +1482,7 @@ namespace eval punkcheck { } else { set store_source_cksums 0 } - + @@ -1545,12 +1545,12 @@ namespace eval punkcheck { } if {$suppress == 0} { lappend match_list $m - } + } } #sample .punkcheck file record (raw form) to make the code clearer #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist - #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS # #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { @@ -1563,15 +1563,15 @@ namespace eval punkcheck { # } #} - if {[llength $match_list]} { + if {[llength $match_list]} { #example - target dir has a file where there is a directory at the source if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" } } - + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} - + #puts stdout "Current target dir: $current_target_dir" foreach m $match_list { @@ -1581,7 +1581,7 @@ namespace eval punkcheck { set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing file - globmatchpath $antipath vs $relative_source_path" + #puts "testing file - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched $current_source_dir set is_antipath 1 @@ -1598,7 +1598,7 @@ namespace eval punkcheck { #puts stdout " rel_target: $punkcheck_target_relpath" - + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] #change to use extract_or_create_fileset_record ? set existing_filerec_posn [dict get $fetch_filerec_result position] @@ -1614,7 +1614,7 @@ namespace eval punkcheck { set filerec [dict get $fetch_filerec_result record] } set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] - + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. @@ -1630,7 +1630,7 @@ namespace eval punkcheck { #different volume or root } #Note this isn't a recordlist function - so it doesn't purely operate on the records - #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] @@ -1697,7 +1697,7 @@ namespace eval punkcheck { } else { #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it set is_skip 1 - puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" lappend files_skipped $current_source_dir/$m } } else { @@ -1728,7 +1728,7 @@ namespace eval punkcheck { #if {$store_source_cksums} { #} - set install_records [dict get $filerec body] + set install_records [dict get $filerec body] set current_install_record [lindex $install_records end] #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED if {$is_skip} { @@ -1790,7 +1790,7 @@ namespace eval punkcheck { set relative_source_path [file join $relative_source_dir $d] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing folder - globmatchpath $antipath vs $relative_source_path" + #puts "testing folder - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched [file join $current_source_dir $d] #puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath " @@ -1801,11 +1801,11 @@ namespace eval punkcheck { if {$is_antipath} { continue } - + #if {![file exists $current_target_dir/$d]} { # file mkdir $current_target_dir/$d #} - + set sub_opts_1 [list\ -call-depth-internal [expr {$CALLDEPTH + 1}]\ @@ -1828,7 +1828,7 @@ namespace eval punkcheck { -punkcheck_folder $punkcheck_folder\ -punkcheck_eventid $punkcheck_eventid\ -punkcheck_records $punkcheck_records\ - ] + ] set sub_opts [dict merge $opts $sub_opts] set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] @@ -1838,7 +1838,7 @@ namespace eval punkcheck { lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] set punkcheck_records [dict get $sub_result punkcheck_records] } - + if {[string match *store* $opt_source_checksum]} { #puts "subdirlist: $subdirlist" if {$CALLDEPTH == 0} { @@ -1849,7 +1849,7 @@ namespace eval punkcheck { #puts stdout ">>>>>>>>>>>>>>>>>>>" } else { #todo - write db INSTALLER record if -debug true - + } #puts stdout "sources_unchanged" #puts stdout "$sources_unchanged" @@ -2108,7 +2108,7 @@ namespace eval punkcheck { if {[dict get $file_record tag] ne "FILEINFO"} { error "file_record_set_defaults bad file_record: tag not FILEINFO" } - set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] foreach {k v} $defaults { if {![dict exists $file_record $k]} { dict set file_record $k $v @@ -2186,10 +2186,10 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punkcheck [namespace eval punkcheck { set pkg punkcheck 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/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 8d66978f..2d185f01 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 @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_textblock 0 0.1.3] #[copyright "2024"] #[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] +#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] #[require textblock] #[keywords module ansi text layout colour table frame console terminal] #[description] @@ -29,7 +29,7 @@ #*** !doctools #[section Overview] -#[para] overview of textblock +#[para] overview of textblock #[subsection Concepts] #[para] @@ -39,7 +39,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by textblock +#[para] packages used by textblock #[list_begin itemized] #*** !doctools @@ -90,7 +90,7 @@ package require textutil tcl::namespace::eval textblock { #review - what about ansi off in punk::console? tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ - tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus #(more likely to be optimised for modern cpu features?) @@ -102,7 +102,7 @@ tcl::namespace::eval textblock { namespace eval argdoc { proc hash_algorithm_choices_and_help {} { set choices [list none] - set unavailable [list] + set unavailable [list] set unloaded [dict create] set algorithm_packages {md5 sha1 sha256} foreach p $algorithm_packages { @@ -219,7 +219,7 @@ tcl::namespace::eval textblock { #ie only vll,blc,hlb used for cells except top row and right column #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 + #e.g for 4x4 # C C C O # L L L U # L L L U @@ -229,7 +229,7 @@ tcl::namespace::eval textblock { set L [list vll blc hlb] set U [list vll blc hlb brc vlr] set tops [list trc hlt tlc] - set lefts [list tlc vll blc] + set lefts [list tlc vll blc] set bottoms [list blc hlb brc] set rights [list trc brc vlr] @@ -491,8 +491,8 @@ tcl::namespace::eval textblock { set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v + set seps_h $requested_seps_h + set seps_v $requested_seps_v if {$requested_seps eq ""} { if {$requested_seps_h eq ""} { set seps_h 1 @@ -502,10 +502,10 @@ tcl::namespace::eval textblock { } } else { if {$requested_seps_h eq ""} { - set seps_h $seps + set seps_h $seps } if {$requested_seps_v eq ""} { - set seps_v $seps + set seps_v $seps } } return [tcl::dict::create horizontal $seps_h vertical $seps_v] @@ -515,8 +515,8 @@ tcl::namespace::eval textblock { set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body + set ft_header $requested_ft_header + set ft_body $requested_ft_body switch -- $requested_ft { light { if {$requested_ft_header eq ""} { @@ -544,10 +544,10 @@ tcl::namespace::eval textblock { } default { if {$requested_ft_header eq ""} { - set ft_header $requested_ft + set ft_header $requested_ft } if {$requested_ft_body eq ""} { - set ft_body $requested_ft + set ft_body $requested_ft } } } @@ -621,7 +621,7 @@ tcl::namespace::eval textblock { if {![llength $args]} { return $o_opts_table - } + } if {[llength $args] == 1} { if {[lindex $args 0] in [list %topt_keys%]} { #query single option @@ -634,7 +634,7 @@ tcl::namespace::eval textblock { tcl::dict::set infodict debug [ansistring VIEW $val] } -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] } } tcl::dict::set returndict info $infodict @@ -663,11 +663,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; + set ansi_codes [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend ansi_codes $code @@ -684,7 +684,7 @@ tcl::namespace::eval textblock { -framemap_body - -framemap_header { #upvar ::textblock::class::opts_table_defaults tdefaults #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map + #todo - check keys and map if {[llength $v] == 1} { if {$v eq "default"} { upvar ::textblock::class::opts_table_defaults tdefaults @@ -700,7 +700,7 @@ tcl::namespace::eval textblock { switch -- $subk { topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" } } #safe jumptable test @@ -752,14 +752,14 @@ tcl::namespace::eval textblock { } -show_hseps { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations } -show_edge { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play @@ -768,7 +768,7 @@ tcl::namespace::eval textblock { -show_vseps { #we allow empty string - so don't use -strict boolean check if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } #affects width calculations set o_calculated_column_widths [list] @@ -807,7 +807,7 @@ tcl::namespace::eval textblock { if {[my width] < [expr {$twidth+2}]} { set o_calculated_column_widths [list] tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] - } + } tcl::dict::set o_opts_table -title $v } default { @@ -840,7 +840,7 @@ tcl::namespace::eval textblock { } } #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] return $o_opts_table } @@ -858,7 +858,7 @@ tcl::namespace::eval textblock { for {set c 0} {$c < $matrix_colcount} {incr c} { my add_column -headers "" } - } + } set table_colcount [my column_count] if {$table_colcount != $matrix_colcount} { error "textblock::table::printmatrix column count of table doesn't match column count of matrix" @@ -874,7 +874,7 @@ tcl::namespace::eval textblock { method as_matrix {{cmd ""}} { #*** !doctools #[call class::table [method as_matrix] [arg ?cmd?]] - #[para] return a struct::matrix command representing the data portion of the table. + #[para] return a struct::matrix command representing the data portion of the table. if {$cmd eq ""} { set m [struct::matrix] @@ -883,8 +883,8 @@ tcl::namespace::eval textblock { } $m add columns [tcl::dict::size $o_columndata] $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v + tcl::dict::for {k v} $o_columndata { + $m set column $k $v } return $m } @@ -907,17 +907,17 @@ tcl::namespace::eval textblock { } } } - set colcount [tcl::dict::size $o_columndefs] + set colcount [tcl::dict::size $o_columndefs] tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { + if {[catch { my configure_column $colcount {*}$opts } errMsg]} { #configure failed - ensure o_columndata and o_columndefs entries are removed @@ -926,7 +926,7 @@ tcl::namespace::eval textblock { tcl::dict::unset o_columnstates $colcount #undo cache invalidation set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" } #any add_column that succeeds should invalidate the calculated column widths set o_calculated_column_widths [list] @@ -945,7 +945,7 @@ tcl::namespace::eval textblock { method column_count {} { #*** !doctools #[call class::table [method column_count]] - #[para] return the number of columns + #[para] return the number of columns return [tcl::dict::size $o_columndefs] } method configure_column {index_expression args} { @@ -956,7 +956,7 @@ tcl::namespace::eval textblock { set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } + } if {![llength $args]} { return [tcl::dict::get $o_columndefs $cidx] } else { @@ -991,7 +991,7 @@ tcl::namespace::eval textblock { } set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - set hstates $o_headerstates ;#operate on a copy + set hstates $o_headerstates ;#operate on a copy set colstate [tcl::dict::get $o_columnstates $cidx] set args_got_headers 0 set args_got_header_colspans 0 @@ -1000,7 +1000,7 @@ tcl::namespace::eval textblock { -headers { set args_got_headers 1 set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. foreach hdr $v { set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns #set this_header_height [textblock::height $hdr] @@ -1052,7 +1052,7 @@ tcl::namespace::eval textblock { # } #} else { set header_spans [tcl::dict::get $cspans $h] - set remaining [lindex $header_spans 0] + set remaining [lindex $header_spans 0] if {$remaining ne "any"} { incr remaining -1 } @@ -1109,11 +1109,11 @@ tcl::namespace::eval textblock { } -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; + set col_ansibase_items [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend col_ansibase_items $code @@ -1146,13 +1146,13 @@ tcl::namespace::eval textblock { } #args checked - ok to update headerstates, headerdefs and columndefs and columnstates tcl::dict::set o_columndefs $cidx $checked_opts - set o_headerstates $hstates + set o_headerstates $hstates dict for {hidx hstate} $hstates { #configure_header if {![dict exists $o_headerdefs $hidx]} { #remove calculated members -values -colspans set hdefaults [dict remove $o_opts_header_defaults -values -colspans] - dict set o_headerdefs $hidx $hdefaults + dict set o_headerdefs $hidx $hdefaults } } @@ -1183,7 +1183,7 @@ tcl::namespace::eval textblock { method header_count {} { #*** !doctools #[call class::table [method header_count]] - #[para] return the number of header rows + #[para] return the number of header rows return [tcl::dict::size $o_headerstates] } method header_count_calc {} { @@ -1232,7 +1232,7 @@ tcl::namespace::eval textblock { method header_colspans {} { #*** !doctools #[call class::table [method header_colspans]] - #[para] Show the colspans configured for all headers + #[para] Show the colspans configured for all headers #set num_headers [my header_count_calc] set num_headers [my header_count] @@ -1242,9 +1242,9 @@ tcl::namespace::eval textblock { set colspans_for_column [tcl::dict::get $cdef -header_colspans] for {set h 0} {$h < $num_headers} {incr h} { set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] + set defined_span [lindex $colspans_for_column $h] set i 0 - set spanremaining [lindex $headerspans 0] + set spanremaining [lindex $headerspans 0] if {$spanremaining ne "any"} { if {$spanremaining eq ""} { set spanremaining 1 @@ -1256,7 +1256,7 @@ tcl::namespace::eval textblock { set spanremaining "any" } elseif {$s == 0} { if {$spanremaining ne "any"} { - incr spanremaining -1 + incr spanremaining -1 } } else { set spanremaining [expr {$s - 1}] @@ -1273,7 +1273,7 @@ tcl::namespace::eval textblock { } else { lappend headerspans $defined_span } - tcl::dict::set colspans_by_header $h $headerspans + tcl::dict::set colspans_by_header $h $headerspans } } return $colspans_by_header @@ -1301,10 +1301,10 @@ tcl::namespace::eval textblock { } incr spanlen } - #overwrite the 'any' with it's actual span + #overwrite the 'any' with it's actual span set modified_spans [dict get $hcolspans $h] lset modified_spans $c $spanlen - dict set hcolspans $h $modified_spans + dict set hcolspans $h $modified_spans } incr c } @@ -1315,7 +1315,7 @@ tcl::namespace::eval textblock { method configure_header {index_expression args} { #*** !doctools #[call class::table [method configure_header]] - #[para] - configure header row-wise + #[para] - configure header row-wise #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis @@ -1331,7 +1331,7 @@ tcl::namespace::eval textblock { } if {![llength $args]} { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] set header_row_items [list] @@ -1339,9 +1339,9 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - tcl::dict::set result -values $header_row_items + tcl::dict::set result -values $header_row_items #review - ensure always a headerdef record for each header? if {[tcl::dict::exists $o_headerdefs $hidx]} { @@ -1359,7 +1359,7 @@ tcl::namespace::eval textblock { #set val [tcl::dict::get $o_rowdefs $ridx $k] set infodict [tcl::dict::create] - #todo + #todo # -blockalignments and -textalignments lists # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} #if there is a value it overrides alignments specified on the column @@ -1370,14 +1370,14 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - set val $header_row_items + set val $header_row_items set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] } -colspans { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] set val [tcl::dict::get $colspans_by_header $hidx] #ansireset not required @@ -1412,11 +1412,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; + set header_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend header_ansibase_items $code @@ -1443,7 +1443,7 @@ tcl::namespace::eval textblock { if {[llength $v] > $numcols} { error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" } - if {[llength $v] < $numcols} { + if {[llength $v] < $numcols} { puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" } @@ -1457,7 +1457,7 @@ tcl::namespace::eval textblock { } if {!$first_is_ok} { error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" - } + } #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) set remaining $firstspan if {$remaining ne "any"} { @@ -1469,7 +1469,7 @@ tcl::namespace::eval textblock { foreach span [lrange $v 1 end] { if {$remaining eq "any"} { if {$span eq "any"} { - set remaining "any" + set remaining "any" } elseif {$span > 0} { #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { @@ -1479,7 +1479,7 @@ tcl::namespace::eval textblock { set remaining $span incr remaining -1 } else { - #zero following an any - leave remaining as any + #zero following an any - leave remaining as any } } else { if {$span eq "0"} { @@ -1546,7 +1546,7 @@ tcl::namespace::eval textblock { # -- -- -- -- -- -- #also update maxwidthseen & maxheightseen set i 0 - set maxwidthseen 0 + set maxwidthseen 0 #set maxheightseen 0 foreach hdr $thiscol_headers_vertical { lassign [textblock::size $hdr] _w this_header_width _h this_header_height @@ -1567,7 +1567,7 @@ tcl::namespace::eval textblock { } } -colspans { - #sequence has been verified above - we need to split it and store across columns + #sequence has been verified above - we need to split it and store across columns set c 0 ;#column index foreach span $v { set colspans [tcl::dict::get $o_columndefs $c -header_colspans] @@ -1615,7 +1615,7 @@ tcl::namespace::eval textblock { } #set o_headerstate $hidx -minheight? -maxheight? ??? - tcl::dict::set o_headerdefs $hidx $update_hdefs + tcl::dict::set o_headerdefs $hidx $update_hdefs } method add_row {valuelist args} { @@ -1635,14 +1635,14 @@ tcl::namespace::eval textblock { if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { error "add_row - no values supplied, and no columns defined, so cannot use default column values" } - + set defaults [tcl::dict::create\ -minheight 1\ -maxheight ""\ -ansibase ""\ -ansireset "\uFFEF"\ ] - set o_opts_row_defaults $defaults + set o_opts_row_defaults $defaults if {[llength $args] %2 !=0} { error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" @@ -1676,23 +1676,23 @@ tcl::namespace::eval textblock { } } set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure if {[catch { my configure_row $rowcount {*}$opts } errMsg]} { #undo anything we saved before configure_row tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns + #remove auto_columns if {$auto_columns} { set o_columndata [tcl::dict::create] set o_columndefs [tcl::dict::create] set o_columnstate [tcl::dict::create] } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" } - + set c 0 set max_height_seen 1 foreach v $valuelist { @@ -1774,11 +1774,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; + set row_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend row_ansibase_items $code @@ -1954,7 +1954,7 @@ tcl::namespace::eval textblock { } method get_column_by_index {index_expression args} { #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. set opts [tcl::dict::create\ -position "inner"\ -return "string"\ @@ -1992,7 +1992,7 @@ tcl::namespace::eval textblock { set topt_show_header [tcl::dict::get $o_opts_table -show_header] if {$topt_show_header eq ""} { - set allheaders 0 + set allheaders 0 set all_cols [tcl::dict::keys $o_columndefs] foreach c $all_cols { incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] @@ -2015,8 +2015,8 @@ tcl::namespace::eval textblock { set boxlimits "" set joins "" - set header_boxlimits [list] - set header_body_joins [list] + set header_boxlimits [list] + set header_body_joins [list] set ftypes [my Get_frametypes] @@ -2035,9 +2035,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] @@ -2060,9 +2060,9 @@ tcl::namespace::eval textblock { set sep_elements_horizontal $::textblock::class::table_hseps set sep_elements_vertical $::textblock::class::table_vseps - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] set onlymap [tcl::dict::get $fmap only$opt_posn] set hdrmap [tcl::dict::get $hmap only${opt_posn}] @@ -2074,7 +2074,7 @@ tcl::namespace::eval textblock { set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] lassign [my Get_seps] _h show_seps_h _v show_seps_v @@ -2091,7 +2091,7 @@ tcl::namespace::eval textblock { set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] set ansiborder_final $ansibase_header$ansiborder_header$extrabg } else { set ansiborder_final $ansibase_header$ansiborder_header @@ -2099,7 +2099,7 @@ tcl::namespace::eval textblock { set RST [punk::ansi::a] - set hcolwidth $colwidth + set hcolwidth $colwidth #set hcolwidth [my column_width_configured $cidx] set hcell_line_blank [tcl::string::repeat " " $hcolwidth] @@ -2149,7 +2149,7 @@ tcl::namespace::eval textblock { if {$hrow == $hmax} { set header_joins $header_body_joins } else { - set header_joins $joins + set header_joins $joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] @@ -2167,7 +2167,7 @@ tcl::namespace::eval textblock { set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] set spanbelow [lindex $next_spanlist $cidx] if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins + #we don't want a down-join for blc - use a framedef with only left joins tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] } } else { @@ -2181,7 +2181,7 @@ tcl::namespace::eval textblock { #May be better to require user to pre-wrap as needed ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) # -width is always +2 - as the boxlimits take into account show_vseps and show_edge @@ -2219,10 +2219,10 @@ tcl::namespace::eval textblock { #puts ">> remaining_spans: $remaining_spans" set spancol [expr {$cidx + 1}] set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + - set last [expr {[llength $remaining_spans] -1}] set i 0 foreach s $remaining_spans { @@ -2238,9 +2238,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $next_posn $fname_body] set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] @@ -2263,14 +2263,14 @@ tcl::namespace::eval textblock { } } else { #join to body - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype } } if {$hrow == $hmax} { set header_joins $span_joins_body } else { - set header_joins $span_joins + set header_joins $span_joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] @@ -2285,7 +2285,7 @@ tcl::namespace::eval textblock { } else { break } - incr spancol + incr spancol incr i } @@ -2304,7 +2304,7 @@ tcl::namespace::eval textblock { set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] } else { - set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] } } else { @@ -2349,10 +2349,10 @@ tcl::namespace::eval textblock { set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] #POTENTIAL BUG (fixed with spans_to_rhs above) #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) - #we need to shift 1 to the left when doing our overtype with blockalign right + #we need to shift 1 to the left when doing our overtype with blockalign right #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge #(even though the column position may be left or inner) - + } else { @@ -2389,12 +2389,12 @@ tcl::namespace::eval textblock { set h_lines [lrepeat $padheight $bline] set hcell_blank [::join $h_lines \n] set header_frame $hcell_blank - } else { + } else { set bline [tcl::string::repeat $TSUB $padwidth] set h_lines [lrepeat $rowh $bline] set hcell_blank [::join $h_lines \n] # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi + #frame borders will never display - so use the simplest frametype and don't apply any ansi #puts "===>zerospan hlims: $hlims" set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ @@ -2424,13 +2424,13 @@ tcl::namespace::eval textblock { append part_header $header_frame\n } set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] + set adjusted_lines [list] foreach ln [split $part_header \n] { if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline + lappend adjusted_lines $padline } else { lappend adjusted_lines $ln } @@ -2496,7 +2496,7 @@ tcl::namespace::eval textblock { set cell_ansibase "" set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row + set ansiborder_final $ansiborder_body_col_row #$c will always have ansi resets due to overtype behaviour ? #todo - review overtype if {[punk::ansi::ta::detect $c]} { @@ -2514,7 +2514,7 @@ tcl::namespace::eval textblock { #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] #puts --->[ansistring VIEW $codes] - + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { #special case double reset at end of content @@ -2527,7 +2527,7 @@ tcl::namespace::eval textblock { set cell_ansibase $cell_ansi_tail } else { #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase } } else { if {$ftblock} { @@ -2555,7 +2555,7 @@ tcl::namespace::eval textblock { } else { set bmap $topmap if {$do_show_header} { - set blims $blims_top + set blims $blims_top } else { set blims $blims_top_headerless } @@ -2631,7 +2631,7 @@ tcl::namespace::eval textblock { } else { set output $part_body } - return $output + return $output } else { return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] } @@ -2652,15 +2652,15 @@ tcl::namespace::eval textblock { } error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" } - #assert cidx is integer >=0 - set num_header_rows [my header_count] - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] set ansibase_col [tcl::dict::get $cdef -ansibase] set textalign [tcl::dict::get $cdef -textalign] switch -- $textalign { left {set pad right} - right {set pad left} + right {set pad left} default { set pad "centre" ;#todo? } @@ -2684,7 +2684,7 @@ tcl::namespace::eval textblock { # lappend configured_widths [my column_width_configured $c] #} - set output [tcl::dict::create] + set output [tcl::dict::create] tcl::dict::set output headers [list] set showing_vseps [my Showing_vseps] @@ -2720,10 +2720,10 @@ tcl::namespace::eval textblock { set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerrow_colspans $cidx] + set this_span [lindex $headerrow_colspans $cidx] - #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] @@ -2734,7 +2734,7 @@ tcl::namespace::eval textblock { set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top set hval_block [::join $hval_lines \n] set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell + tcl::dict::lappend output headers $hcell } @@ -2758,7 +2758,7 @@ tcl::namespace::eval textblock { set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { set rowh $rowdefminh ;#an exact height is defined for the row } else { if {$rowdefminh eq ""} { @@ -2780,7 +2780,7 @@ tcl::namespace::eval textblock { } } } - + set cell_lines [lrepeat $rowh $cell_line_blank] #set cell_blank [join $cell_lines \n] @@ -2792,7 +2792,7 @@ tcl::namespace::eval textblock { set cval_lines [lrange $cval_lines 0 $rowh-1] set cval_block [::join $cval_lines \n] - #//JMN assert widest cval_line = datawidth = known_blockwidth + #//JMN assert widest cval_line = datawidth = known_blockwidth set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] tcl::dict::lappend output cells $cell @@ -2817,7 +2817,7 @@ tcl::namespace::eval textblock { #[call class::table [method debug]] #[para] display lots of debug information about how the table is constructed. - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) set defaults [tcl::dict::create\ -usetables 1\ ] @@ -2836,7 +2836,7 @@ tcl::namespace::eval textblock { puts stdout "rowstates: $o_rowstates" #puts stdout "columndefs: $o_columndefs" puts stdout "columndefs:" - if {!$opt_usetables} { + if {!$opt_usetables} { tcl::dict::for {k v} $o_columndefs { puts " $k $v" } @@ -2849,7 +2849,7 @@ tcl::namespace::eval textblock { continue } $t add_column -headers $property - } + } break } @@ -2858,15 +2858,15 @@ tcl::namespace::eval textblock { set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths tcl::dict::for {col coldef} $o_columndefs { set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] + set colheaders [tcl::dict::get $coldef -headers] #inner table probably overkill here ..but just as easy set htable [textblock::class::table new] $htable configure -show_header 1 -show_edge 0 -show_hseps 0 $htable add_column -headers row $htable add_column -headers text $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 + $htable add_column -headers span + set hnum 0 set spans [tcl::dict::get $o_columndefs $col -header_colspans] foreach h $colheaders s $spans { lassign [textblock::size $h] _w width _h height @@ -2881,7 +2881,7 @@ tcl::namespace::eval textblock { if {$w > [tcl::dict::get $max_widths $icol]} { tcl::dict::set max_widths $icol $w } - incr icol + incr icol } } @@ -2899,7 +2899,7 @@ tcl::namespace::eval textblock { tcl::dict::for {innercol maxw} $max_widths { $htable configure_column $innercol -minwidth $maxw -blockalign left } - lappend row [$htable print] + lappend row [$htable print] $htable destroy } default { @@ -2923,7 +2923,7 @@ tcl::namespace::eval textblock { tcl::dict::for {k coldef} $o_columndefs { if {[tcl::dict::exists $o_columndata $k]} { set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] + set coldata [tcl::dict::get $o_columndata $k] set colinfo "rowcount: [llength $coldata]" set allfields [concat $headerlist $coldata] if {[llength $allfields]} { @@ -2944,7 +2944,7 @@ tcl::namespace::eval textblock { if {$c == 0} { lappend cols [my get_column_by_index $c -position left] " " } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] + lappend cols [my get_column_by_index $c -position right] } else { lappend cols [my get_column_by_index $c -position inner] " " } @@ -3089,7 +3089,7 @@ tcl::namespace::eval textblock { lappend configured_widths [my column_width_configured $c] } set header_colspans [my header_colspans] - set width_max $colwidth + set width_max $colwidth set test_width $colwidth set showing_vseps [my Showing_vseps] set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] @@ -3125,7 +3125,7 @@ tcl::namespace::eval textblock { if {$showing_vseps} { incr others_width 1 } - } + } set total_spanned_width [expr {$width_max + $others_width}] if {$thiscol_widest_header > $total_spanned_width} { #this just allocates the extra space in the current column - which is not great. @@ -3172,9 +3172,9 @@ tcl::namespace::eval textblock { return true } } - return false + return false } - + method column_datawidth {index_expression args} { set opts [tcl::dict::create\ -headers 0\ @@ -3289,11 +3289,11 @@ tcl::namespace::eval textblock { set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] set widest [expr {max($valwidest,$hwidest)}] } else { - set widest $hwidest + set widest $hwidest } return $widest } - #print1 uses basic column joining - useful for testing/debug especially with colspans + #print1 uses basic column joining - useful for testing/debug especially with colspans method print1 {args} { if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3338,15 +3338,15 @@ tcl::namespace::eval textblock { incr colposn } if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] + return [textblock::join -- {*}$blocks] } else { return "No columns matched" } } method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr set colspace_added [tcl::dict::create] - + set ordered_spans [tcl::dict::create] tcl::dict::for {col spandata} [my spangroups] { set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] @@ -3363,7 +3363,7 @@ tcl::namespace::eval textblock { } } tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 + tcl::dict::set colspace_added $col 0 set spanlengths [tcl::dict::get $spandata spanlengths] foreach slen $spanlengths { @@ -3373,13 +3373,13 @@ tcl::namespace::eval textblock { set hwidth [tcl::dict::get $s headerwidth] set hrow [tcl::dict::get $s hrow] set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth } } } - #safe jumptable test + #safe jumptable test #dict for {spanid spandata} $ordered_spans {} tcl::dict::for {spanid spandata} $ordered_spans { lassign [split $spanid ,] startcol hrow @@ -3390,7 +3390,7 @@ tcl::namespace::eval textblock { if {$num_cols_spanned == 1} { set col [lindex $memcols 0] set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { + if {$space_to_alloc > 0} { set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] if {$maxwidth ne ""} { if {$maxwidth > [tcl::dict::get $colwidths $col]} { @@ -3400,7 +3400,7 @@ tcl::namespace::eval textblock { } set will_alloc [expr {min($space_to_alloc,$can_alloc)}] } else { - set will_alloc $space_to_alloc + set will_alloc $space_to_alloc } if {$will_alloc} { #tcl::dict::set colwidths $col $hwidth @@ -3422,12 +3422,12 @@ tcl::namespace::eval textblock { if {[my Showing_vseps]} { set sepcount [expr {$num_cols_spanned -1}] incr space_to_alloc -$sepcount - } + } #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added switch -- $allocmethod { least { #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3445,10 +3445,10 @@ tcl::namespace::eval textblock { } } least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth #(we should be able to collapse column width to zero and have header colspans gracefully respond) #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3485,7 +3485,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3521,7 +3521,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3533,10 +3533,10 @@ tcl::namespace::eval textblock { } - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] } - #spangroups keyed by column + #spangroups keyed by column method spangroups {} { #*** !doctools #[call class::table [method spangroups]] @@ -3550,8 +3550,8 @@ tcl::namespace::eval textblock { tcl::dict::set spangroups $c [list spanlengths {}] set spanlist [my column_get_spaninfo $c] set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist while {[llength $ungrouped]} { set spanlen [lindex $ungrouped 0 $index_spanlen_val] @@ -3569,14 +3569,14 @@ tcl::namespace::eval textblock { tcl::dict::set headerwidths $hcol,$hrow $hwidth } lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo + lappend sgroup $spaninfo } set spanlengths [tcl::dict::get $spangroups $c spanlengths] lappend spanlengths $spanlen tcl::dict::set spangroups $c spanlengths $spanlengths tcl::dict::set spangroups $c spangroups $spanlen $sgroup set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } + } } return $spangroups } @@ -3660,14 +3660,14 @@ tcl::namespace::eval textblock { basic { #basic column by column - This allocates extra space to first span/column as they're encountered. #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. + #The header values can extend over some of the spanned columns - but not optimally so. set o_calculated_column_widths [list] for {set c 0} {$c < $column_count} {incr c} { lappend o_calculated_column_widths [my basic_column_width $c] } } simplistic { - #just uses the widest column data or header element. + #just uses the widest column data or header element. #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column #This is a conservative option potentially useful in testing/debugging. set o_calculated_column_widths [list] @@ -3676,7 +3676,7 @@ tcl::namespace::eval textblock { } } span { - #widest of smallest spans first method + #widest of smallest spans first method #set calcresult [my columncalc_spans least] set calcresult [my columncalc_spans least_unmaxed] set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] @@ -3695,7 +3695,7 @@ tcl::namespace::eval textblock { return $o_calculated_column_widths } method print2 {args} { - variable full_column_cache + variable full_column_cache set full_column_cache [tcl::dict::create] if {![llength $args]} { @@ -3749,10 +3749,10 @@ tcl::namespace::eval textblock { tcl::dict::set full_column_cache $c $columninfo } set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] @@ -3762,12 +3762,12 @@ tcl::namespace::eval textblock { #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3787,7 +3787,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3839,7 +3839,7 @@ tcl::namespace::eval textblock { } set blocks [list] set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set table "" foreach c $cols { @@ -3855,20 +3855,20 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3888,7 +3888,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3916,7 +3916,7 @@ tcl::namespace::eval textblock { method print {args} { #*** !doctools #[call class::table [method print]] - #[para] Return the table as text suitable for console display + #[para] Return the table as text suitable for console display if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3944,7 +3944,7 @@ tcl::namespace::eval textblock { } } set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set header_build "" set body_blocks [list] @@ -3962,7 +3962,7 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] set headerheight [tcl::dict::get $columninfo headerheight] #set nextcol_lines [split $nextcol \n] #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] @@ -3971,7 +3971,7 @@ tcl::namespace::eval textblock { set nextcol_body [tcl::dict::get $columninfo body] if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header + set header_build $nextcol_header } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] @@ -3979,7 +3979,7 @@ tcl::namespace::eval textblock { #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } lappend body_blocks $nextcol_body - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {![llength $body_blocks]} { @@ -4014,7 +4014,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -4039,11 +4039,11 @@ tcl::namespace::eval textblock { method print_bodymatrix {} { #*** !doctools #[call class::table [method print_bodymatrix]] - #[para] output the matrix string corresponding to the body data using the matrix 2string format + #[para] output the matrix string corresponding to the body data using the matrix 2string format #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. # - + set m [my as_matrix] $m format 2string @@ -4098,7 +4098,7 @@ tcl::namespace::eval textblock { return $t } - #more complex colspans + #more complex colspans proc spantest2 {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} @@ -4137,7 +4137,7 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - @values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { @@ -4163,7 +4163,7 @@ tcl::namespace::eval textblock { " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] + ] set type_colours [list] @@ -4173,71 +4173,71 @@ tcl::namespace::eval textblock { set ansi [a+ {*}$fc web-black Web-gold] set val [list ansi $ansi cat alkaline_earth] foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val + tcl::dict::set ecat $e $val } set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val } set cat [list Li Na K Rb Cs Fr] - #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val } - set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] + set ansi [a+ {*}$fc web-black Web-lightskyblue] set val [list ansi $ansi cat post_transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list B Si Ge As Sb Te At] - #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] + set ansi [a+ {*}$fc web-black Web-orchid] set val [list ansi $ansi cat noble_gases] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] + set ansi [a+ {*}$fc web-black Web-plum] set val [list ansi $ansi cat actinoids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - #set ansi [a+ {*}$fc web-black Web-tan] - set ansi [a+ {*}$fc black Term-tan] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] set val [list ansi $ansi cat lanthanoids] foreach e $cat { tcl::dict::set ecat $e $val } - set ansi [a+ {*}$fc web-black Web-whitesmoke] + set ansi [a+ {*}$fc web-black Web-whitesmoke] set val [list ansi $ansi cat other] foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { tcl::dict::set ecat $e $val @@ -4264,7 +4264,7 @@ tcl::namespace::eval textblock { set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] set c 0 foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 + $t configure_column $c -headers [list $h] -minwidth 2 incr c } set ccount [$t column_count] @@ -4279,7 +4279,7 @@ tcl::namespace::eval textblock { } dict for {k v} $conf { if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] + dict set conf $k [dict get $opts $k] } } @@ -4310,14 +4310,14 @@ tcl::namespace::eval textblock { } proc bookend_lines {block start {end "\x1b\[m"}} { - set out "" + set out "" foreach ln [split $block \n] { append out $start $ln $end \n } return [string range $out 0 end-1] } proc ansibase_lines {block {newprefix ""}} { - set base "" + set base "" set out "" if {$newprefix eq ""} { if {![punk::ansi::ta::detect $block]} { @@ -4340,7 +4340,7 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + set parts [linsert $parts $code_idx+1 $base] } incr code_idx 2 } @@ -4373,7 +4373,7 @@ tcl::namespace::eval textblock { incr offset } incr code_idx 2 - } + } append out {*}$parts \n } return [string range $out 0 end-1] @@ -4398,29 +4398,29 @@ tcl::namespace::eval textblock { Will not be visible if -show_edge is false" -titlealign -type string -choices {left centre right} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ - -help "frame type or dict for custom frame" + -help "frame type or dict for custom frame" -show_edge -default "" -type boolean\ -help "show outer border of table" - -show_seps -default "" -type boolean + -show_seps -default "" -type boolean -show_vseps -default "" -type boolean\ - -help "Show vertical table separators" + -help "Show vertical table separators" -show_hseps -default "" -type boolean\ -help "Show horizontal table separators (default 0 if no existing -table supplied)" -colheaders -default "" -type list\ -help {list of lists. list of column header values. Outer list must match number of columns. - A table + A table e.g single header row: -colheaders {{column_a} {column_b} {column_c}} e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}} Note that each element of the outer list is itself a list so: - -colheaders {"column a" "column b" "column c"} + -colheaders {"column a" "column b" "column c"} Is likely not the right format if it was intended to have a single header row where the column titles contain spaces. The correct syntax for that would be: - -colheaders {{"column a"} {"column b"} {"column c"}} + -colheaders {{"column a"} {"column b"} {"column c"}} For spanning header cells - use 'set t [list_as_table -return tableobject ...]' and then something like: - $t configure_header 1 -colspans {3 0 0}; $t print + $t configure_header 1 -colspans {3 0 0}; $t print } -header -default "" -type list -multiple 1\ -help "Each supplied -header argument is a header row. @@ -4498,14 +4498,14 @@ tcl::namespace::eval textblock { if {[llength $colheaders] < $c+1} { lappend colheaders [lrepeat $r {}] } - set colinfo [lindex $colheaders $c] + set colinfo [lindex $colheaders $c] if {$r > [llength $colinfo]} { set diff [expr {$r - [llength $colinfo]}] lappend colinfo {*}[lrepeat $diff {}] } lappend colinfo $cell lset colheaders $c $colinfo - incr c + incr c } incr r } @@ -4516,15 +4516,15 @@ tcl::namespace::eval textblock { if {![tcl::dict::exists $opts received -show_header]} { set show_header 1 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } } else { if {![tcl::dict::exists $opts received -show_header]} { set show_header 0 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } - } + } if {[tcl::string::is integer -strict $opt_columns]} { set cols $opt_columns @@ -4536,7 +4536,7 @@ tcl::namespace::eval textblock { if {[llength $colheaders]} { set cols [llength $colheaders] } else { - set cols 2 ;#seems a reasonable default + set cols 2 ;#seems a reasonable default } } #defaults for new table only @@ -4605,13 +4605,13 @@ tcl::namespace::eval textblock { if {"-titlealign" in $received} { $t configure -titlealign [dict get $opts -titlealign] } - #puts stdout $rowdata + #puts stdout $rowdata if {[tcl::dict::get $opts -return] eq "table"} { set result [$t print] if {$is_new_table} { $t destroy } - return $result + return $result } else { return $t } @@ -4627,13 +4627,13 @@ tcl::namespace::eval textblock { error "textblock::block blockheight must be a positive integer" } if {$char eq ""} {return ""} - #using tcl::string::length is ok + #using tcl::string::length is ok if {[tcl::string::length $char] == 1} { set row [tcl::string::repeat $char $blockwidth] set mtrx [lrepeat $blockheight $row] return [::join $mtrx \n] } else { - set charblock [tcl::string::map [list \r\n \n] $char] + set charblock [tcl::string::map [list \r\n \n] $char] if {[tcl::string::last \n $charblock] >= 0} { if {$blockwidth > 1} { #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) @@ -4657,7 +4657,7 @@ tcl::namespace::eval textblock { columns wide and size rows tall. (which on a terminal will show as a vertically oriented rectangle due to - cells being taller than their width) + cells being taller than their width) The characters used are 123456789ABCDEF @@ -4681,7 +4681,7 @@ tcl::namespace::eval textblock { The additional pseudo-color 'rainbow' is available. - " + " } proc testblock {args} { @@ -4700,14 +4700,14 @@ tcl::namespace::eval textblock { lappend rainbow_list {37 40} ;#white Black lappend rainbow_list {black Yellow} lappend rainbow_list red - lappend rainbow_list green + lappend rainbow_list green lappend rainbow_list yellow lappend rainbow_list blue lappend rainbow_list purple - lappend rainbow_list cyan + lappend rainbow_list cyan lappend rainbow_list {white Red} - #set rainbow_direction "horizontal" + #set rainbow_direction "horizontal" #set vpos [lsearch $colour vertical] #if {$vpos >= 0} { # set rainbow_direction vertical @@ -4719,11 +4719,11 @@ tcl::namespace::eval textblock { # set colour [lremove $colour $hpos] #} set direction [dict get $argd opts -direction] - + set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + set charsubset [lrange $chars 0 $size-1] if {"noreset" in $colour} { set RST "" } else { @@ -4737,7 +4737,7 @@ tcl::namespace::eval textblock { for {set i 0} {$i <$size} {incr i} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] set ansi [a+ {*}$colour2] - + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } @@ -4748,7 +4748,7 @@ tcl::namespace::eval textblock { } } elseif {"rainbow" in $colour} { #direction must be horizontal - set block "" + set block "" for {set r 0} {$r < $size} {incr r} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] set ansi [a+ {*}$colour2] @@ -4763,7 +4763,7 @@ tcl::namespace::eval textblock { set block [tcl::string::trimright $block \n] return $block } else { - #row first - + #row first - set rows [list] foreach ch $charsubset { lappend rows [tcl::string::repeat $ch $size] @@ -4790,7 +4790,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4799,8 +4799,8 @@ tcl::namespace::eval textblock { if {[tcl::string::last \n $textblock] >= 0} { return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } - return [punk::char::ansifreestring_width $textblock] - } + return [punk::char::ansifreestring_width $textblock] + } #gather info about whether ragged (samewidth each line = false) and min width proc widthinfo {textblock} { #backspaces, vertical tabs ? @@ -4814,7 +4814,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4843,7 +4843,7 @@ tcl::namespace::eval textblock { if {[punk::ansi::ta::detect $tl]} { set tl [punk::ansi::ansistripraw $tl] } - return [punk::char::ansifreestring_width $tl] + return [punk::char::ansifreestring_width $tl] } #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. proc string_length_line_max {textblock} { @@ -4864,7 +4864,7 @@ tcl::namespace::eval textblock { proc height {textblock} { #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) + #empty string still has height 1 (at least for left-right/right-left languages) #vertical tab on a proper terminal should move directly down. #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) @@ -4894,7 +4894,7 @@ tcl::namespace::eval textblock { #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } else { - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -4933,7 +4933,7 @@ tcl::namespace::eval textblock { } } else { set num_le 0 - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -5010,14 +5010,14 @@ tcl::namespace::eval textblock { # -- --- --- --- --- --- --- --- --- --- set padchar [tcl::dict::get $opts -padchar] #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map #The caller may also use ansi within the padchar - although it's unlikely to be efficient. # -- --- --- --- --- --- --- --- --- --- set known_whiches [list l left r right c center centre] set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] switch -- $opt_which { center - centre - c { - set which c + set which c } left - l { set which l @@ -5055,7 +5055,7 @@ tcl::namespace::eval textblock { set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. set datawidth "" if {$width eq "auto"} { - #for auto - we + #for auto - we if {$known_blockwidth eq ""} { if {$known_samewidth ne "" && $known_samewidth} { set datawidth [textblock::widthtopline $block] @@ -5077,7 +5077,7 @@ tcl::namespace::eval textblock { set datawidth [textblock::widthtopline $block] } else { set datawidth $known_blockwidth - } + } } #assert datawidth may still be empty string } @@ -5096,7 +5096,7 @@ tcl::namespace::eval textblock { #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) #we should use overtype with suitable replacement char (space?) for chopped double-wides if {!$pad_has_ansi} { - return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] } else { set base [tcl::string::repeat " " $width] return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] @@ -5105,7 +5105,7 @@ tcl::namespace::eval textblock { #review - tcl format can only pad with zeros or spaces? #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - #review - surprisingly, this doesn't seem to be a performance win + #review - surprisingly, this doesn't seem to be a performance win #No detectable diff on small blocks - slightly worse on large blocks # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position @@ -5144,7 +5144,7 @@ tcl::namespace::eval textblock { set parts [list $block] } - set line_chunks [list] + set line_chunks [list] set line_len 0 set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad foreach {pt ansi} $parts { @@ -5179,7 +5179,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5237,7 +5237,7 @@ tcl::namespace::eval textblock { } #don't let trailing empty ansi affect the line_chunks length if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? } } #pad last line @@ -5251,7 +5251,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5321,7 +5321,7 @@ tcl::namespace::eval textblock { if {$i == $i_last_code} { return [lappend out $str {*}[lrange $ansisplits $i end]] } - #code being empty can only occur when we have reached last pt + #code being empty can only occur when we have reached last pt #we have returned by then. lappend out $code incr i 2 @@ -5338,7 +5338,7 @@ tcl::namespace::eval textblock { set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] + set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] set t [textblock::list_as_table -columns 3 -return tableobject $testlist] $t configure_column 0 -headers [list "ansi"] @@ -5397,20 +5397,20 @@ tcl::namespace::eval textblock { set r3 [list "column\ncolours"] #1 - #test without table padding + #test without table padding #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering #(basically a mechanism to add extra resets at start and end of each line) #dict for {b bdict} $blockinfo { # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] #} #2 - the more useful one? tcl::dict::for {b bdict} $blockinfo { lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] lappend r3 "" "" } @@ -5486,7 +5486,7 @@ tcl::namespace::eval textblock { # >} .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| # >} punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines } punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } + } proc example {args} { @@ -5930,7 +5930,7 @@ tcl::namespace::eval textblock { set RST [a] set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST + set pleft_greenb $greenb$pleft$RST set pright_redb $redb$pright$RST set prightair_cyanb $cyanb$prightair$RST set cpunks [textblock::join -- $pleft_greenb $pright_redb] @@ -6064,7 +6064,7 @@ tcl::namespace::eval textblock { } } } - } + } variable framedef_cache [tcl::dict::create] proc framedef {args} { #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. @@ -6072,7 +6072,7 @@ tcl::namespace::eval textblock { #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. #the arc set can't even join to itself e.g with curved equivalents of T-like shapes - #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. variable framedef_cache set cache_key $args if {[tcl::dict::exists $framedef_cache $cache_key]} { @@ -6115,10 +6115,10 @@ tcl::namespace::eval textblock { if {![llength $rawglobs] || "all" in $rawglobs || "*" in $rawglobs} { set globs * } else { - set globs [list] + set globs [list] foreach g $rawglobs { switch -- $g { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - hltj - hlbj - vllj - vlrj { lappend globs $g } @@ -6150,7 +6150,7 @@ tcl::namespace::eval textblock { } default { #must look like a glob search if not one of the above - if {[regexp {[*?\[\]]} $g]} { + if {[regexp {[*?\[\]]} $g]} { lappend globs $g } else { set bad_option 1 @@ -6174,7 +6174,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - @values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -6191,7 +6191,7 @@ tcl::namespace::eval textblock { set joins [tcl::dict::get $opts -joins] set boxonly [tcl::dict::get $opts -boxonly] - + #sorted order down left right up #1 x choose 4 #4 x choose 3 @@ -6204,7 +6204,7 @@ tcl::namespace::eval textblock { #e.g down-light, up-heavy set join_targets [tcl::dict::create left "" down "" right "" up ""] foreach jt $joins { - lassign [split $jt -] direction target + lassign [split $jt -] direction target if {$target ne ""} { tcl::dict::set join_targets $direction $target } @@ -6234,7 +6234,7 @@ tcl::namespace::eval textblock { #set brc [cd::brc] set brc [punk::ansi::g0 j] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6382,7 +6382,7 @@ tcl::namespace::eval textblock { set trc + set blc + set brc + - #horizontal and vertical bar joins + #horizontal and vertical bar joins #set hltj $hlt #set hlbj $hlb #set vllj $vll @@ -6392,7 +6392,7 @@ tcl::namespace::eval textblock { set hlbj + set vllj + set vlrj + - #our corners are all + already - so we won't do anything for directions or targets + #our corners are all + already - so we won't do anything for directions or targets } "light" { @@ -6408,7 +6408,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_lur] set brc [punk::char::charshort boxd_lul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6423,16 +6423,16 @@ tcl::namespace::eval textblock { #default empty targets to current box type 'light' foreach dir {down left right up} { set rawtarget [tcl::dict::get $join_targets $dir] - lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same + lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same switch -- $target { "" - light { - set target$dir light + set target$dir light } ascii - altg - arc { - set target$dir light + set target$dir light } heavy { - set target$dir $target + set target$dir $target } default { set target$dir other @@ -6504,7 +6504,7 @@ tcl::namespace::eval textblock { other-light { set blc \u2534 ;#(btj) set tlc \u252c ;#(ttj) - #brc - default corner + #brc - default corner set vllj \u2524 ;# (rtj) } other-other { @@ -6546,7 +6546,7 @@ tcl::namespace::eval textblock { light-other { set blc \u251c ;# (ltj) #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) + set brc \u2524 ;# boxd_lvl (rtj) set hlbj \u252c ;# (ttj) } light-heavy { @@ -6682,41 +6682,41 @@ tcl::namespace::eval textblock { light_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } light_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] tcl::dict::with arcframe {} ;#extract keys as vars } "heavy" { @@ -6731,7 +6731,7 @@ tcl::namespace::eval textblock { set trc [punk::char::charshort boxd_hdl] set blc [punk::char::charshort boxd_hur] set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6743,10 +6743,10 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - heavy { - set target$dir heavy + set target$dir heavy } light - ascii - altg - arc { - set target$dir light + set target$dir light } default { set target$dir other @@ -6773,12 +6773,12 @@ tcl::namespace::eval textblock { #2 switch -- $targetleft { light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) set vllj \u2528 ;# left light (rtj) } heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set blc [punk::char::charshort boxd_huhz] ;# (btj) set vllj \u252b ;#(rtj) } @@ -6833,7 +6833,7 @@ tcl::namespace::eval textblock { set vllj \u2528 ;# left light (rtj) } down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) set hlbj \u252F ;# down light (ttj) @@ -6954,41 +6954,41 @@ tcl::namespace::eval textblock { heavy_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } heavy_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] tcl::dict::with arcframe {} ;#extract keys as vars } "double" { @@ -7004,7 +7004,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7163,7 +7163,7 @@ tcl::namespace::eval textblock { } left_right { #8 - + #from 2 #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set tlc \U2566 ;# (ttj) @@ -7254,7 +7254,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7266,7 +7266,7 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - arc { - set target$dir self + set target$dir self } default { set target$dir other @@ -7282,7 +7282,7 @@ tcl::namespace::eval textblock { set blc \u251c ;# *light (ltj) #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal #set brc \u2524 ;# *light(rtj) #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) @@ -7354,41 +7354,41 @@ tcl::namespace::eval textblock { arc_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } arc_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] tcl::dict::with arcframe {} ;#extract keys as vars } block1 { @@ -7402,7 +7402,7 @@ tcl::namespace::eval textblock { set blc \u2594 ;# upper one eighth block set brc \u2594 ;# upper one eight block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7410,7 +7410,7 @@ tcl::namespace::eval textblock { } block2 { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7425,7 +7425,7 @@ tcl::namespace::eval textblock { set trc \U1fb7e ;#legacy block set blc \U1fb7c ;#legacy block set brc \U1fb7f ;#legacy block - + if {(![interp issafe])} { if {![catch {punk::console::check::has_bug_legacysymbolwidth} symbug] && $symbug} { #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems @@ -7437,7 +7437,7 @@ tcl::namespace::eval textblock { } } - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7445,7 +7445,7 @@ tcl::namespace::eval textblock { } block2hack { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7466,7 +7466,7 @@ tcl::namespace::eval textblock { # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs + #except that the punk overtype library does recognise PMs #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block @@ -7474,7 +7474,7 @@ tcl::namespace::eval textblock { set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7491,7 +7491,7 @@ tcl::namespace::eval textblock { set blc \u2599 set brc \u259f - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7526,9 +7526,9 @@ tcl::namespace::eval textblock { set $t [tcl::dict::get $custom_frame $t] } else { #set more explicit type to it's more general counterpart if it's missing - #e.g hlt -> hl - #e.g hltj -> hlt - set $t [set [string range $t 0 end-1]] + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] } } #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set @@ -7671,14 +7671,14 @@ tcl::namespace::eval textblock { tcl::dict::for {k v} $display_dict { lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? #set fwidth [textblock::width $frame] set frameinfo "$k used:$used " set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] if {$allinone_width >= $termwidth} { #split across 2 lines - append out "$frameinfo\n" + append out "$frameinfo\n" append out $frame \n } else { append out [textblock::join -- $frameinfo $frame]\n @@ -7707,7 +7707,7 @@ tcl::namespace::eval textblock { set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] return $FRAMETYPELABELS } - #proc EG {} "return {[a+ brightblack]}" + #proc EG {} "return {[a+ brightblack]}" #make EG fetch from SGR cache so as to abide by colour off/on proc EG {} { a+ brightblack @@ -7729,7 +7729,7 @@ tcl::namespace::eval textblock { -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and provide more comprehensive error info. - Set false for slight performance improvement." + Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ @@ -7741,10 +7741,10 @@ tcl::namespace::eval textblock { passing an empty string will result in no box, but title/subtitle will still appear if supplied. ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict - -joins -default {} -type list + -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. - May contain ANSI - no trailing reset required. + May contain ANSI - no trailing reset required. ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" -titlealign -default "centre" -choices {left centre right} @@ -7778,7 +7778,7 @@ tcl::namespace::eval textblock { -help "Show ANSI control characters within frame contents. (Control Representation Mode) Frame width doesn't adapt and content may be truncated - so -width may need to be manually set to display more." + so -width may need to be manually set to display more." @values -min 0 -max 1 contents -default "" -type string\ @@ -7793,7 +7793,7 @@ tcl::namespace::eval textblock { # #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it # - but we would need to maintain support for the rendered-string based operations too. proc frame {args} { @@ -7828,8 +7828,8 @@ tcl::namespace::eval textblock { # for ansi art - -pad 0 is likely to be preferable set has_contents 0 - set optlist $args ;#initial only - content will be removed - #no solo opts for frame + set optlist $args ;#initial only - content will be removed + #no solo opts for frame if {[llength $args] %2 == 0} { if {[lindex $args end-1] eq "--"} { set contents [lpop optlist end] @@ -7843,7 +7843,7 @@ tcl::namespace::eval textblock { set contents [lpop optlist end] set has_contents 1 } - + #todo args -justify left|centre|right (center) #todo -blockalignbias -textalignbias? #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache @@ -7852,12 +7852,12 @@ tcl::namespace::eval textblock { foreach {k v} $optlist { set k2 [tcl::prefix::match -error "" $optnames $k] switch -- $k2 { - -etabs - -type - -boxlimits - -boxmap - -joins + -etabs - -type - -boxlimits - -boxmap - -join - -title - -titlealign - -subtitle - -subtitlealign - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -crm_mode - - -usecache - -buildcache - -pad + - -usecache - -buildcache - -pad - -checkargs { tcl::dict::set opts $k2 $v } @@ -7878,21 +7878,21 @@ tcl::namespace::eval textblock { set contents [dict get $argd values contents] } - # -- --- --- --- --- --- + # -- --- --- --- --- --- # cache relevant set opt_usecache [tcl::dict::get $opts -usecache] set opt_buildcache [tcl::dict::get $opts -buildcache] set usecache $opt_usecache ;#may need to override set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination set opt_crm_mode [tcl::dict::get $opts -crm_mode] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_type [tcl::dict::get $opts -type] set opt_boxlimits [tcl::dict::get $opts -boxlimits] set opt_joins [tcl::dict::get $opts -joins] set opt_boxmap [tcl::dict::get $opts -boxmap] set buildcache $opt_buildcache set opt_pad [tcl::dict::get $opts -pad] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_title [tcl::dict::get $opts -title] set opt_subtitle [tcl::dict::get $opts -subtitle] set opt_width [tcl::dict::get $opts -width] @@ -7930,7 +7930,7 @@ tcl::namespace::eval textblock { ##e.g down-light, up-heavy #set join_targets [tcl::dict::create left "" down "" right "" up ""] #foreach jt $opt_joins { - # lassign [split $jt -] direction target + # lassign [split $jt -] direction target # if {$target ne ""} { # tcl::dict::set join_targets $direction $target # } @@ -8056,10 +8056,10 @@ tcl::namespace::eval textblock { set FSUB \uF2DD - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see + #set buildcache 0 ;#comment out for debug/analysis so we can see #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" set cache_key [a+ Web-red web-white]$cache_key[a] } @@ -8069,7 +8069,7 @@ tcl::namespace::eval textblock { #we can still substitute with right length set cache_key [a+ Web-steelblue web-black]$cache_key[a] } else { - #actual_contentwidth is narrower than frame - check template's patternwidth + #actual_contentwidth is narrower than frame - check template's patternwidth if {[tcl::dict::exists $frame_cache $cache_key]} { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] } else { @@ -8096,7 +8096,7 @@ tcl::namespace::eval textblock { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] set template [tcl::dict::get $frame_cache $cache_key frame] set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record set is_cached 1 } @@ -8107,7 +8107,7 @@ tcl::namespace::eval textblock { # -- --- --- --- --- set is_joins_ok 1 foreach v $opt_joins { - lassign [split $v -] direction target + lassign [split $v -] direction target switch -- $direction { left - right - up - down {} default { @@ -8126,7 +8126,7 @@ tcl::namespace::eval textblock { if {!$is_joins_ok} { error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set is_boxmap_ok 1 tcl::dict::for {boxelement subst} $opt_boxmap { switch -- $boxelement { @@ -8139,9 +8139,9 @@ tcl::namespace::eval textblock { } } if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" + error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #these are all valid commands for overtype:: switch -- $opt_textalign { left - right - centre - center {} @@ -8149,7 +8149,7 @@ tcl::namespace::eval textblock { error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" } } - # -- --- --- --- --- --- + # -- --- --- --- --- --- switch -- $opt_blockalign { left - right - centre - center {} default { @@ -8217,7 +8217,7 @@ tcl::namespace::eval textblock { switch -- $frameset { custom { #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely set vll_width [punk::ansi::printing_length $vll] set hlb_width [punk::ansi::printing_length $hlb] @@ -8235,8 +8235,8 @@ tcl::namespace::eval textblock { if {$opt_width eq ""} { #width wasn't specified - so user is expecting frame to adapt to title/contents #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] } else { @@ -8281,14 +8281,14 @@ tcl::namespace::eval textblock { set tbar [tcl::string::repeat $hlt $frame_inner_width] #set tbar [cd::groptim $tbar] set tbar [punk::ansi::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] + set bbar [tcl::string::repeat $hlb $frame_inner_width] #set bbar [cd::groptim $bbar] set bbar [punk::ansi::groptim $bbar] } default { set tbar [tcl::string::repeat $hlt $frame_inner_width] set bbar [tcl::string::repeat $hlb $frame_inner_width] - + } } @@ -8467,7 +8467,7 @@ tcl::namespace::eval textblock { #after overtype::block - our actual patternwidth may be less set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - if {$leftborder && $rightborder} { + if {$leftborder && $rightborder} { #set bodyparts [list $lhs $inner $rhs] set cache_bodyparts [list $lhs $cache_inner $rhs] } else { @@ -8522,12 +8522,12 @@ tcl::namespace::eval textblock { } set template $fscached ;#end !$is_cached - } + } - #use the same mechanism to build the final frame - whether from cache or template + #use the same mechanism to build the final frame - whether from cache or template if {$actual_contentwidth == 0} { set fs [tcl::string::map [list $FSUB " "] $template] } else { @@ -8549,7 +8549,7 @@ tcl::namespace::eval textblock { #set cwidth [textblock::width $contents] set cwidth $actual_contentwidth if {$opt_pad} { - set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) set paddedwidth [textblock::widthtopline $paddedcontents] #review - horizontal truncation if {$paddedwidth > $cache_patternwidth} { @@ -8590,7 +8590,7 @@ tcl::namespace::eval textblock { if {$is_cached} { - return $fs + return $fs } else { if {$buildcache} { tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] @@ -8621,9 +8621,9 @@ tcl::namespace::eval textblock { set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size + set fit_size $size if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size + set max_cross_size $fit_size } else { #todo - only allow divisors #set testsize [expr {min($fit_size,$opt_max_cross_size)}] @@ -8651,7 +8651,7 @@ tcl::namespace::eval textblock { set onecross "" set crossrows [list] set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] + set row [lrepeat $max_cross_size " "] #toparm for {set i 0} {$i < $armsize} {incr i} { set r $row @@ -8692,7 +8692,7 @@ tcl::namespace::eval textblock { return $out } - #Test we can join two coloured blocks + #Test we can join two coloured blocks proc test_colour {} { set b1 [a red]1\n2\n3[a] set b2 [a green]a\nb\nc[a] @@ -8716,10 +8716,10 @@ interp alias {} piper_blockjoin {} ::textblock::piper::join # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide textblock [tcl::namespace::eval textblock { variable version - set version 0.1.3 + set version 0.1.3 }] return diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.12.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.12.tm index 080e7da9..1983211c 100644 Binary files a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.12.tm and b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zipper-0.12.tm differ 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 3d1d87e9..5b45b2bc 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 @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] #[copyright "2024"] #[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::aliascore] #[keywords module alias] #[description] @@ -98,7 +98,7 @@ package require Tcl 8.6- # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::aliascore { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable aliases #use absolute ns ie must be prefixed with :: #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased @@ -136,7 +136,7 @@ tcl::namespace::eval punk::aliascore { #*** !doctools #[subsection {Namespace punk::aliascore}] - #[para] Core API functions for punk::aliascore + #[para] Core API functions for punk::aliascore #[list_begin definitions] @@ -144,13 +144,13 @@ tcl::namespace::eval punk::aliascore { #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" #} #todo - options as to whether we should raise an error if collisions found, undo aliases etc? @@ -208,13 +208,13 @@ tcl::namespace::eval punk::aliascore { #todo - ensure exported? noclobber? if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { #puts stderr "importing $cmd" - tcl::namespace::eval :: [list namespace import $cmd] + tcl::namespace::eval :: [list namespace import $cmd] } else { #target command name differs from exported name #e.g stripansi -> punk::ansi::ansistrip #import and rename #puts stderr "importing $cmd (with rename to ::$a)" - tcl::namespace::eval $tempns [list namespace import $cmd] + tcl::namespace::eval $tempns [list namespace import $cmd] catch {rename ${tempns}::[namespace tail $cmd] ::$a} } } else { @@ -242,18 +242,18 @@ tcl::namespace::eval punk::aliascore { # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::aliascore::lib { - namespace export {[a-z]*} ;# Convention: export all lowercase + namespace export {[a-z]*} ;# Convention: export all lowercase namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::aliascore::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 + # #[para]Description of utility1 + # return 1 #} @@ -271,17 +271,17 @@ namespace eval punk::aliascore::lib { namespace eval punk::aliascore::system { #*** !doctools #[subsection {Namespace punk::aliascore::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::aliascore [namespace eval punk::aliascore { variable pkg punk::aliascore 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/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 b367be2a..50ea5082 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 @@ -19,21 +19,21 @@ #[manpage_begin punkshell_module_punk::ansi 0 0.1.1] #[copyright "2023"] #[titledesc {Ansi string functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] +#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] #[require punk::ansi] #[keywords module ansi terminal console string] #[description] -#[para]Ansi based terminal control string functions -#[para]See [package punk::ansi::console] for related functions for controlling a console +#[para]Ansi based terminal control string functions +#[para]See [package punk::ansi::console] for related functions for controlling a console # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Overview] -#[para] overview of punk::ansi +#[para] overview of punk::ansi #[para]punk::ansi functions return their values - no implicit emission to console/stdout #[subsection Concepts] -#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner +#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner #[para]There are many differences in terminal implementations - but most should support a core set of features #[para]punk::ansi does not contain any code for direct terminal manipulation via the local system APIs. #[para]Sticking to ansi codes where possible may be better for cross-platform and remote operation where such APIs are unlikely to be useable. @@ -45,7 +45,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::ansi +#[para] packages used by punk::ansi #[list_begin itemized] package require Tcl 8.6- @@ -72,7 +72,7 @@ tcl::namespace::eval punk::ansi::class { if {![llength [tcl::info::commands class_ansi]]} { oo::class create class_ansi { - variable o_ansistringobj + variable o_ansistringobj variable o_render_dimensions ;#last dimensions at which we rendered variable o_rendered @@ -83,7 +83,7 @@ tcl::namespace::eval punk::ansi::class { } #a straight string compare may be faster.. but a checksum is much smaller in memory, so we'll use that by default. - set o_rendered_what "" + set o_rendered_what "" #There may also be advantages to renering to a class_ansistring class object set o_render_dimensions $dimensions @@ -100,7 +100,7 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set cksum "not-done" - if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { + if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { #some ansi layout/art relies on wrapping at the width-dimension to display properly #this includes cursor movements ie right arrow can move cursor to columns in lines below #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. @@ -111,7 +111,7 @@ tcl::namespace::eval punk::ansi::class { #if dimensions changed - the checksum won't have been done set o_rendered_what [$o_ansistringobj checksum] } else { - set o_rendered_what $cksum + set o_rendered_what $cksum } set o_render_dimensions $dimensions } @@ -127,8 +127,8 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set o_dimensions $dimensions - - + + set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } @@ -185,12 +185,12 @@ tcl::namespace::eval punk::ansi::class { set lfvis [ansistring VIEW -lf 1 \n] set maplf [list \n "[a+ green bold reverse]${lfvis}[a]\n"] ;#a mapping to highlight newlines - set lines [split [$o_ansistringobj get] \n] + set lines [split [$o_ansistringobj get] \n] set rlines [lrange $lines 0 $x] - set chunk [::join $rlines \n] + set chunk [::join $rlines \n] append chunk \n if {$opt_minus ne "0"} { - set chunk [tcl::string::range $chunk 0 end-$opt_minus] + 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 marker "" @@ -212,7 +212,7 @@ tcl::namespace::eval punk::ansi::class { 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 + #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 renderheight [llength [split $rendered \n]] set chunkdisplay_lines [split $chunkdisplay \n] @@ -221,7 +221,7 @@ tcl::namespace::eval punk::ansi::class { #the input chunk lines are often much longer than the output.. resulting in main content being way up the screen. It's often impractical to view more than the tail of the chunkdisplay. textblock::join -- $rendered $chunkdisplay_block } - + method checksum {} { return [$o_ansistringobj checksum] } @@ -237,7 +237,7 @@ tcl::namespace::eval punk::ansi::class { -lf 0\ -vt 0\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -267,7 +267,7 @@ tcl::namespace::eval punk::ansi::class { method viewchars {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -295,7 +295,7 @@ tcl::namespace::eval punk::ansi::class { method viewstyle {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -338,20 +338,20 @@ tcl::namespace::eval punk::ansi::class { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ansi { - variable PUNKARGS + variable PUNKARGS #*** !doctools #[subsection {Namespace punk::ansi}] - #[para] Core API functions for punk::ansi + #[para] Core API functions for punk::ansi #[list_begin definitions] - #old-school ansi graphics - C0 control glyphs. - variable cp437_map + #old-school ansi graphics - C0 control glyphs. + variable cp437_map #for cp437 images we need to map these *after* splitting ansi, to single-width unicode chars #It would also probably be problematic to map \u000A to the glyph - as this is the newline - it included in the map anyway for completeness. The caller may have to manually carve that or other specific c0 controls out of the map to use it depending on the situation(?) #Layout for cp437 won't be right if you don't at least set width of control-chars to 1 - but also some images specifically use these glyphs - #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too + #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too #by mapping these we can display regardless. - #nul char - no cp437 image but commonly used as space in ansi graphics. + #nul char - no cp437 image but commonly used as space in ansi graphics. #(This is a potential conflict because we use nul as a filler to mean empty column in overtype rendering) REVIEW tcl::dict::set cp437_map \u0000 " " ;#space tcl::dict::set cp437_map \u0001 \u263A ;#smiley @@ -377,11 +377,11 @@ tcl::namespace::eval punk::ansi { tcl::dict::set cp437_map \u0015 \u00A7 ;#Section Sign tcl::dict::set cp437_map \u0016 \u25AC ;#Heavy horizontal? tcl::dict::set cp437_map \u0017 \u21A8 ;#updown arrow 2 ? - tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow - tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow - tcl::dict::set cp437_map \u001A \u2192 ;#right arrow - tcl::dict::set cp437_map \u001B \u2190 ;#left arrow - tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner + tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow + tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow + tcl::dict::set cp437_map \u001A \u2192 ;#right arrow + tcl::dict::set cp437_map \u001B \u2190 ;#left arrow + tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner tcl::dict::set cp437_map \u001D \u2194 ;#left-right arrow tcl::dict::set cp437_map \u001E \u25B2 ;#up arrow triangle tcl::dict::set cp437_map \u001F \u25BC ;#down arrow triangle @@ -396,7 +396,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics c \u240c ;#symbol for FF tcl::dict::set map_special_graphics d \u240d ;#symbol for CR tcl::dict::set map_special_graphics e \u240a ;#symbol for LF - tcl::dict::set map_special_graphics f \u00b0 ;#degree sign + tcl::dict::set map_special_graphics f \u00b0 ;#degree sign tcl::dict::set map_special_graphics g \u00b1 ;#plus-minus sign tcl::dict::set map_special_graphics h \u2424 ;#symbol for NL tcl::dict::set map_special_graphics i \u240b ;#symbol for VT @@ -408,8 +408,8 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics o \u23ba ;#horizontal scan line-1 tcl::dict::set map_special_graphics p \u23bb ;#horizontal scan line-3 tcl::dict::set map_special_graphics q \u2500 ;#light horizontal - box drawing - tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 - tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 + tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 + tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 tcl::dict::set map_special_graphics t \u251c ;#light vertical and right - box drawing tcl::dict::set map_special_graphics u \u2524 ;#light vertical and left - box drawing tcl::dict::set map_special_graphics v \u2534 ;#light up and horizontal - box drawing @@ -419,10 +419,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics z \u2265 ;#greater than or equal tcl::dict::set map_special_graphics "\{" \u03c0 ;#greek small letter pi tcl::dict::set map_special_graphics "|" \u2260 ;#not equal to - tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign + tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign tcl::dict::set map_special_graphics ~ \u00b7 ;#middle dot - #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control + #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control variable test "blah\033\[1;33mETC\033\[0;mOK" @@ -451,14 +451,14 @@ tcl::namespace::eval punk::ansi { 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\\ \u009c] ;#note mix of 1 and 2-byte terminals + #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\\ \u009c] ;#note mix of 1 and 2-byte terminals tcl::dict::set escape_terminals DCS [list \007 \033\\ \u009c] tcl::dict::set escape_terminals MISC [list \007 \033\\ \u009c] - #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) + #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) #This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows? - #review - there doesn't seem to be an \x1b#7 + #review - there doesn't seem to be an \x1b#7 # https://espterm.github.io/docs/VT100%20escape%20codes.html #self-contained 2 byte ansi escape sequences - review more? @@ -479,9 +479,9 @@ tcl::namespace::eval punk::ansi { #comparitive test (performance) string-append vs 2-object (with existing splits) append proc test_cat1 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -492,13 +492,13 @@ tcl::namespace::eval punk::ansi { $s2 destroy #$s1 append \033\[31mX ;#redX - return $s1 + return $s1 } proc test_cat2 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -513,12 +513,12 @@ tcl::namespace::eval punk::ansi { # -------------------------------------- - #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? + #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? #In testing old ansi graphics files available on the web, some files need encoding {utf-8 cp437} some just cp437 proc readfile {fname {encoding cp437}} { - #todo + #todo #1- look for BOM - read according to format given by BOM - #2- assume utf-8 + #2- assume utf-8 #3- if errors - assume cp437? if {[llength $encoding] == 1} { @@ -605,7 +605,7 @@ tcl::namespace::eval punk::ansi { Defaults to /src/testansi - where projectbase is determined from the current directory. " - @values -min 0 -max -1 + @values -min 0 -max -1 files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help\ "List of filenames - leave empty to display 4 defaults" } ""] @@ -620,7 +620,7 @@ tcl::namespace::eval punk::ansi { set fnames [dict get $argd values files] #assumes fixed column widths e.g 80col images will fit in 82-width frames (common standard for old ansi art) (of arbitrary height) - #todo - review dependency on punk::repo ? + #todo - review dependency on punk::repo ? package require textblock package require punk::repo package require punk::console @@ -630,13 +630,13 @@ tcl::namespace::eval punk::ansi { puts stderr "Ensure ansi test files exist: $fnames" #error "punk::ansi::example Cannot find example files" } - set termsize [punk::console:::get_size] + set termsize [punk::console:::get_size] set termcols [dict get $termsize columns] set margin 4 ;#review set freewidth [expr {$termcols-$margin}] if {$freewidth < $colwidth} { puts stderr "[a+ red bold]punk::ansi::example freewidth: $freewidth < colwidth: $colwidth TRUNCATING IMAGES[a]" - set colwidth $freewidth + set colwidth $freewidth } set per_row [expr {$freewidth / $colwidth}] @@ -655,7 +655,7 @@ tcl::namespace::eval punk::ansi { #set img [join [lines_as_list -line trimline -block trimtail [ansicat $filepath]] \n] #-line trimline will wreck some images set img [join [lines_as_list -block trimtail [ansicat $filepath]] \n] - lappend pics [tcl::dict::create filename $f pic $img status ok] + lappend pics [tcl::dict::create filename $f pic $img status ok] } } @@ -670,13 +670,13 @@ tcl::namespace::eval punk::ansi { foreach picinfo $pics { set subtitle "" if {[tcl::dict::get $picinfo status] ne "ok"} { - set subtitle [tcl::dict::get $picinfo status] + set subtitle [tcl::dict::get $picinfo status] } set title [tcl::dict::get $picinfo filename] set fr [textblock::frame -checkargs 0 -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] - # -- --- --- --- + # -- --- --- --- #we need the max height of a row element to use join_basic instead of join below - # -- --- --- --- + # -- --- --- --- set fr_height [textblock::height $fr] lappend row $fr lappend rowh $fr_height @@ -691,8 +691,8 @@ tcl::namespace::eval punk::ansi { set rowmax $fr_height lset maxheights end $rowmax } - } - # -- --- --- --- + } + # -- --- --- --- if {$i % $per_row == 0} { lappend rowlist $row @@ -718,9 +718,9 @@ tcl::namespace::eval punk::ansi { if {$h < $maxheight} { #add blank lines to bottom of shorter images so join_basic can be used. #textblock::join of ragged-height images would work and remove the need for all the height calculation - #.. but it requires much more processing + #.. but it requires much more processing append i [string repeat \n$blankline [expr {$maxheight - $h}]] - } + } lappend adjusted_row $i } append result [textblock::join_basic -- {*}$adjusted_row] \n @@ -746,12 +746,12 @@ tcl::namespace::eval punk::ansi { #b) DEVICE CONTROL STRING (DCS) #c) OPERATING SYSTEM COMMAND (OSC) #d) PRIVACY MESSAGE (PM) - #e) START OF STRING (SOS) + #e) START OF STRING (SOS) # #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ - #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. + #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. #todo - review - printing_length calculations affected by whether terminal honours PMs or not. detect and accomodate. #review - can terminals handle SGR codes within a PM? #Wezterm will hide PM,SOS,APC - but not any part following an SGR code - i.e it seems to terminate hiding before the ST (apparently at the ) @@ -779,7 +779,7 @@ tcl::namespace::eval punk::ansi { #candidate for zig/c implementation? proc stripansi2 {text} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters join [::punk::ansi::ta::split_at_codes $text] "" } @@ -793,7 +793,7 @@ tcl::namespace::eval punk::ansi { #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - #set re {\033\(0[^\033]*\033\(B} + #set re {\033\(0[^\033]*\033\(B} #set re {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} #set re2 {\033\(0(.*)\033\(B} ;#capturing @@ -806,9 +806,9 @@ tcl::namespace::eval punk::ansi { #don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this. - set re_g0_open_or_close {\x1b\(0|\x1b\(B} + set re_g0_open_or_close {\x1b\(0|\x1b\(B} set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text] - set out {} + set out {} set g0_on 0 foreach {other g} $parts { if {$g0_on} { @@ -838,7 +838,7 @@ tcl::namespace::eval punk::ansi { #That will either stop us matching - so no conversion - or risk converting parts of the ansi codes #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - set re {\033\(0[^\033]*\033\(B} + set re {\033\(0[^\033]*\033\(B} set re2 {\033\(0(.*)\033\(B} ;#capturing #box sample @@ -902,10 +902,10 @@ tcl::namespace::eval punk::ansi { #Note that SYN (\016) seems to put terminals in a state #where alternate graphics are not processed. #an ETB (\017) needs to be sent to get alt graphics working again. - #It isn't known what software utilises SYN/ETB within altg sequences + #It isn't known what software utilises SYN/ETB within altg sequences # (presumably to alternate between the charsets within a graphics-on/graphics-off section) #but as modern emulators seem to react to it, we should handle it. - #REVIEW - this mapping not fully understood + #REVIEW - this mapping not fully understood #used by groptim variable grforw variable grback @@ -938,10 +938,10 @@ tcl::namespace::eval punk::ansi { proc ansistrip_gx {text} { #e.g "\033(0" - select VT100 graphics for character set G0 - #e.g "\033(B" - reset + #e.g "\033(B" - reset #e.g "\033)0" - select VT100 graphics for character set G1 #e.g "\033)X" - where X is any char other than 0 to reset ?? - + #return [convert_g0 $text] return [tcl::string::map [list \x1b(0 "" \x1b(B "" \x1b)0 "" \x1b)X ""] $text] } @@ -953,7 +953,7 @@ tcl::namespace::eval punk::ansi { #CSI m = SGR (Select Graphic Rendition) #leave map unindented - used both as a dict and for direct display variable SGR_setting_map { -reset 0 bold 1 dim 2 italic 3 noitalic 23 +reset 0 bold 1 dim 2 italic 3 noitalic 23 underline 4 doubleunderline 21 nounderline 24 blink 5 fastblink 6 noblink 25 reverse 7 noreverse 27 hide 8 nohide 28 strike 9 nostrike 29 normal 22 defaultfg 39 defaultbg 49 overline 53 nooverline 55 @@ -967,26 +967,26 @@ Black 40 Red 41 Green 42 Yellow 43 Blue brightblack 90 brightred 91 brightgreen 92 brightyellow 93 brightblue 94 brightpurple 95 brightcyan 96 brightwhite 97 Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblue 104 Brightpurple 105 Brightcyan 106 Brightwhite 107 } - variable SGR_map ;#public - part of interface - review + variable SGR_map ;#public - part of interface - review set SGR_map [tcl::dict::merge $SGR_colour_map $SGR_setting_map] #we use prefixes e.g web-white and/or x11-white #Only a leading capital letter will indicate the colour target is background vs lowercase for foreground - #In the map key-lookup context the colour names will be canonically lower case + #In the map key-lookup context the colour names will be canonically lower case #We should be case insensitive in the non-prefix part ie after determining fg/bg target from first letter of the prefix - #e.g Web-Lime or Web-lime are ok and are targeting background + #e.g Web-Lime or Web-lime are ok and are targeting background #foreground target examples: web-Lime web-LIME web-DarkSalmon web-Darksalmon #specified in decimal - but we should also accept hex format directly in a+ function e.g #00FFFF for aqua - variable WEB_colour_map + variable WEB_colour_map #use the totitle format as the canonical lookup key #don't use leading zeros - keep compatible with earlier tcl and avoid octal issue - # -- --- --- + # -- --- --- #css 1-2.0 HTML 3.2-4 Basic colours eg web-silver for fg Web-silver for bg # variable WEB_colour_map_basic tcl::dict::set WEB_colour_map_basic white 255-255-255 ;# #FFFFFF - tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 + tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 tcl::dict::set WEB_colour_map_basic gray 128-128-128 ;# #808080 tcl::dict::set WEB_colour_map_basic black 0-0-0 ;# #000000 tcl::dict::set WEB_colour_map_basic red 255-0-0 ;# #FF0000 @@ -1001,7 +1001,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_basic navy 0-0-128 ;# #000080 tcl::dict::set WEB_colour_map_basic fuchsia 255-0-255 ;# #FF00FF tcl::dict::set WEB_colour_map_basic purple 128-0-128 ;# #800080 - # -- --- --- + # -- --- --- #Pink colours variable WEB_colour_map_pink tcl::dict::set WEB_colour_map_pink mediumvioletred 199-21-133 ;# #C71585 @@ -1010,7 +1010,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_pink hotpink 255-105-180 ;# #FF69B4 tcl::dict::set WEB_colour_map_pink lightpink 255-182-193 ;# #FFB6C1 tcl::dict::set WEB_colour_map_pink pink 255-192-203 ;# #FFCOCB - # -- --- --- + # -- --- --- #Red colours variable WEB_colour_map_red tcl::dict::set WEB_colour_map_red darkred 139-0-0 ;# #8B0000 @@ -1022,7 +1022,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_red salmon 250-128-114 ;# #FA8072 tcl::dict::set WEB_colour_map_red darksalmon 233-150-122 ;# #E9967A tcl::dict::set WEB_colour_map_red lightsalmon 255-160-122 ;# #FFA07A - # -- --- --- + # -- --- --- #Orange colours variable WEB_colour_map_orange tcl::dict::set WEB_colour_map_orange orangered 255-69-0 ;# #FF4500 @@ -1030,7 +1030,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_orange darkorange 255-140-0 ;# #FF8C00 tcl::dict::set WEB_colour_map_orange coral 255-127-80 ;# #FF7F50 tcl::dict::set WEB_colour_map_orange orange 255-165-0 ;# #FFA500 - # -- --- --- + # -- --- --- #Yellow colours variable WEB_colour_map_yellow tcl::dict::set WEB_colour_map_yellow darkkhaki 189-183-107 ;# #BDB76B @@ -1044,7 +1044,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_yellow lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 tcl::dict::set WEB_colour_map_yellow lemonchiffon 255-250-205 ;# #FFFACD tcl::dict::set WEB_colour_map_yellow lightyellow 255-255-224 ;# #FFFFE0 - # -- --- --- + # -- --- --- #Brown colours #maroon as above variable WEB_colour_map_brown @@ -1064,7 +1064,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_brown bisque 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown blanchedalmond 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown cornsilk 255-248-220 ;# #FFF8DC - # -- --- --- + # -- --- --- #Purple, violet, and magenta colours variable WEB_colour_map_purple tcl::dict::set WEB_colour_map_purple indigo 75-0-130 ;# #4B0082 @@ -1074,7 +1074,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple darkslateblue 72-61-139 ;# #9400D3 tcl::dict::set WEB_colour_map_purple blueviolet 138-43-226 ;# #8A2BE2 tcl::dict::set WEB_colour_map_purple darkorchid 153-50-204 ;# #9932CC - tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF + tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF tcl::dict::set WEB_colour_map_purple magenta 255-0-255 ;# #FF00FF - same as fuchsia tcl::dict::set WEB_colour_map_purple slateblue 106-90-205 ;# #6A5ACD tcl::dict::set WEB_colour_map_purple mediumslateblue 123-104-238 ;# #7B68EE @@ -1085,7 +1085,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD tcl::dict::set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8 tcl::dict::set WEB_colour_map_purple lavender 230-230-250 ;# #E6E6FA - # -- --- --- + # -- --- --- #Blue colours variable WEB_colour_map_blue tcl::dict::set WEB_colour_map_blue midnightblue 25-25-112 ;# #191970 @@ -1103,7 +1103,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_blue lightsteelblue 176-196-222 ;# #B0C4DE tcl::dict::set WEB_colour_map_blue lightblue 173-216-230 ;# #ADD8E6 tcl::dict::set WEB_colour_map_blue powderblue 176-224-230 ;# #B0E0E6 - # -- --- --- + # -- --- --- #Cyan colours #teal as above variable WEB_colour_map_cyan @@ -1114,11 +1114,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_cyan mediumturquoise 72-209-204 ;# #48D1CC tcl::dict::set WEB_colour_map_cyan turquoise 64-224-208 ;# #40E0D0 tcl::dict::set WEB_colour_map_cyan aqua 0-255-255 ;# #00FFFF - tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua + tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua tcl::dict::set WEB_colour_map_cyan aquamarine 127-255-212 ;# #7FFFD4 tcl::dict::set WEB_colour_map_cyan paleturquoise 175-238-238 ;# #AFEEEE tcl::dict::set WEB_colour_map_cyan lightcyan 224-255-255 ;# #E0FFFF - # -- --- --- + # -- --- --- #Green colours variable WEB_colour_map_green tcl::dict::set WEB_colour_map_green darkgreen 0-100-0 ;# #006400 @@ -1141,7 +1141,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_green lightgreen 144-238-144 ;# #90EE90 tcl::dict::set WEB_colour_map_green greenyellow 173-255-47 ;# #ADFF2F tcl::dict::set WEB_colour_map_green palegreen 152-251-152 ;# #98FB98 - # -- --- --- + # -- --- --- #White colours variable WEB_colour_map_white tcl::dict::set WEB_colour_map_white mistyrose 255-228-225 ;# #FFE4E1 @@ -1161,7 +1161,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_white snow 255-250-250 ;# #FFFAFA tcl::dict::set WEB_colour_map_white ivory 255-255-240 ;# #FFFFF0 tcl::dict::set WEB_colour_map_white white 255-255-255 ;# #FFFFFF - # -- --- --- + # -- --- --- #Gray and black colours variable WEB_colour_map_gray tcl::dict::set WEB_colour_map_gray black 0-0-0 ;# #000000 @@ -1202,8 +1202,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #Xterm colour names (256 colours) - #lists on web have duplicate names - #these have been renamed here in a systematic way: + #lists on web have duplicate names + #these have been renamed here in a systematic way: #They are suffixed with a dash and a letter e.g second deepskyblue4 -> deepskyblue4-b, third deepskyblue4 -> deepskyblue4-c #presumably the xterm colour names are not widely used or are used for reverse lookup from rgb to get an approximate name in the case of dupes? #Review! @@ -1215,10 +1215,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95) #Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway. #The xterm names are boringly unimaginative - and also have some oddities such as: - # DarkSlateGray1 which looks much more like cyan.. + # DarkSlateGray1 which looks much more like cyan.. # The greyxx names are spelt with an e - but the darkslategrayX variants use an a. Perhaps that's because they are more cyan than grey and the a is a hint? # there is no gold or gold2 - but there is gold1 and gold3 - #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. + #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. set xterm_names [list\ black\ @@ -1500,7 +1500,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {!$did_rename} { - error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" + error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" } } incr cidx @@ -1510,7 +1510,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #colour_hex2ansidec - #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) + #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) #we want to support arbitrary rgb values specified in hex - so a table of 16M+ is probably not a great idea #hex zero-padded - canonically upper case but mixed or lower accepted #dict for {k v} $WEB_colour_map { @@ -1539,7 +1539,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable SGR_map return $SGR_map } - + proc colourmap1 {args} { set opts {-bg Web-white -forcecolour 0} foreach {k v} $args { @@ -1603,7 +1603,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } package require textblock set clist [list] - set fg "black" + set fg "black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "black"} { @@ -1647,14 +1647,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::get $opts -forcecolour]} { set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 0} {$i <=15} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? + set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? if {[llength $row]== 8} { lappend rows $row set row [list] @@ -1686,7 +1686,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } set out "" - set fg "web-black" + set fg "web-black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "web-black"} { @@ -1694,7 +1694,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set fg "web-black" } - set br "\n" + set br "\n" } else { set br "" } @@ -1716,10 +1716,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set out "" #use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-black" + set fg "web-black" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 16} {$i <=231} {incr i} { @@ -1892,10 +1892,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_hseps 0 -show_edge 0 for {set i 232} {$i <=255} {incr i} { @@ -1955,7 +1955,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray] switch -- $groups { "" - * { - set show_groups $all_groupnames + set show_groups $all_groupnames } ? { return "Web group names: $all_groupnames" @@ -1996,7 +1996,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] } - $t configure -frametype {} + $t configure -frametype {} $t configure_column 0 -headers [list "[tcl::string::totitle $g] colours"] $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] @@ -2106,7 +2106,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST" set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST" set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST" - set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" + set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" append out "${indent}$undercurly $underdotted" \n append out "${indent}$underdashed" \n append out "${indent}$underline_c" \n @@ -2115,7 +2115,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out "${indent}If a fallback to standard underline is required, underline should be added along with extended codes such as underlinedotted, underlinedouble etc" \n append out "${indent}e.g cyan with curly yellow underline or fallback all cyan underlined \[a+ cyan undercurly underline undt-yellow\]text\[a] -> [a+ {*}$fc cyan undercurly underline undt-yellow]text$RST" \n append out "[a+ {*}$fc web-white]Standard SGR colours and attributes $RST" \n - set settings_applied $SGR_setting_map + set settings_applied $SGR_setting_map set strmap [list] #safe jumptable test #dict for {k v} $SGR_setting_map {} @@ -2139,7 +2139,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try package require textblock - append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n + append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n set bgname "Web-white" @@ -2287,7 +2287,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::exists $TERM_colour_map $tail]} { set descr [tcl::dict::get $TERM_colour_map $tail] } else { - set descr "UNKNOWN colour for term" + set descr "UNKNOWN colour for term" } } $t add_row [list $i $descr $s [ansistring VIEW $s]] @@ -2303,11 +2303,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t add_row [list $i $descr $s [ansistring VIEW $s]] } - rgb- - Rgb- - RGB- - - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - + rgb- - Rgb- - RGB- - + rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - - rgb# - Rgb# - RGB# - + RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - + rgb# - Rgb# - RGB# - und# - und- { set cont [string range $i end-11 end] switch -- $cont { @@ -2430,7 +2430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #REVIEW! note that OSC 4 can change the 256 color pallette - #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ + #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ # (or with colour name instead of rgb #HHHHHH on for example wezterm) #Q: If we can't detect OSC 4 - how do we know when to invalidate/clear at least the 256 color portion of the cache? @@ -2492,13 +2492,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set linelen $thislen } else { append line "$ansi$key$RST " - incr linelen $thislen + incr linelen $thislen } } if {[tcl::string::length $line]} { lappend lines $line } - return [join $lines \n] + return [join $lines \n] } #PUNKARGS doc performed below, after we create the proc @@ -2506,10 +2506,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun a+] [opt {ansicode...}]] #[para]Returns the ansi code to apply those from the supplied list - without any reset being performed first - #[para] e.g to set foreground red and bold + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #function name part of cache-key because a and a+ return slightly different results (a has leading reset) @@ -2538,7 +2538,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set args [lremove $args $fcpos] } - set t [list] + set t [list] set e [list] ;#extended codes needing to go in own escape sequence foreach i $args { set f4 [tcl::string::range $i 0 3] @@ -2560,7 +2560,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] switch -- $cont { -contrasting { set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] @@ -2592,7 +2592,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] switch -- $cont { -contrasting { set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] @@ -2629,13 +2629,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu unde { #TODO - fix # extended codes with colon suppress normal SGR attributes when in same escape sequence on terminal that don't support the extended codes. - # need to emit in + # need to emit in switch -- $i { underline { lappend t 4 ;#underline } underlinedefault { - lappend t 59 + lappend t 59 } underextendedoff { #lremove any existing 4:1 etc @@ -2689,7 +2689,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -2749,10 +2749,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a+ $args'" } @@ -2763,19 +2763,19 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a+ $args'" } } } - rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - + rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { #decimal rgb foreground/background - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx set cont [string range $i end-11 end] switch -- $cont { @@ -2832,8 +2832,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx #https://wezfurlong.org/wezterm/escape-sequences.html#csi-582-underline-color-rgb set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set RGB [lrange [tcl::string::map [list - { } , { } {;} { }] $rgbspec] 0 2] @@ -2854,7 +2854,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend e "58:2::$rgbfinal" } "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] #set rgb [join [::scan $hex6 %2X%2X%2X] {:}] set RGB [::scan $hex6 %2X%2X%2X] @@ -2880,10 +2880,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -2894,7 +2894,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -2906,7 +2906,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -2927,10 +2927,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #the performance penalty must not be placed on the standard colour_enabled path. #This is punk. Colour is the happy path despite the costs. - #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. - #As no_color doesn't strip all ansi - the motivation for it should not generally be + #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. + #As no_color doesn't strip all ansi - the motivation for it should not generally be if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -2940,7 +2940,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -2994,12 +2994,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 0-255 int values for red, green and blue. rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 web- Web- - + The acceptable values for and can be queried using punk::ansi::a? term and punk::ansi::a? web - + Example to set foreground red and background cyan followed by a reset: set str \"[a+ red Cyan]sample text[a]\" " @@ -3009,11 +3009,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun a] [opt {ansicode...}]] #[para]Returns the ansi code to reset any current settings and apply those from the supplied list - #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text - #[para] e.g to set foreground red and bold + #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #It's important to put the functionname in the cache-key because a and a+ return slightly different results @@ -3041,7 +3041,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set args [lremove $args $fcpos] } - set t [list] + set t [list] set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence foreach i $args { set f4 [tcl::string::range $i 0 3] @@ -3052,7 +3052,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground web colour set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] set rgb [tcl::string::map { - ;} $rgbdash] lappend t "38;2;$rgb" } else { @@ -3093,7 +3093,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend t 4 ;#underline } underlinedefault { - lappend t 59 + lappend t 59 } underextendedoff { #lremove any existing 4:1 etc @@ -3147,7 +3147,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -3207,10 +3207,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a $args'" } @@ -3221,10 +3221,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a $args'" } @@ -3232,7 +3232,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 { #decimal rgb foreground - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] lappend t "38;2;$rgb" @@ -3256,14 +3256,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend t "48;2;$rgb" } und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set rgb [tcl::string::map [list - {:} , {:}] $rgbspec] lappend e "58:2::$rgb" } "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] set rgb [join [::scan $hex6 %2X%2X%2X] {:}] lappend e "58:2::$rgb" @@ -3274,10 +3274,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -3288,7 +3288,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -3300,7 +3300,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -3318,9 +3318,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - + if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -3330,7 +3330,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -3431,7 +3431,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun reset]] #[para]reset console - return "\x1bc" + return "\x1bc" } proc reset_soft {} { #*** !doctools @@ -3450,7 +3450,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun reset_colour]] #[para]reset colour only - return "\x1b\[0m" + return "\x1b\[0m" } # -- --- --- --- --- @@ -3578,7 +3578,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu Sequence is of the form: ESCY - This sequence will generally not be understood by terminals + This sequence will generally not be understood by terminals that are not in vt52 mode (e.g DECANM unset). } @values -min 2 -max 2 @@ -3605,7 +3605,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu proc move_emit {row col data args} { #*** !doctools #[call [fun move_emit] [arg row] [arg col] [arg data] [opt {row col data...}]] - #[para]Return an ansi string representing a move to row col with data appended + #[para]Return an ansi string representing a move to row col with data appended #[para]row col data can be repeated any number of times to return a string representing the output of the data elements at all those points #[para]Compare to punk::console::move_emit which calls this function - but writes it to stdout #[para]punk::console::move_emit_return will also return the cursor to the original position @@ -3773,13 +3773,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return \x1b\[3l } - #DECSNM + #DECSNM #Note this can invert the enclosed section including any already reversed by SGR 7 - depending on terminal support. - #e.g + #e.g #set test [a+ reverse]aaa[a+ noreverse]bbb # - $test above can't just be reversed by putting another [a+ reverse] in front of it. # - but the following will work (even if underlying terminal doesn't support ?5 sequences) - #overtype::renderspace -width 20 [enable_inverse]$test + #overtype::renderspace -width 20 [enable_inverse]$test proc enable_inverse {} { return \x1b\[?5h } @@ -3818,7 +3818,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # \x1b\[?7\;1\$y # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - + #https://wiki.tau.garden/dec-modes/ #(DEC,xterm,contour,mintty,kitty etc) #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking @@ -3837,7 +3837,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # mouse_urxvt 1015\ # mouse_sgr_pixel 1016\ #] - variable decmode_data { + variable decmode_data { 1 { {origin DEC description "DECCKM - Cursor Keys Mode" names {DECCKM cursor_keys}} } @@ -3864,7 +3864,7 @@ In VT52 mode - use \x1b< to exit. {origin "xterm" description "X10 compatibility mouse" names {SET_X10_MOUSE mouse_tracking} note { Escape sequence on button press only. CSI M CbCxCy (6 chars) -Coords limited to 223 (=255 - 32) +Coords limited to 223 (=255 - 32) } } {origin DEC description "DECINLM - Interlace Mode (obsolete?)" names {DECINLM}} @@ -3925,7 +3925,7 @@ to 223 (=255 - 32) 2004 { {origin "xterm" description "Set bracketed paste mode" names {bracketed_paste}} } - 2027 { + 2027 { {origin Contour description "Grapheme Cluster Processing" names {grapheme_clusters}} } } @@ -3936,7 +3936,7 @@ to 223 (=255 - 32) foreach nm $names { dict set decmode_names $nm $code } - } + } } @@ -3960,12 +3960,12 @@ to 223 (=255 - 32) #Alt screen buffer - smcup/rmcup ti/te #Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty) - #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. + #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. #see: https://xn--rpa.cc/irl/term.html #1049 (introduced by xterm in 1998?) considered the more modern version? #1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence #1049 - includes save cursor,switch to alt screen, clear screen - #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) + #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) #SMCUP # \x1b7 (save cursor) # \x1b\[?47h (switch) @@ -3973,10 +3973,10 @@ to 223 (=255 - 32) #RMCUP # \x1b\[?47l (switch back) # \x1b8 (restore cursor) - + #1047 - clear screen on the way out (ony if actually on alt screen) proc enable_alt_screen {} { - #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? + #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? return \x1b\[?1049h } proc disable_alt_screen {} { @@ -4114,13 +4114,13 @@ to 223 (=255 - 32) #[para]Use punk::console::get_cursor_pos or punk::console::get_cursor_pos_list instead. #[para]These functions will emit the code - but read it in from stdin so that it doesn't display, and then return the row and column as a colon-delimited string or list respectively. #[para]The punk::ansi::cursor_pos function is used by punk::console::get_cursor_pos and punk::console::get_cursor_pos_list - return \033\[6n + return \033\[6n } - + proc cursor_pos_extended {} { #includes page e.g ^[[47;3;1R #(but not on all terminals - some (freebsd?) will report as per 6n e.g ^[[74;3R) - return \033\[?6n + return \033\[?6n } @@ -4128,7 +4128,7 @@ to 223 (=255 - 32) #REVIEW - vt100 accepts decimal values 132-126 and 160-255 ("in the current GL or GR in-use table") #some modern terminals accept and display characters outside this range - but this needs investigation. #in a modern unicode era - the restricted range doesn't make a lot of sense - but we need to see what terminal emulators actually do. - #e.g what happens with double-width? + #e.g what happens with double-width? #this wrapper accepts a char rather than a decimal value proc fill_rect {char t l b r} { set dec [scan $char %c] @@ -4169,7 +4169,7 @@ to 223 (=255 - 32) } - #alternative to string terminator is \007 - + #alternative to string terminator is \007 - proc titleset {windowtitle} { #*** !doctools #[call [fun titleset] [arg windowtitles]] @@ -4181,7 +4181,7 @@ to 223 (=255 - 32) return \x1bS$windowtitle\r } #titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title - #no cross-platform ansi-only mechanism ? + #no cross-platform ansi-only mechanism ? proc test_decaln {} { #Screen Alignment Test @@ -4189,13 +4189,13 @@ to 223 (=255 - 32) #(doesn't work on many terminals - seems to work in FreeBSD 13.2 and wezterm on windows) return \x1b#8 } - + #length of text for printing characters only #- unicode and other non-printing chars and combining sequences should be handled by the ansifreestring_width call at the end. #certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names #review - is there an existing library or better method? printing to a terminal and querying cursor position is relatively slow and terminals lie. #Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first - #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. + #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. proc printing_length {line} { #string last faster than string first for long strings anyway if {[tcl::string::last \n $line] >= 0} { @@ -4203,7 +4203,7 @@ to 223 (=255 - 32) } #what if line has \v (vertical tab) ie more than one logical screen line? - #review - detect ansi moves and warn/error? They would invalidate this algorithm + #review - detect ansi moves and warn/error? They would invalidate this algorithm #for a string with ansi moves - we would need to use the overtype::renderline function (which is a bit heavier) #arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review #the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char @@ -4237,7 +4237,7 @@ to 223 (=255 - 32) } #NOTE - this is non-destructive backspace as it occurs in text blocks - and is likely different to the sequence coming from a terminal or editor which generally does a destructive backspace - #e.g + #e.g #This means for example that abc\b has a length of 3. Trailing or leading backslashes have no effect #set bs [format %c 0x08] @@ -4260,16 +4260,16 @@ to 223 (=255 - 32) } #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner - #build an output + #build an output set idx 0 set outchars [list] set outsizes [list] # -- - #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code + #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code #this is difficult/risky to maintain - hence the lsearch and grapheme-replacement above #we could reasonably do it with backspace - but cr is more difficult #note that \x08 \b etc won't work to create a compiled switch statement even with unbraced (separate argument) form of switch statement. - #set bs "" + #set bs "" #set cr ? # -- foreach c $chars { @@ -4283,10 +4283,10 @@ to 223 (=255 - 32) set idx 0 } default { - #set nxt [llength $outchars] + #set nxt [llength $outchars] if {$idx < [llength $outchars]} { #overstrike? - should usually have no impact on width - width taken as last grapheme in that column - #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. lset outchars $idx $c } else { @@ -4338,7 +4338,7 @@ to 223 (=255 - 32) #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) if {[string length $text] < 2} {return $text} if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] @@ -4358,7 +4358,7 @@ to 223 (=255 - 32) #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } set parts [punk::ansi::ta::split_codes $text] #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" @@ -4369,9 +4369,9 @@ to 223 (=255 - 32) proc ansistripraw {text} { #*** !doctools #[call [fun ansistripraw] [arg text] ] - #[para]Return a string with ansi codes stripped out + #[para]Return a string with ansi codes stripped out #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. - #[para]ie instead of a horizontal line you may see: qqqqqq + #[para]ie instead of a horizontal line you may see: qqqqqq if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] @@ -4403,7 +4403,7 @@ tcl::namespace::eval punk::ansi { # name (one not found in xterm's tables) ends processing of the # list of names. proc xtgetcap {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -4412,7 +4412,7 @@ tcl::namespace::eval punk::ansi { return "\x1bP+q$payload\x1b\\" } proc xtgetcap2 {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -4432,8 +4432,8 @@ tcl::namespace::eval punk::ansi { #review - separate namespace for functions that operate on multiple or embedded? proc is_sgr {code} { - #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline - #we will accept and pass through the less common colon separator (ITU Open Document Architecture) + #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline + #we will accept and pass through the less common colon separator (ITU Open Document Architecture) #Terminals should generally ignore it if they don't use it regexp {\033\[[0-9;:]*m$} $code } @@ -4450,7 +4450,7 @@ tcl::namespace::eval punk::ansi { return 1 } } - return 0 + return 0 } #pure SGR reset with no other functions proc is_sgr_reset {code} { @@ -4458,8 +4458,8 @@ tcl::namespace::eval punk::ansi { #[call [fun is_sgr_reset] [arg code]] #[para]Return a boolean indicating whether this string has a trailing pure SGR reset #[para]Note that if the reset is not the very last item in the string - it will not be detected. - #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. - + #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. + #todo 8-bit csi regexp {\x1b\[0*m$} $code } @@ -4469,7 +4469,7 @@ tcl::namespace::eval punk::ansi { #if an SGR code has a reset in it - we don't need to carry forward any previous SGR codes #it generally only makes sense for the reset to be the first parameter - otherwise the code has ineffective portions #However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. - #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. + #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. #Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg colour twice in same code proc has_sgr_leadingreset {code} { @@ -4477,7 +4477,7 @@ tcl::namespace::eval punk::ansi { #[call [fun has_sgr_leadingreset] [arg code]] #[para]The reset must be the very first item in code to be detected. Trailing strings/codes ignored. set params "" - #we need non-greedy + #we need non-greedy if {[regexp {^\033\[([^m]*)m} $code _match params]} { #must match trailing m to be the type of reset we're looking for set plist [split $params ";"] @@ -4506,7 +4506,7 @@ tcl::namespace::eval punk::ansi { #regexp {\x1b\(B|\x1b\)B} $code regexp {\x1b(?:\(B|\)B)} $code } - #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through + #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through #This is not order-preserving if non-sgr codes are present as they are tacked on to the end even if they initially were before all SGR codes variable codestate_empty @@ -4514,11 +4514,11 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty rst "" ;#0 (or empty) tcl::dict::set codestate_empty intensity "" ;#1 bold, 2 dim, 22 normal tcl::dict::set codestate_empty italic "" ;#3 on 23 off - tcl::dict::set codestate_empty underline "" ;#4 on 24 off + tcl::dict::set codestate_empty underline "" ;#4 on 24 off #nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5 #4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions - #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines + #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines tcl::dict::set codestate_empty underextended "" ;#4:0 for no extended underline 4:1 etc for underline styles #tcl::dict::set codestate_empty undersingle "" #tcl::dict::set codestate_empty underdouble "" @@ -4550,10 +4550,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty superscript "" ;#73 tcl::dict::set codestate_empty subscript "" ;#74 tcl::dict::set codestate_empty nosupersub "" ;#75 - # -- + # -- tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 - tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 + tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 #misnomer should have been sgr_merge_args ? :/ @@ -4562,7 +4562,7 @@ tcl::namespace::eval punk::ansi { if {[llength $args] == 0} { return "" } elseif {[llength $args] == 1} { - return [lindex $args 0] + return [lindex $args 0] } sgr_merge $args } @@ -4610,7 +4610,7 @@ tcl::namespace::eval punk::ansi { set did_reset 0 #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? - #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? + #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? #we will output 7bit merge of the SGRs even if some or all were 8bit CSi #As at 2024 - 7bit are widely supported 8bit seem to be often ignored by pseudoterminals #auto-detecting and emitting 8bit only if any are present in our input doesn't seem like a good idea - as sgr_merge_list is only seeing a subset of the data - so any auto-decision at this level will just introduce indeterminism. @@ -4644,10 +4644,10 @@ tcl::namespace::eval punk::ansi { #some codes have additional parameters - e.g rgb colours so we need to jump forward in the parameter list sometimes. for {set i 0} {$i < [llength $plist]} {incr i} { set p [lindex $plist $i] - set paramsplit [split $p :] - #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters + set paramsplit [split $p :] + #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters #e.g see https://github.com/mintty/mintty/wiki/Tips#text-attributes-and-rendering - #this may have originated with kitty? + #this may have originated with kitty? #windows terminal seems to be implementing it too #however, they can be completely repurposed - so we probably need to specifically support them.. REVIEW. @@ -4682,7 +4682,7 @@ tcl::namespace::eval punk::ansi { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines #e.g hyper on windows if {[llength $paramsplit] == 1} { - tcl::dict::set codestate underline 4 + tcl::dict::set codestate underline 4 } else { switch -- [lindex $paramsplit 1] { 0 { @@ -4691,10 +4691,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended } 1 { - tcl::dict::set codestate underextended 4:1 + tcl::dict::set codestate underextended 4:1 } 2 { - tcl::dict::set codestate underextended 4:2 + tcl::dict::set codestate underextended 4:2 } 3 { tcl::dict::set codestate underextended "4:3" @@ -4716,7 +4716,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate reverse 7 } 8 { - tcl::dict::set codestate hide 8 + tcl::dict::set codestate hide 8 } 9 { tcl::dict::set codestate strike 9 @@ -4738,7 +4738,7 @@ tcl::namespace::eval punk::ansi { } 23 { #? wikipedia mentions blackletter - review - tcl::dict::set codestate italic 23 + tcl::dict::set codestate italic 23 } 24 { tcl::dict::set codestate underline 24 ;#off @@ -4766,11 +4766,11 @@ tcl::namespace::eval punk::ansi { 38 { #256 colour or rgb #check if subparams supplied as colon separated - if {[tcl::string::first : $p] < 0} { + if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4780,9 +4780,9 @@ tcl::namespace::eval punk::ansi { } } } else { - #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space + #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space #we should only need to pass it all through for the terminal to understand - #review + #review tcl::dict::set codestate fg $p } } @@ -4798,7 +4798,7 @@ tcl::namespace::eval punk::ansi { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4818,7 +4818,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate proportional 50 ;#off - see 26 } 51 - 52 { - tcl::dict::set codestate frame_or_circle 51 + tcl::dict::set codestate frame_or_circle 51 } 53 { tcl::dict::set codestate overline 53 ;#not supported in terminals? pass through anyway @@ -4830,13 +4830,13 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate overline 55; #off } 58 { - #nonstandard + #nonstandard #256 colour or rgb if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4905,11 +4905,11 @@ tcl::namespace::eval punk::ansi { } } - } + } default { lappend othercodes $c } - } + } } @@ -4920,7 +4920,7 @@ tcl::namespace::eval punk::ansi { #dict for {k v} $codestate {} tcl::dict::for {k v} $codestate { switch -- $v { - "" { + "" { } default { switch -- $k { @@ -5028,7 +5028,7 @@ tcl::namespace::eval punk::ansi { tcl::namespace::eval punk::ansi::ta { #*** !doctools #[subsection {Namespace punk::ansi::ta}] - #[para] text ansi functions + #[para] text ansi functions #[para] based on but not identical to the Perl Text Ansi module: #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm #[list_begin definitions] @@ -5036,7 +5036,7 @@ tcl::namespace::eval punk::ansi::ta { variable PUNKARGS - #handle both 7-bit and 8-bit csi + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position #CSI @@ -5058,7 +5058,7 @@ tcl::namespace::eval punk::ansi::ta { #non-greedy by excluding ST terminators variable re_esc_osc1 {(?:\x1b\])(?:[^\007]*)\007} #variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\} ;#somewhat wrong - we want to exclude the ST - not other esc sequences - variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} + variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} variable re_esc_osc3 {(?:\u009d)(?:[^\u009c]*)?\u009c} variable re_osc_open {(?:\x1b\]|\u009d).*} @@ -5070,7 +5070,7 @@ tcl::namespace::eval punk::ansi::ta { #ESC Y move, ESC b foreground colour #ESC F - gr-on ESC G - gr-off variable re_vt52_open {(?:\x1bY|\x1bb|\x1bF)} - #\x1bc vt52 bgcolour conflict ?? + #\x1bc vt52 bgcolour conflict ?? #if we don't split on altgraphics too and separate them out - it's easy to get into a horrible mess variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} @@ -5078,7 +5078,7 @@ tcl::namespace::eval punk::ansi::ta { variable re_g0_close {(?:\x1b\(B)} # DCS "ESC P" or "0x90" is also terminated by ST - set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} #ST terminators [list \007 \033\\ \u009c] #regex to capture the start of string/privacy message/application command block including the contents and string terminator (ST) @@ -5087,7 +5087,7 @@ tcl::namespace::eval punk::ansi::ta { #even if terminals generally don't support that - it's quite possible for an ansi code to get nested this way - and we'd prefer it not to break our splits #Just checking for \x1b will terminate the match too early #we also need to track the start of ST terminated code and not add it for replay (in the ansistring functions) - #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) + #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) #keep our 8bit/7bit start-end codes separate variable re_ST {(?:\x1bP|\x1bX|\x1b\^|\x1b_)(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007)|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)} @@ -5104,12 +5104,12 @@ tcl::namespace::eval punk::ansi::ta { #variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} #NOTE - the literal # char can cause problems in expanded syntax - even though it's within a bracketed section. \# seems to work though. - #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| + #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| #https://freemint.github.io/tos.hyp/en/VT_52_terminal.html #what to with ESC c vs vt52 ESC c (background colour) ??? #we probably need to use a separate re_ansi_detect for vt52 - #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes + #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes #ie - when DECANM is on - VT52 codes are *not* processed #todo - ansi mode and cursor key mode set ? @@ -5129,8 +5129,8 @@ tcl::namespace::eval punk::ansi::ta { - variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" - + variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" + #may be same as detect - kept in case detect needs to diverge #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect @@ -5142,7 +5142,7 @@ tcl::namespace::eval punk::ansi::ta { } lappend PUNKARGS [list -dynamic 0 { - @id -id ::punk::ansi::ta::detect + @id -id ::punk::ansi::ta::detect @cmd -name punk::ansi::ta::detect -help\ "Return a boolean indicating whether Ansi codes were detected in text. Important caveat: @@ -5151,9 +5151,9 @@ tcl::namespace::eval punk::ansi::ta { (one example is if a list element contains an unbalanced brace) This can cause square brackets that form part of the ansi to be backslash escaped - and the function can fail to match it as an Ansi code. - " + " @values -min 1 - text -type string + text -type string } ] #*** !doctools @@ -5187,8 +5187,8 @@ tcl::namespace::eval punk::ansi::ta { proc detect_g0 {text} [string map [list [list $re_g0_group]] { regexp $text }] - #note - micro optimisation of inlining gives us *almost* nothing extra. - #left in place for a few such as detect/detect_g0 as we want them as fast as possible + #note - micro optimisation of inlining gives us *almost* nothing extra. + #left in place for a few such as detect/detect_g0 as we want them as fast as possible # in general the technique doesn't seem particularly worthwhile for this set of functions. #the performance is dominated by the complexity of the regexp proc detect2 {text} { @@ -5211,8 +5211,8 @@ tcl::namespace::eval punk::ansi::ta { #[call [fun detect_csi] [arg text]] #[para]Return a boolean indicating whether an Ansi Control Sequence Introducer (CSI) was detected in text #[para]The csi is often represented in code as \x1b or \033 followed by a left bracket [lb] - #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation - #[para]There is also a multi-byte escape sequence \u009b + #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation + #[para]There is also a multi-byte escape sequence \u009b #[para]This is less commonly used but is also detected here #[para](This function is not in perl ta) variable re_csi_open @@ -5240,7 +5240,7 @@ tcl::namespace::eval punk::ansi::ta { #*** !doctools #[call [fun length] [arg text]] #[para]Return the character length after stripping ansi codes - not the printing length - + #we can use ansistripraw to avoid g0 conversion - as the length should remain the same tcl::string::length [ansistripraw $text] } @@ -5259,11 +5259,11 @@ tcl::namespace::eval punk::ansi::ta { proc split_at_codes {str} [string map [list $re_ansi_split] { #variable re_ansi_split #punk::ansi::internal::splitx $str ${re_ansi_split} - punk::ansi::ta::Do_split_at_codes $str {} + punk::ansi::ta::Do_split_at_codes $str {} }] #it is faster to split this function out than to inline it into split_at_codes in tcl 8.7 - something to do with the use of the variable vs argument for the regexp #literal inlining of the re in the main proc-body was slower too - but inlining it into the wrapper seems to work (a tiny bit) - #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - + #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - # - but in aggregate for something like textblock::periodic - we can get a bit over 5% faster (e.g 136ms vs 149ms) proc Do_split_at_codes {str regexp} { if {$str eq ""} { @@ -5342,12 +5342,12 @@ tcl::namespace::eval punk::ansi::ta { lappend list [tcl::string::range $str $start end] return $list }] - - # -- --- --- --- --- --- + + # -- --- --- --- --- --- #Split $text to a list containing alternating ANSI colour codes and text. #ANSI colour codes are always on the second element, fourth, and so on. #(ie plaintext on even list-indices ansi on odd indices) - #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) + #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) # Example: #split_codes "" # => "" #split_codes "a" # => "a" @@ -5361,7 +5361,7 @@ tcl::namespace::eval punk::ansi::ta { variable re_ansi_split_multi return [_perlish_split $re_ansi_split_multi $text] } - #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) + #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds) #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. @@ -5413,16 +5413,16 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] - incr start + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] + incr start } else { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] } if {$start >= [tcl::string::length $text]} { @@ -5437,20 +5437,20 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] - incr start + 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 $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] #? if {$start >= [tcl::string::length $text]} { @@ -5467,22 +5467,22 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::index $text $matchStart] - incr start + yield [tcl::string::index $text $matchStart] + incr start if {$start >= [tcl::string::length $text]} { break } continue } yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::range $text $matchStart $matchEnd] + yield [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] #? if {$start >= [tcl::string::length $text]} { @@ -5495,7 +5495,7 @@ tcl::namespace::eval punk::ansi::ta { proc _ws_split {text} { regexp -all -inline {(?:\S+)|(?:\s+)} $text } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #*** !doctools #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] @@ -5532,7 +5532,7 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- if {[llength $args] < 1} { error {usage: ?-width ? ?-height ? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring} @@ -5632,7 +5632,7 @@ tcl::namespace::eval punk::ansi::class { method rendernext {} { upvar ${o_ns_from}::o_ansisplits from_ansisplits upvar ${o_ns_from}::o_elements from_elements - upvar ${o_ns_from}::o_splitindex from_splitindex + upvar ${o_ns_from}::o_splitindex from_splitindex #if {![llength $from_ansisplits]} {$o_from_ansistring eval_in {my MakeSplit}} ;#!!todo - a better way to keep this method semi hidden but call from a 'friend' if {![llength $from_ansisplits]} { @@ -5658,7 +5658,7 @@ tcl::namespace::eval punk::ansi::class { set process_splitindex [lindex $from_splitindex $eidx] ;#which from_ansisplits index the first unrendered element belongs to set elementinfo [lindex $from_elements $eidx] - lassign $elementinfo type_rendered item + lassign $elementinfo type_rendered item #we don't expect type to change should be all graphemes (type 'g') or a single code (type 'sgr','other' etc) #review - we may want to store more info for graphemes e.g g0 g1 g2 for zero-wide 1-wide 2-wide ? #if so - we should report a list of the grapheme types that were rendered in a pt block @@ -5674,7 +5674,7 @@ tcl::namespace::eval punk::ansi::class { set e_splitindex $process_splitindex while {$e_splitindex == $process_splitindex && $eidx < [llength $from_elements]} { append newtext $item - lappend o_rendereditems $elementinfo + lappend o_rendereditems $elementinfo incr rendercount incr eidx @@ -5684,8 +5684,8 @@ tcl::namespace::eval punk::ansi::class { } } else { #while not g ? render however many ansi sequences are in a row? - set newtext $item - lappend o_rendereditems $elementinfo + set newtext $item + lappend o_rendereditems $elementinfo incr rendercount } @@ -5703,7 +5703,7 @@ tcl::namespace::eval punk::ansi::class { if {![tcl::string::length $overtext]} { continue } - #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] + #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] } } #renderspace equivalent? channel based? @@ -5714,7 +5714,7 @@ tcl::namespace::eval punk::ansi::class { } } - #name all with prefix class_ for rendertype detection + #name all with prefix class_ for rendertype detection oo::class create class_cp437 { superclass base_renderer } @@ -5733,7 +5733,7 @@ tcl::namespace::eval punk::ansi::class { #this is the main state we keep of the split apart string #we use the punk::ansi::ta::split_codes_single function which produces a list with zero, or an odd number elements always beginning and ending with plaintext - variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes + variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes variable o_ansisplits ;#store our plaintext/ansi-code splits so we don't keep re-running the regexp to split @@ -5750,7 +5750,7 @@ tcl::namespace::eval punk::ansi::class { variable o_elements ;#elements contains entry for each grapheme/control + each ansi code variable o_sgrstacks ;#list of ansi sgr codes that will be merged later. Entries deliberately repeat if no change from previous entry. Later scans look for difference between n and n-1 when deciding where to apply codes. variable o_gx0states ;#0|1 for alternate graphics gx0 - variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. + variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. # -- -- constructor {string} { @@ -5763,7 +5763,7 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- #we choose not to generate an internal split-state for the initial string - which may potentially be large. @@ -5772,7 +5772,7 @@ tcl::namespace::eval punk::ansi::class { set o_count "" ;#o_count first updated when string appended or a method causes MakeSplit to run (or by count method if constructor argument was empty string) - set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. + set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. set o_ptlist [list] #o_ansisplits and o_ptlist should only remain empty if an empty string was passed to the contructor, or no methods have yet triggered the initial string to have it's internal state built. @@ -5786,7 +5786,7 @@ tcl::namespace::eval punk::ansi::class { #empty if no render methods used # -- - set o_renderer "" + set o_renderer "" set o_renderout "" ;#class_ansistring # -- @@ -5810,18 +5810,18 @@ tcl::namespace::eval punk::ansi::class { method show_state {{verbose 0}} { #show some state info - without updating anything - #only use 'my' methods that don't update the state e.g has_ansi + #only use 'my' methods that don't update the state e.g has_ansi set result "" if {![llength $o_ansisplits]} { append result "No internal splits. " append result \n "has ansi : [my has_ansi]" - append result \n "Tcl string length raw string: [tcl::string::length $o_string]" + append result \n "Tcl string length raw string: [tcl::string::length $o_string]" } else { append result \n "has ansi : [my has_ansi]" - append result \n "ansisplit list len: [llength $o_ansisplits]" + append result \n "ansisplit list len: [llength $o_ansisplits]" append result \n "plaintext list len: [llength $o_ptlist]" append result \n "cached count : $o_count" - append result \n "Tcl string length raw string : [tcl::string::length $o_string]" + append result \n "Tcl string length raw string : [tcl::string::length $o_string]" append result \n "Tcl string length plaintext parts: [tcl::string::length [join $o_ptlist ""]]" if {[llength $o_ansisplits] %2 == 0} { append result \n -------------------------------------------------- @@ -5860,10 +5860,10 @@ tcl::namespace::eval punk::ansi::class { #private method method MakeSplit {} { #The split with each code as it's own element is more generally useful. - set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; + set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; set o_ptlist [list] set codestack [list] - set gx0_state 0 ;#default off + set gx0_state 0 ;#default off set current_split_index 0 ;#incremented for each pt block, incremented for each code if {$o_count eq ""} { set o_count 0 @@ -5878,7 +5878,7 @@ tcl::namespace::eval punk::ansi::class { incr o_count } #after handling the pt block - incr the current_split_index - incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry + incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry #we will only get an empty code at the very end of ansisplits (ansisplits is length 0 or odd length - always with pt at start and pt at end) if {$code ne ""} { lappend o_sgrstacks $codestack @@ -5914,7 +5914,7 @@ tcl::namespace::eval punk::ansi::class { } } #assertion every grapheme and every individual code has been added to o_elements - #every element has an entry in o_sgrstacks + #every element has an entry in o_sgrstacks #every element has an entry in o_gx0states assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} } @@ -5925,7 +5925,7 @@ tcl::namespace::eval punk::ansi::class { method strippedlength {} { if {![llength $o_ansisplits]} {my MakeSplit} #review - return [string length [join $o_ptlist ""]] + return [string length [join $o_ptlist ""]] } #returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already method stripped {} { @@ -5938,13 +5938,13 @@ tcl::namespace::eval punk::ansi::class { method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function return [tcl::string::length [regsub -all $re_diacritics $plaintext ""]] } - #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! + #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! method count {} { if {$o_count eq ""} { #only initial string present @@ -5977,7 +5977,7 @@ tcl::namespace::eval punk::ansi::class { #channels for stream in/out.. these are vaguely analogous to the input/output between a shell and a PTY Slave - but this is not intended to be a full pseudoterminal #renderstream_to_render (private?) - # write end held by outer ansistring? read end by inner render ansistring ? + # write end held by outer ansistring? read end by inner render ansistring ? #renderstream_from_render (public?) method rendertypes {} { @@ -5991,7 +5991,7 @@ tcl::namespace::eval punk::ansi::class { } set rtypes [my rendertypes] if {$rtype ni $rtypes} { - error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" + error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" } #if {$o_renderout eq ""} { # set o_renderout [punk::ansi::class::class_ansistring new ""] @@ -6022,7 +6022,7 @@ tcl::namespace::eval punk::ansi::class { } if {$rw eq $o_renderwidth} { return $o_renderwidth - } + } #re-render if needed? puts stderr "renderwidth todo? re-render?" @@ -6034,7 +6034,7 @@ tcl::namespace::eval punk::ansi::class { method render_state {} { #? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary #but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split. - #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work + #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work } method renderbuf {} { #get the underlying renderobj - if any @@ -6071,7 +6071,7 @@ tcl::namespace::eval punk::ansi::class { return [dict create graphemes $grapheme_count other $other_count] } method rendernext {} { - #render next available pt/code chunk only - not to end of available input + #render next available pt/code chunk only - not to end of available input if {$o_renderer eq ""} { my rendertype $o_rendertype ;#review - proper way to initialise rendering } @@ -6111,7 +6111,7 @@ tcl::namespace::eval punk::ansi::class { } #analagous to Tcl string append - #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient + #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient method append {args} { set catstr [join $args ""] if {$catstr eq ""} { @@ -6122,19 +6122,19 @@ tcl::namespace::eval punk::ansi::class { #ansi-free additions #if no initial internal-split - generate it without first appending our additions - as we can more efficiently append them to the internal state if {![llength $o_ansisplits]} { - #initialise o_count because we need to add to it. + #initialise o_count because we need to add to it. #The count method will do this by calling Makesplit only if it needs to. (which will create ansisplits for anything except empty string) my count } append o_string $catstr;# only append after updating using my count above if {![llength $o_ptlist]} { - #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits + #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits #even though we can use lset to add to a list - we can't for empty lappend o_ptlist $catstr #assertion - if o_ptlist is empty so is o_ansisplits lappend o_ansisplits $catstr } else { - lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] + lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] $catstr] } set last_codestack [lindex $o_sgrstacks end] @@ -6156,16 +6156,16 @@ tcl::namespace::eval punk::ansi::class { #set combined_plaintext [join $o_ptlist ""] #set o_count [my DoCount $combined_plaintext] assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} - return $o_string + return $o_string } else { - #update each element of internal state incrementally without reprocessing what is already there. + #update each element of internal state incrementally without reprocessing what is already there. append o_string $catstr - set newsplits [punk::ansi::ta::split_codes_single $catstr] + set newsplits [punk::ansi::ta::split_codes_single $catstr] set ptnew "" set codestack [lindex $o_sgrstacks end] set gx0_state [lindex $o_gx0states end] - set current_split_index [lindex $o_splitindex end] - #first pt must be merged with last element of o_ptlist + set current_split_index [lindex $o_splitindex end] + #first pt must be merged with last element of o_ptlist set new_pt_list [list] foreach {pt code} $newsplits { lappend new_pt_list $pt @@ -6216,7 +6216,7 @@ tcl::namespace::eval punk::ansi::class { #if {$o_count eq ""} { # #we have splits - but didn't count graphemes? - # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts + # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts #} else { # incr o_count [my DoCount $ptnew] #} @@ -6227,7 +6227,7 @@ tcl::namespace::eval punk::ansi::class { return $o_string } - #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. + #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. #This is 'often'? likely to be true - We don't have grapheme cluster support yet anyway. review. method appendobj {args} { if {![llength $o_ansisplits]} { @@ -6272,7 +6272,7 @@ tcl::namespace::eval punk::ansi::class { set firstnewidx [lindex $new_splitindex 0] set diffidx [expr {$lastidx - $firstnewidx}] ;#may be negative foreach v $new_splitindex { - lappend o_splitindex [expr {$v + $diffidx}] + lappend o_splitindex [expr {$v + $diffidx}] } incr o_count $new_count @@ -6323,7 +6323,7 @@ tcl::namespace::eval punk::ansi::class { set arrow_lr \u2194 set arrow_du \u2195 #2024 - there is no 4-arrow symbol or variations (common cursor and window icon) in unicode - despite requests and argument from the community that this has been in use for decades. - #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. + #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. #don't split into lines first - \n is valid within ST sections set output "" @@ -6338,7 +6338,7 @@ tcl::namespace::eval punk::ansi::class { set c1 [tcl::string::index $code 0] set c1c2 [tcl::string::range $code 0 1] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[ 7CSI\ \x9b 8CSI\ @@ -6346,9 +6346,9 @@ tcl::namespace::eval punk::ansi::class { \x1b\( 7GFX\ \x9d 8OSC\ \x1b 7ESC\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - #we leave the tail of the code unmapped for now + #we leave the tail of the code unmapped for now switch -- $leadernorm { 7CSI - 7OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] @@ -6401,7 +6401,7 @@ tcl::namespace::eval punk::ansi::class { H - f { set params [tcl::string::range $codenorm 4 end-1] lassign [split $params {;}] row col - #lassign $matchinfo _match row col + #lassign $matchinfo _match row col set displaycode [ansistring VIEW $code] if {$col eq ""} { #row only move @@ -6423,7 +6423,7 @@ tcl::namespace::eval punk::ansi::class { append output ${unk}[ansistring VIEW -lf 1 $code]$RST } } - } + } 7GFX { switch -- [tcl::string::index $codenorm 4] { "0" { @@ -6456,7 +6456,7 @@ tcl::namespace::eval punk::ansi::class { #set splits [punk::ansi::ta::split_codes_single $string] set output "" set codestack [list] - set gx_stack [list] ;#not actually a stack + set gx_stack [list] ;#not actually a stack set cursor_saved "" foreach {pt code} $o_ansisplits { if {[llength $args]} { @@ -6482,13 +6482,13 @@ tcl::namespace::eval punk::ansi::class { #cursor_restore set codestack [list $cursor_saved] } else { - #leave SGR stack as is + #leave SGR stack as is if {[punk::ansi::codetype::is_gx_open $code]} { set gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess } elseif {[punk::ansi::codetype::is_gx_close $code]} { set gx_stack [list] - } - } + } + } } } return $output @@ -6500,24 +6500,24 @@ tcl::namespace::eval punk::ansi { proc stripansi3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - #using detect costs us a couple of uS - but saves time on plain text + #using detect costs us a couple of uS - but saves time on plain text #we should probably leave this for caller - otherwise it ends up being called more than necessary - #if {![::punk::ansi::ta::detect $text]} { + #if {![::punk::ansi::ta::detect $text]} { # return $text #} #alternate graphics codes are not the norm - # - so save a few uS in the common case by only calling convert_g0 if we detect + # - so save a few uS in the common case by only calling convert_g0 if we detect if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] proc stripansiraw3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { #join [::punk::ansi::ta::split_at_codes $text] "" - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] } @@ -6533,7 +6533,7 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::namespace::ensemble create tcl::namespace::export length trim trimleft trimright INDEX COUNT VIEW VIEWCODES VIEWSTYLE INDEXABSOLUTE INDEXCOLUMNS COLUMNINDEX NEW #todo - expose _splits_ methods so caller can work efficiently with the splits themselves - #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single + #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single #\UFFFD - replacement char or \U2426 @@ -6647,7 +6647,7 @@ tcl::namespace::eval punk::ansi::ansistring { variable debug_visuals #modern (c0 seem to have more terminal/font support - C1 can show 8bit c1 codes - but also seems to be limited support) - + #Goal is not to map every control character? #Map of which elements we want to convert - done this way so we can see names of control's that are included: - ease of maintenance compared to just creating the tcl::string::map directly #ETX -ctrl-c @@ -6729,10 +6729,10 @@ tcl::namespace::eval punk::ansi::ansistring { #we'll hack in some stuff as needed - may override some of the visuals_c1 which is usually just empty/substitute glyphs #Being repurposed - these could potentially be confused with actual characters depending on the debugging context #To minimize potential confusion - we'll use a longer replacement sequence - which is not ideal from the perspective of terminal column layout debugging - #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator + #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator #(review - BOM should use different brackets to c1?) - #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. + #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. #for 8-bit controls - we will standardize on a fixed width of 4 bracketing with: #\u2987 and \u2988 from Miscellaneous Mathematical Symbols-B (D or fractional-moon shaped brackets) #\u2987 - Z Notation Left Image Bracket @@ -6750,7 +6750,7 @@ tcl::namespace::eval punk::ansi::ansistring { #unicode Tags block brackets set obt \u2993 ;set cbt \u2994 - #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now + #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now #set visuals_c1 [tcl::dict::create\ # BPH [list \x82 "${ob8}\ue022 $cb8"]\ # NBH [list \x83 "${ob8}\ue023 $cb8"]\ @@ -6826,10 +6826,10 @@ tcl::namespace::eval punk::ansi::ansistring { set vis [format %c $asciidec] if {[dict exists $map_c0 $vis]} { set vis [dict get $map_c0 $vis] - } + } tcl::dict::set visuals_tags TAG$asciidec [list [format %c $i] "${obt}$vis${cbt}"] } - + set hack [tcl::dict::create] tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) @@ -6840,13 +6840,13 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::dict::set hack SOS [list \x98 "${ob8}\u2380 $cb8"] ;#Insertion Symbol from Miscellaneous Technical - 1 wide + pad tcl::dict::set hack ST [list \x9c "${ob8}\u2383 $cb8"] ;#Emphasis Symbol from Miscellaneous Technical - 1 wide + pad (graphically related to \u2380) tcl::dict::set hack CSI [list \x9b "${ob8}\u2386 $cb8"] ;#Enter Symbol from Miscellaneous Technical - 1 wide + pad - tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) + tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) tcl::dict::set hack PM [list \x9e "${ob8}PM$cb8"] tcl::dict::set hack APC [list \x9f "${ob8}\U1f534$cb8"] ;#bright red ball from Miscellaneoust Symbols and Pictographs - 2 wide (APC also noted as a potential security risk) set debug_visuals [tcl::dict::merge $visuals_c0 $visuals_c1 $hack $visuals_tags] - #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient + #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient proc NEW {string} { punk::ansi::class::class_ansistring new $string } @@ -6894,8 +6894,8 @@ tcl::namespace::eval punk::ansi::ansistring { # -lf 2, -vt 2 and -ff 2 are useful for CRM mode (Show Control Character Mode) in the terminal - where a newline is expected to display after the character. - set visuals_opt $debug_visuals - set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] + set visuals_opt $debug_visuals + set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] if {$opt_esc} { tcl::dict::set visuals_opt ESC [list \x1b \u241b] @@ -6949,7 +6949,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #The implementation of viewcodes,viewstyle is more efficiently done in an object for the case where repeated calls of various methods can re-use the internal splits. - #for oneshots here - there is only minor overhead to use and destroy the object here. + #for oneshots here - there is only minor overhead to use and destroy the object here. proc VIEWCODES {args} { set string [lindex $args end] if {$string eq ""} { @@ -6961,7 +6961,7 @@ tcl::namespace::eval punk::ansi::ansistring { $ansistr destroy return $result } - #an attempt to show the codes and colour/style of the *input* + #an attempt to show the codes and colour/style of the *input* #ie we aren't looking at the row/column positioning - but we do want to keep track of cursor attribute saves and restores proc VIEWSTYLE {args} { set string [lindex $args end] @@ -6993,16 +6993,16 @@ tcl::namespace::eval punk::ansi::ansistring { #stripping diacritics only makes sense if we are counting them as combiners and also treating unicode grapheme combinations as single entities. #as Our ansistring INDEX function returns the character with diacritics, and will ultimately return grapheme clusters as a single element - we strip theme here as not counted. #todo - combiners/diacritics? just map them away here? - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set string [regsub -all $re_diacritics $string ""] - #we want length to return number of glyphs.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs.. not screen width. Has to be consistent with index function tcl::string::length [ansistrip $string] } #included as a test/verification - slightly slower. #grapheme split version may end up being used once it supports unicode grapheme clusters proc count2 {string} { - #we want count to return number of glyphs.. not screen width. Has to be consistent with index function + #we want count to return number of glyphs.. not screen width. Has to be consistent with index function return [llength [punk::char::grapheme_split [ansistrip $string]]] } @@ -7077,7 +7077,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc - #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. + #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. proc trimleft {string args} { set intext 0 set out "" @@ -7103,19 +7103,19 @@ tcl::namespace::eval punk::ansi::ansistring { } proc trim {string} { #make sure we do our ansi-scanning split only once - so use list-based trim operations - #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length + #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length #we save a single function call by calling both here rather than _splits_trim join [_splits_trimright [_splits_trimleft [split_codes $string]]] "" } - #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index + #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index proc INDEX {string index} { #*** !doctools #[call [fun index] [arg string] [arg index]] #[para]Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes) #[para]Returns the character (with applied ansi effect) at position index #[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output. - #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) + #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) #[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them. #[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards. #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index. @@ -7194,8 +7194,8 @@ tcl::namespace::eval punk::ansi::ansistring { } #any pt could be empty if using split_codes_single (or just first and last pt if split_codes) - set low -1 - set high -1 + set low -1 + set high -1 set pt_index -2 set pt_found -1 set char "" @@ -7209,8 +7209,8 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { set graphemes [punk::char::grapheme_split $pt] - set low [expr {$high + 1}] ;#last high - #incr high [tcl::string::length $pt] + set low [expr {$high + 1}] ;#last high + #incr high [tcl::string::length $pt] incr high [llength $graphemes] } @@ -7220,14 +7220,14 @@ tcl::namespace::eval punk::ansi::ansistring { set char [lindex $graphemes $index-$low] break } - + if {[punk::ansi::codetype::is_sgr_reset $code]} { - #we can throw away previous codestack + #we can throw away previous codestack set codestack [list] } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { set codestack [list $code] } else { - #may have partial resets + #may have partial resets #sgr_merge_list will handle at end #we don't apply non SGR codes to our output. This is probably what is wanted - but should be reviewed. #Review - consider if any other types of code make sense to retain in the output in this context. @@ -7244,8 +7244,8 @@ tcl::namespace::eval punk::ansi::ansistring { } } - #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi - #return empty string for each index that is out of range + #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi + #return empty string for each index that is out of range #review - this is possibly too slow to be very useful as is. # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string #see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. @@ -7326,11 +7326,11 @@ tcl::namespace::eval punk::ansi::ansistring { #we now have numeric or empty string indices - but haven't fully checked they are within the underlying payload length if {[join $testindices ""] eq ""} { - #don't calc ansistring length if no indices to check + #don't calc ansistring length if no indices to check return $testindices } if {$payload_len == -1} { - set payload_len [punk::ansi::ansistring::length $string] + set payload_len [punk::ansi::ansistring::length $string] } set indices [list] foreach ti $testindices { @@ -7356,7 +7356,7 @@ tcl::namespace::eval punk::ansi::ansistring { #single-width grapheme will return pair of integers of equal value #doulbe-width grapheme will return a pair of consecutive indices proc INDEXCOLUMNS {string idx} { - #There is an index per grapheme - whether it is 1 or 2 columns wide + #There is an index per grapheme - whether it is 1 or 2 columns wide set index [lindex [INDEXABSOLUTE $string $idx] 0] if {$index eq ""} { return "" @@ -7377,7 +7377,7 @@ tcl::namespace::eval punk::ansi::ansistring { foreach ptline $ptlines { set graphemes [punk::char::grapheme_split $ptline] if {$ptlineindex > 0} { - #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column + #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column #zero width set low [expr {$high + 1}] set lowc [expr {$highc + 1}] @@ -7393,7 +7393,7 @@ tcl::namespace::eval punk::ansi::ansistring { set lowc 0 set highc 0 } - set low [expr {$high + 1}] ;#last high + set low [expr {$high + 1}] ;#last high set lowc [expr {$highc + 1}] set high [expr {$low + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $ptline] -1}] @@ -7435,7 +7435,7 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { if {[tcl::string::last \n $pt] < 0} { set graphemes [punk::char::grapheme_split $pt] - set lowindex [expr {$highindex + 1}] ;#last high + set lowindex [expr {$highindex + 1}] ;#last high set lowc [expr {$highc + 1}] set highindex [expr {$lowindex + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $pt] -1}] @@ -7527,7 +7527,7 @@ namespace eval punk::ansi::colour { #https://sourceforge.net/p/irrational-numbers/code/HEAD/tree/pkgs/Colors/trunk/colors.tcl#l159 - # classic formula for luminance (0.0 .. 100.0) + # classic formula for luminance (0.0 .. 100.0) proc luminance {R G B} { return [expr {(0.3*$R + 0.59*$G + 0.11*$B)/255.0}] } @@ -7536,9 +7536,9 @@ namespace eval punk::ansi::colour { proc contrasting {R G B} { set lum [luminance $R $G $B] if {$lum < 0.597} { - set lum 0.9 + set lum 0.9 } else { - set lum 0.2 + set lum 0.2 } lassign [RGB2hsl $R $G $B] h s l return [hsl2RGB $h $s $lum] @@ -7569,11 +7569,11 @@ namespace eval punk::ansi::colour { } foreach c {R G B} { - if {$T($c) < [expr {1.0/6.0}]} { + if {$T($c) < (1.0/6.0)} { set T($c) [expr {$P+($Q-$P)*6.0*$T($c)}] } elseif {$T($c) < 0.5} { set T($c) $Q - } elseif {$T($c) < [expr {2.0/3.0}]} { + } elseif {$T($c) < (2.0/3.0)} { set T($c) [expr {$P+($Q-$P)*(2.0/3.0-$T($c))*6.0}] } else { set T($c) $P @@ -7585,7 +7585,7 @@ namespace eval punk::ansi::colour { } proc RGB2hsl { R G B } { set r [expr {$R/255.0}] - set g [expr {$G/255.0}] + set g [expr {$G/255.0}] set b [expr {$B/255.0}] set max $r @@ -7611,7 +7611,7 @@ namespace eval punk::ansi::colour { } set L [expr {($max+$min)/2}] - + if { $L == 0.0 || $max == $min } { set S 0.0 } elseif { $L <= 0.5 } { @@ -7651,7 +7651,7 @@ namespace eval punk::ansi::colour { set Bmax 1 } set L [expr {($min + $max) / 2.0}] - set H 0.0 + set H 0.0 set S 0.0 #REVIEW - java allows floating point division by 0.0 - producing positive infinity, negative infinity or NaN #This makes the original java algorithm a little more obscure @@ -7757,9 +7757,9 @@ tcl::namespace::eval punk::ansi::internal { } proc printing_length_addchar {i c} { - upvar outchars outc + upvar outchars outc upvar outsizes outs - set nxt [llength $outc] + set nxt [llength $outc] if {$i < $nxt} { lset outc $i $c } else { @@ -7801,10 +7801,10 @@ namespace eval ::punk::args::register { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ansi [tcl::namespace::eval punk::ansi { 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/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index 74a3ffc8..25b01d81 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::args 0 0.1.0] #[copyright "2024"] #[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] #[require punk::args] #[keywords module proc args arguments parse] #[description] -#[para]Utilities for parsing proc args +#[para]Utilities for parsing proc args # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -53,8 +53,8 @@ # @cmd -help "do some stuff with files e.g dofilestuff " # @opts -type string # #comment lines ok -# -directory -default "" -# -translation -default binary +# -directory -default "" +# -translation -default binary # #setting -type none indicates a flag that doesn't take a value (solo flag) # -nocomplain -type none # @values -min 1 -max -1 @@ -62,26 +62,26 @@ # # puts "translation is [dict get $opts -translation]" # foreach f [dict values $values] { -# puts "doing stuff with file: $f" +# puts "doing stuff with file: $f" # } # } #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values #[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. #[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. #[para]e.g the result from the punk::args call above may be something like: #[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments #[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments #[example { # proc dofilestuff {category args} { # lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary +# -directory -default "" +# -translation -default binary # -nocomplain -type none -# @values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 # } $args]] leaders opts values @@ -89,16 +89,16 @@ # puts "$category fileB: [dict get $values fileB]" # } #}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 #[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, #[para] or an additional call could be made to punk::args e.g #[example { # punk::args::get_dict { -# category -choices {cat1 cat2 cat3} +# category -choices {cat1 cat2 cat3} # another_leading_arg -type boolean # } [list $category $another_leading_arg] -#}] +#}] #*** !doctools #[subsection Notes] @@ -111,8 +111,8 @@ # proc test_switch {args} { # set opts [dict create\\ # -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ +# -frametype "heavy"\\ +# -show_edge 1\\ # -show_seps 0\\ # -x a\\ # -y b\\ @@ -173,12 +173,12 @@ #[enum]The tcllib set of TEPAM modules (pure tcl) #[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. #[list_end] -#[para] (* c implementation planned/proposed) +#[para] (* c implementation planned/proposed) #[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. #[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences #[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. #[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. #[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. #[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. @@ -188,7 +188,7 @@ #All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 #as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. #(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) #ensembles: array binary clock dict info namespace string @@ -221,7 +221,7 @@ package require Tcl 8.6- tcl::namespace::eval punk::args::register { #*** !doctools #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register + #[para] cooperative namespace punk::args::register #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. #[list_begin definitions] @@ -257,15 +257,15 @@ tcl::namespace::eval punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args { - + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - tcl::namespace::export {[a-z]*} + tcl::namespace::export {[a-z]*} variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} variable id_cache_rawdef [tcl::dict::create] variable id_cache_spec [tcl::dict::create] - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) variable argdata_cache [tcl::dict::create] @@ -273,7 +273,7 @@ tcl::namespace::eval punk::args { #*** !doctools #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args + #[para] Core API functions for punk::args #[list_begin definitions] #todo - some sort of punk::args::cherrypick operation to get spec from an existing set @@ -283,10 +283,10 @@ tcl::namespace::eval punk::args { #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix #e.g - # -corner -aliases {-corners} + # -corner -aliases {-corners} # -centre -aliases {-center -middle} #We mightn't want the prefix to be longer just because of an alias #we should get -co -ce and -m from the above as abbreviations @@ -301,10 +301,10 @@ tcl::namespace::eval punk::args { Returns a dictionary representing the argument specifications. The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. + @id -id value from the supplied definition. This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. This can be used purely for documentation or called within a function to parse a mix of leading values, switches/flags and trailing values. @@ -325,7 +325,7 @@ tcl::namespace::eval punk::args { text if they are properly braced or double quoted and Tcl escaping for inner quotes or unbalanced braces is maintained. The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for + (\\ at the end of the line) can be used to continue the set of arguments for a leading word. Leading words beginning with the @ character are directives controlling argument parsing and help display. @@ -347,13 +347,13 @@ tcl::namespace::eval punk::args { -body (text to replace autogenerated arg info) %B%@doc%N% ?opt val...? options: -name -url - %B%@seealso%N% ?opt val...? + %B%@seealso%N% ?opt val...? options: -name -url (for footer - unimplemented) Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults + to use with the @leaders @opts @values directives to set defaults for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be + These directives should occur in exactly this order - but can be repeated with custom argument lines interspersed. An @id line can only appear once and should be the first item. @@ -365,17 +365,17 @@ tcl::namespace::eval punk::args { Custom arguments are defined by using any word at the start of a line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so + (except that adding an additionl @ escapes this restriction so that @@somearg becomes an argument named @somearg) custom leading args, switches/options (names starting with -) and trailing values also take options: - -type + -type defaults to string. If no other restrictions - are specified, choosing string does the least validation. + are specified, choosing string does the least validation. recognised types: - none + none (used for switches only. Indicates this is a 'solo' flag ie accepts no value) int|integer @@ -400,14 +400,14 @@ tcl::namespace::eval punk::args { -default -multiple (for leaders & values defines whether subsequent received values are stored agains the same - argument name - only applies to final leader or value) + argument name - only applies to final leader or value) (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - no necessarily contiguously) + flag to appear multiple times - no necessarily contiguously) -choices {} A list of allowable values for an argument. The -default value doesn't have to be in the list. If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted + It will only be used for validation if the -choicerestricted option is set to false. -choicerestricted Whether values not specified in -choices or -choicegroups are @@ -421,7 +421,7 @@ tcl::namespace::eval punk::args { These choices should match exactly a choice entry in one of the settings -choices or -choicegroups. These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. + choice argument must be entered to select the choice. -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name. @@ -446,7 +446,7 @@ tcl::namespace::eval punk::args { " -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} are re-evaluated on each call. If the definition is being used not just as documentation, but is also used within the function to parse args, e.g using punk::args::get_by_id, @@ -463,7 +463,7 @@ tcl::namespace::eval punk::args { Using multiple text arguments may be useful to mix curly-braced and double-quoted strings to have finer control over interpolation when defining arguments. (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) + from existing definitions (by id) for re-use of argument specifications and help text) e.g the following definition passes 2 blocks as text arguments definition { @@ -486,7 +486,7 @@ tcl::namespace::eval punk::args { #Items that don't begin with * or - are value definitions v1 -type integer -default 0 thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" " }]] @@ -519,7 +519,7 @@ tcl::namespace::eval punk::args { -multiple 0\ -regexprepass {}\ -validationtransform {}\ - ] + ] set valspec_defaults [tcl::dict::create\ -type string\ -optional 0\ @@ -618,7 +618,7 @@ tcl::namespace::eval punk::args { variable argdefcache_unresolved - set cache_key $args + set cache_key $args #ideally we would use a fast hash algorithm to produce a short key with low collision probability. #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) #review - check if there is a built-into-tcl way to do this quickly @@ -668,8 +668,8 @@ tcl::namespace::eval punk::args { foreach a $textargs { lappend normargs [tcl::string::map {\r\n \n} $a] } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + set optionspecs [join $normargs \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 @@ -692,7 +692,7 @@ tcl::namespace::eval punk::args { #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices #default to 1 for convenience - #checks with no default + #checks with no default #-minsize -maxsize -range @@ -729,13 +729,13 @@ tcl::namespace::eval punk::args { #ansi colours can stop info complete from working (contain square brackets) #review - when exactly are ansi codes allowed/expected in record lines. # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket if {$has_punkansi} { set test_complete [punk::ansi::ansistrip $recordsofar] } else { - #review + #review #we only need to strip enough to stop interference with 'info complete' set test_complete [string map [list \x1b\[ ""] $recordsofar] } @@ -743,7 +743,7 @@ tcl::namespace::eval punk::args { #append linebuild [string trimleft $rawline] \n if {$in_record} { #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) @@ -761,7 +761,7 @@ tcl::namespace::eval punk::args { set in_record 1 regexp {(\s*).*} $rawline _all lastindent #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " + #puts "indent from rawline:$rawline " append linebuild $rawline \n } } else { @@ -769,14 +769,14 @@ tcl::namespace::eval punk::args { #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left if {[tcl::string::first "$lastindent " $rawline] == 0} { set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline + append linebuild $trimmedline } elseif {[tcl::string::first $lastindent $rawline] == 0} { set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline + append linebuild $trimmedline } else { append linebuild $rawline } - lappend records $linebuild + lappend records $linebuild set linebuild "" } } @@ -793,7 +793,7 @@ tcl::namespace::eval punk::args { #(common case of no leaders specified) set opt_any 0 set val_min 0 - set val_max -1 ;#-1 for no limit + set val_max -1 ;#-1 for no limit set DEF_definition_id $id #form_defs @@ -805,14 +805,14 @@ tcl::namespace::eval punk::args { set refs [dict create] set record_type "" - set record_number -1 ;# + set record_number -1 ;# foreach rec $records { set trimrec [tcl::string::trim $rec] switch -- [tcl::string::index $trimrec 0] { "" - # {continue} } incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict if {[llength $record_values] % 2 != 0} { #todo - avoid raising an error - store invalid defs keyed on id error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" @@ -853,19 +853,19 @@ tcl::namespace::eval punk::args { set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] + set form_ids_active [lindex $record_form_ids 0] } } foreach fid $record_form_ids { if {![dict exists $F $fid]} { if {$firstword eq "@form"} { - #only @form directly supplies keys + #only @form directly supplies keys dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] } else { dict set F $fid [New_command_form $fid] } } else { - #update form with current record opts, except -form + #update form with current record opts, except -form if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } } } @@ -912,7 +912,7 @@ tcl::namespace::eval punk::args { #global reference dict - independent of forms #ignore refs without an -id #store all keys except -id - #complete overwrite if refid repeated later on + #complete overwrite if refid repeated later on if {[dict exists $at_specs -id]} { dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] } @@ -938,7 +938,7 @@ tcl::namespace::eval punk::args { set doc_info [dict get $copyfrom doc_info] } foreach fid $record_form_ids { - #only use elements with matching form id? + #only use elements with matching form id? #probably this feature mainly useful for _default anyway so that should be ok #cooperative doc sets specified in same file could share via known form ids too #todo argdisplay_info by fid @@ -964,7 +964,7 @@ tcl::namespace::eval punk::args { # {4 anykeys {3 by}} # {5 anykeys {1 .. 1 to 3 by}} # }\ - # -fallback 1 + # -fallback 1 # ... # @parser -synopsis "start 'count' count ??'by'? step?"\ # -arities { @@ -976,7 +976,7 @@ tcl::namespace::eval punk::args { # 1 # {3 anykeys {1 by}} # } - # + # # see also after manual # @form -arities {1} # @form -arities { @@ -990,9 +990,9 @@ tcl::namespace::eval punk::args { if {[dict exists $at_specs -form]} { set idlist [dict get $at_specs -form] if {$idlist eq "*"} { - #* only applies to form ids that exist at the time + #* only applies to form ids that exist at the time set idlist [dict keys $F] - } + } set form_ids_active $idlist } #new form keys already created if they were needed (done for all records that have -form ) @@ -1001,7 +1001,7 @@ tcl::namespace::eval punk::args { set package_info [dict merge $package_info $at_specs] } cmd { - #allow arbitrary - review + #allow arbitrary - review set cmd_info [dict merge $cmd_info $at_specs] } doc { @@ -1009,7 +1009,7 @@ tcl::namespace::eval punk::args { } argdisplay { #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing set argdisplay_info [dict merge $argdisplay_info $at_specs] } opts { @@ -1063,8 +1063,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1154,8 +1154,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1246,8 +1246,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1315,12 +1315,12 @@ tcl::namespace::eval punk::args { foreach fid $record_form_ids { if {[dict get $F $fid argspace] eq "leaders"} { set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader + tcl::dict::set argdef_values -ARGTYPE leader #lappend leader_names $argname set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] if {$argname ni $temp_leadernames} { lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames } else { error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" } @@ -1330,7 +1330,7 @@ tcl::namespace::eval punk::args { } } else { set record_type value - tcl::dict::set argdef_values -ARGTYPE value + tcl::dict::set argdef_values -ARGTYPE value set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] lappend temp_valnames $argname tcl::dict::set F $fid VAL_NAMES $temp_valnames @@ -1370,7 +1370,7 @@ tcl::namespace::eval punk::args { tcl::dict::set spec_merged -type int } bool - boolean { - tcl::dict::set spec_merged -type bool + tcl::dict::set spec_merged -type bool } char - character { tcl::dict::set spec_merged -type char @@ -1386,7 +1386,7 @@ tcl::namespace::eval punk::args { } lappend opt_solos $argname } else { - #-solo only valid for flags + #-solo only valid for flags error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } } @@ -1444,7 +1444,7 @@ tcl::namespace::eval punk::args { set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id } else { if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] } else { puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" } @@ -1464,10 +1464,10 @@ tcl::namespace::eval punk::args { if {$is_opt} { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } else { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } tcl::dict::set F $fid ARG_INFO $argname $spec_merged #review existence of -default overriding -optional @@ -1496,7 +1496,7 @@ tcl::namespace::eval punk::args { } } } - } ;# end foreach fid record_form_ids + } ;# end foreach fid record_form_ids } ;# end foreach rec $records @@ -1527,9 +1527,9 @@ tcl::namespace::eval punk::args { #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } @@ -1547,17 +1547,17 @@ tcl::namespace::eval punk::args { #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - #in the above case we have no unique total_arity + #in the above case we have no unique total_arity #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" + #e.g given the invalid command "after cancel" # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from + #e.g commandline completion could show list of synopsis entries to select from set form_info [dict create] dict for {fid fdict} $F { @@ -1619,7 +1619,7 @@ tcl::namespace::eval punk::args { #return raw definition list as created with 'define' # - possibly with unresolved dynamic parts proc raw_def {id} { - variable id_cache_rawdef + variable id_cache_rawdef set realid [real_id $id] if {![dict exists $id_cache_rawdef $realid]} { return "" @@ -1632,8 +1632,8 @@ tcl::namespace::eval punk::args { variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} variable resolved_def_TYPE_CHOICEGROUPS { directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} } lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { @@ -1643,35 +1643,35 @@ tcl::namespace::eval punk::args { uses the 'spec' form to build a response in definition format. Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with + of tight coupling to the other function that should be done with care. Note that the directives @leaders @opts @values may appear multiple times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for + follow. When retrieving these - there is only a single result for each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before + When retrieving -types * each of these will be positioned before the arguments of that type - but this doesn't mean there was a single leading directive for this argument type in the source definition. Each argument has already had its complete specification recorded in its own result. - + When manually specifying -types, the order @leaders then @opts then @values must be maintained - but if they are placed before their corresponding arguments, they will not affect the retrieved arguments as these arguments are already fully spec'd. The defaults from the source can be removed by adding @leaders, @opts @values to the -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the + Each argument can have members of its spec overridden using the -override dictionary. " @leaders -min 0 -max 0 @opts -form -default 0 -help\ - "Ordinal index or name of command form" + "Ordinal index or name of command form" #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} -antiglobs -default {} -type list -help\ "Glob patterns for directive or argument/flags to be suppressed" @@ -1687,7 +1687,7 @@ tcl::namespace::eval punk::args { path for a command name" pattern -type string -optional 1 -default * -multiple 1 -help\ "glob-style patterns for retrieving value or switch - definitions. + definitions. If -type is * and pattern is * the entire definition including directive lines will be returned in line form. @@ -1698,8 +1698,8 @@ tcl::namespace::eval punk::args { will be returned. if -type is another directive such as @id, @doc etc the - patterns are ignored. - + patterns are ignored. + " }]] } @@ -1718,7 +1718,7 @@ tcl::namespace::eval punk::args { return } set patterns [list] - + #a definition id must not begin with "-" ??? review for {set i 0} {$i < [llength $args]} {incr i} { set a [lindex $args $i] @@ -1730,7 +1730,7 @@ tcl::namespace::eval punk::args { dict set opts $a [lindex $args $i] } else { set id [lindex $args $i] - set patterns [lrange $args $i+1 end] + set patterns [lrange $args $i+1 end] break } if {$i == [llength $args]-1} { @@ -1781,7 +1781,7 @@ tcl::namespace::eval punk::args { #set arg_info [dict get $specdict ARG_INFO] set arg_info [dict get $specdict FORMS $formname ARG_INFO] set argtypes [dict create leaders leader opts option values value] - + set opt_antiglobs [dict get $opts -antiglobs] set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] set suppressed_directives [list] @@ -1822,7 +1822,7 @@ tcl::namespace::eval punk::args { } } foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] + set dshort [string range $directive 1 end] if {"$directive" in $included_directives} { if {[dict exists $opt_override $directive]} { append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" @@ -1832,8 +1832,8 @@ tcl::namespace::eval punk::args { } } #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" switch -- $directive { @leaders {set defaults_key leaderspec_defaults} @opts {set defaults_key optspec_defaults} @@ -1925,7 +1925,7 @@ tcl::namespace::eval punk::args { } proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef + variable id_cache_rawdef set realid [real_id $id] if {$realid ne ""} { set speclist [tcl::dict::get $id_cache_rawdef $realid] @@ -1971,7 +1971,7 @@ tcl::namespace::eval punk::args { set deflist [raw_def $id] if {[dict exists $rawdef_cache $deflist -dynamic]} { return [dict get $rawdef_cache $deflist -dynamic] - } + } return [rawdef_is_dynamic $deflist] #@dynamic only has meaning as 1st element of a def in the deflist } @@ -2042,7 +2042,7 @@ tcl::namespace::eval punk::args { if {[tcl::dict::exists $aliases $id]} { return 1 } - variable id_cache_rawdef + variable id_cache_rawdef tcl::dict::exists $id_cache_rawdef $id } proc set_alias {alias id} { @@ -2061,7 +2061,7 @@ tcl::namespace::eval punk::args { } proc real_id {id} { - variable id_cache_rawdef + variable id_cache_rawdef variable aliases if {[tcl::dict::exists $aliases $id]} { set id [tcl::dict::get $aliases $id] @@ -2126,7 +2126,7 @@ tcl::namespace::eval punk::args { } append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" return $result } @@ -2136,7 +2136,7 @@ tcl::namespace::eval punk::args { if {[set gposn [lsearch $nslist {}]] >= 0} { lset nslist $gposn :: } - upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::NAMESPACES registered ;#list upvar ::punk::args::register::loaded_packages loaded_packages ;#list upvar ::punk::args::register::loaded_info loaded_info ;#dict upvar ::punk::args::register::scanned_packages scanned_packages ;#list @@ -2149,7 +2149,7 @@ tcl::namespace::eval punk::args { #e.g - gets called for each subcommand of an ensemble (could be many) # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- + # -- --- --- --- --- --- # common-case fast-path if {[llength $loaded_packages] == [llength $registered]} { @@ -2157,7 +2157,7 @@ tcl::namespace::eval punk::args { #assert - if all are registered - then all have been scanned ( return {} } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set unscanned [punklib_ldiff $registered $scanned_packages] if {[llength $unscanned]} { @@ -2191,7 +2191,7 @@ tcl::namespace::eval punk::args { dict lappend namespace_docpackages $documentedns $pkgns } lappend seen_documentedns $documentedns - } + } } } set ts_end [clock microseconds] @@ -2218,7 +2218,7 @@ tcl::namespace::eval punk::args { set docns ${pkgns}::argdoc if {[namespace exists $docns]} { if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns + lappend needed $docns } } if {[dict exists $namespace_docpackages $pkgns]} { @@ -2247,7 +2247,7 @@ tcl::namespace::eval punk::args { set epath [namespace path] set pkgns [namespace parent] if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail + namespace path [list {*}$epath $pkgns] ;#add to tail } } @@ -2259,7 +2259,7 @@ tcl::namespace::eval punk::args { namespace eval $evalns [list punk::args::define {*}$definitionlist] incr def_count } - } + } #process list of 2-element lists if {[info exists ${pkgns}::PUNKARGS_aliases]} { @@ -2322,7 +2322,7 @@ tcl::namespace::eval punk::args { # -------------------------------------- - #test of Get_caller + #test of Get_caller lappend PUNKARGS [list { @id -id ::punk::args::test1 @values -min 0 -max 0 @@ -2357,16 +2357,16 @@ tcl::namespace::eval punk::args { @cmd -name punk::args::arg_error -help\ "Generates a table (by default) of usage information for a command. A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept + switches and for subcommands or argument/switch values that accept a defined set of choices. These prefixes match the mechanism used to validate arguments (based on tcl::prefix::match). - This function is called during the argument parsing process + This function is called during the argument parsing process (if the definition is not only being used for documentation) It is also called by punk::args::usage which is in turn called by the punk::ns introspection facilities which creates on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. + oo objects where a manually defined one isn't present. " @leaders -min 2 -max 2 msg -type string -help\ @@ -2399,21 +2399,21 @@ tcl::namespace::eval punk::args { proc arg_error {msg spec_dict args} { #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. + #may be desirable to reduce overhead on catches. #consider per-namespace or namespace-tree configurability. #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. + #to resource availability etc - so the slower error generation time may not always be a problem. #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling #code which has no use for the enhanced error info. #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system #todo #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #todo - document unnamed leaders and unnamed values where -min and/or -max specified #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} #only |?-x?|string|... is shown in the output table. #should be something like: @@ -2435,7 +2435,7 @@ tcl::namespace::eval punk::args { namespace import ::punk::ansi::a ::punk::ansi::a+ } } - #limit colours to standard 16 so that themes can apply to help output + #limit colours to standard 16 so that themes can apply to help output variable arg_error_isrunning if {$arg_error_isrunning} { error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" @@ -2448,7 +2448,7 @@ tcl::namespace::eval punk::args { set arg_error_isrunning 1 set badarg "" - set returntype table ;#table as string + set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error set scheme error dict for {k v} $args { @@ -2487,14 +2487,14 @@ tcl::namespace::eval punk::args { } info - error {} default { - set scheme na + set scheme na } } #hack some basics for now. #for coloured schemes - use bold as well as brightcolour in case colour off. array set CLR {} set CLR(errormsg) [a+ brightred] - set CLR(title) "" + set CLR(title) "" set CLR(check) [a+ brightgreen] set CLR(solo) [a+ brightcyan] set CLR(choiceprefix) [a+ underline] @@ -2503,20 +2503,20 @@ tcl::namespace::eval punk::args { set CLR(cmdname) [a+ brightwhite] set CLR(groupname) [a+ bold] set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] switch -- $scheme { nocolour { set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] + set CLR(title) [a+ bold] set CLR(check) "" set CLR(solo) "" set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] + set CLR(cmdname) [a+ bold] set CLR(linebase_header) "" set CLR(linebase) "" - set CLR(ansibase_body) "" + set CLR(ansibase_body) "" } info { set CLR(errormsg) [a+ brightred bold] @@ -2525,8 +2525,8 @@ tcl::namespace::eval punk::args { set CLR(choiceprefix) [a+ brightgreen bold] set CLR(groupname) [a+ cyan bold] set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] } error { set CLR(errormsg) [a+ brightred bold] @@ -2535,8 +2535,8 @@ tcl::namespace::eval punk::args { set CLR(choiceprefix) [a+ brightgreen bold] set CLR(groupname) [a+ cyan bold] set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] } na { } @@ -2547,7 +2547,7 @@ tcl::namespace::eval punk::args { set RST "\x1b\[m" set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error #e.g list_as_table # use basic colours here to support terminals without extended colours @@ -2629,8 +2629,8 @@ tcl::namespace::eval punk::args { } if {$use_table} { set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col if {!$is_custom_argdisplay} { lappend blank_header_col "" @@ -2708,9 +2708,9 @@ tcl::namespace::eval punk::args { $t add_row [list "" $argdisplay_body] } else { if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header + lappend errlines $argdisplay_header } - lappend errlines {*}$argdisplay_body + lappend errlines {*}$argdisplay_body } } else { @@ -2719,18 +2719,18 @@ tcl::namespace::eval punk::args { set A_BADARG $CLR(badarg) set greencheck $CLR(check)\u2713$RST ;#green tick set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space } else { - set A_PREFIXEND $RST + set A_PREFIXEND $RST } set opt_names [list] - set opt_names_display [list] + set opt_names_display [list] if {[llength [dict get $spec_dict OPT_NAMES]]} { if {![catch {package require punk::trie}]} { set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] @@ -2752,14 +2752,14 @@ tcl::namespace::eval punk::args { lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] lappend opt_names $c - } + } } else { set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names + set opt_names_display $opt_names } } set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { # if {![string match -* $argname]} { @@ -2773,8 +2773,8 @@ tcl::namespace::eval punk::args { # set trailing_val_names $leading_val_names # set leading_val_names {} #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names #display options first then values foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { @@ -2788,7 +2788,7 @@ tcl::namespace::eval punk::args { set default "" } set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] + set allchoices_originalcase [list] set choices [Dict_getdef $arginfo -choices {}] set choicegroups [Dict_getdef $arginfo -choicegroups {}] set choicemultiple [dict get $arginfo -choicemultiple] @@ -2799,7 +2799,7 @@ tcl::namespace::eval punk::args { set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck + set multiple $greencheck set is_multiple 1 } else { set multiple "" @@ -2865,11 +2865,11 @@ tcl::namespace::eval punk::args { set idents [dict get [$trie shortest_idents ""] scanned] if {[dict get $arginfo -nocase]} { #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents + set actual_idents $idents foreach ch $allchoices_originalcase { if {![dict exists $idents $ch]} { #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict + #The actual testing is done in get_dict dict set actual_idents $ch [dict get $idents [string tolower $ch]] } } @@ -2899,12 +2899,12 @@ tcl::namespace::eval punk::args { append cdisplay \n [dict get $choicelabeldict $c] } dict lappend formattedchoices $groupname $cdisplay - } + } } } errM]} { #this failure can happen if -nocase is true and there are ambiguous entries #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" + puts stderr "prefix marking failed\n$errM" #append help "\n " [join [dict get $arginfo -choices] "\n "] if {[dict size $choicelabeldict]} { dict for {groupname clist} $choicegroups { @@ -2917,9 +2917,9 @@ tcl::namespace::eval punk::args { } } } else { - set formattedchoices $choicegroups + set formattedchoices $choicegroups } - + } } set choicetable_objects [list] @@ -2932,7 +2932,7 @@ tcl::namespace::eval punk::args { } if {$numcols > 0} { if {$use_table} { - #risk of recursing + #risk of recursing #TODO -title directly in list_as_table set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] lappend choicetable_objects $choicetableobj @@ -3053,7 +3053,7 @@ tcl::namespace::eval punk::args { -ansibase_body $CLR(ansibase_body)\ -ansibase_header $CLR(ansibase_header)\ -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) + -ansiborder_body $CLR(ansiborder) $t configure -maxwidth 80 ;#review if {$returntype ne "tableobject"} { @@ -3073,7 +3073,7 @@ tcl::namespace::eval punk::args { } set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) if {$use_table} { #assert returntype is one of table, tableobject @@ -3081,7 +3081,7 @@ tcl::namespace::eval punk::args { if {$returntype eq "tableobject"} { if {[info object isa object $t]} { set result $t - } + } } } else { set result $errmsg @@ -3109,8 +3109,8 @@ tcl::namespace::eval punk::args { IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. " -return -default table -choices {string table tableobject} } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { @@ -3136,7 +3136,7 @@ tcl::namespace::eval punk::args { @values -min 1 id arglist -type list -help\ - "list containing arguments to be parsed as per the + "list containing arguments to be parsed as per the argument specification identified by the supplied id." }] @@ -3154,7 +3154,7 @@ tcl::namespace::eval punk::args { #consider #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withid $id #parse ?-flag val?... -- $arglist withdef $def ?$def?... #an experiment.. ideally we'd like arglist at the end? @@ -3179,15 +3179,15 @@ tcl::namespace::eval punk::args { form1: parse $arglist ?-flag val?... withid $id form2: parse $arglist ?-flag val?... withdef $def ?$def? see punk::args::define" - @form -form {withid withdef} + @form -form {withid withdef} @leaders -min 1 -max 1 arglist -type list -optional 0 -help\ "Arguments to parse - supplied as a single list" - @opts + @opts -form -type list -default * -help\ "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a + Forms are the orthogonal sets of arguments a command can take - usually described in 'synopsis' entries." #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance @@ -3206,16 +3206,16 @@ tcl::namespace::eval punk::args { @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" withdef -type literal -help\ "The literal value 'withdef'" - + #todo - make -dynamic obsolete - use @dynamic directive instead def -type string -multiple 1 -optional 0 -help\ "Each remaining argument is a block of text defining argument definitions. - As a special case, -dynamic may be + As a special case, -dynamic may be specified as the 1st 2 arguments. These are treated as an indicator to punk::args about how to process the definition." - + }] proc parse {args} { set tailtype "" ;#withid|withdef @@ -3225,7 +3225,7 @@ tcl::namespace::eval punk::args { set parseargs [lindex $args 0] set tailargs [lrange $args 1 end] - set split [lsearch -exact $tailargs withid] + set split [lsearch -exact $tailargs withid] if {$split < 0} { set split [lsearch -exact $tailargs withdef] if {$split < 0} { @@ -3240,7 +3240,7 @@ tcl::namespace::eval punk::args { set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" + error "punk::args::parse Even number of -flag val pairs required after arglist" } set defaultopts [dict create\ -form {*}\ @@ -3253,7 +3253,7 @@ tcl::namespace::eval punk::args { } default { #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" } } } @@ -3312,7 +3312,7 @@ tcl::namespace::eval punk::args { } else { set arglist $a set got_arglist 1 - set tailtype [lindex $args $i+1] + set tailtype [lindex $args $i+1] if {$tailtype eq "withid"} { if {[llength $args] != $i+3} { error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" @@ -3335,7 +3335,7 @@ tcl::namespace::eval punk::args { } #assert tailtype eq withid|withdef if {$tailtype eq "withid"} { - #assert $id was provided + #assert $id was provided return "parse [llength $arglist] args withid $id, options:$opts" } else { #assert llength deflist >=1 @@ -3356,8 +3356,8 @@ tcl::namespace::eval punk::args { #see arg_error regarding considerations around unhappy-path performance #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? #can the above be made completely unambiguous for arbitrary arglist?? #e.g what if arglist = withdef and the first $def is also withdef ? @@ -3373,11 +3373,11 @@ tcl::namespace::eval punk::args { #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values #[para]Each optionspec line defining a flag must be of the form: #[para]-optionname -key val -key2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional #[para]Each optionspec line defining a positional argument is of the form: #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. #[arg_def list rawargs] @@ -3386,13 +3386,13 @@ tcl::namespace::eval punk::args { #[list_end] #[para] - #consider line-processing example below for which we need info complete to determine record boundaries + #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { # @opts # -opt1 -default {} # -opt2 -default { # etc - # } + # } # @values -multiple 1 #} $args @@ -3402,7 +3402,7 @@ tcl::namespace::eval punk::args { #if definition has been seen before, #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] # ----------------------------------------------- @@ -3415,7 +3415,7 @@ tcl::namespace::eval punk::args { set flagsreceived [list] ;#for checking if required flags satisfied #secondary purpose: #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. - #-default value must not be appended to if argname not yet in flagsreceived + #-default value must not be appended to if argname not yet in flagsreceived #todo: -minmultiple -maxmultiple ? @@ -3440,9 +3440,9 @@ tcl::namespace::eval punk::args { } if {$ridx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] + set leader_posn_name [lindex $LEADER_NAMES $ridx] if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 + set is_multiple 1 } } elseif {$ridx > [llength $LEADER_NAMES]-1} { #beyond names - retain name if -multiple was true @@ -3468,7 +3468,7 @@ tcl::namespace::eval punk::args { if {$leader_posn_name ne ""} { #there is a named leading positional for this position #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name incr ridx continue @@ -3480,7 +3480,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader + #optional leader #most adhoc arg processing will allocate based on number of args rather than matching choice values first #(because a choice value could be a legitimate data value) @@ -3501,19 +3501,19 @@ tcl::namespace::eval punk::args { if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { break } else { - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { #required if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional + #already accepted at least one value - requirement satisfied - now equivalent to optional if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { break - } + } } #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -3522,8 +3522,8 @@ tcl::namespace::eval punk::args { if {$ridx > $LEADER_MIN} { break } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -3553,7 +3553,7 @@ tcl::namespace::eval punk::args { #assert - rawargs has been reduced by leading positionals set leaders [list] - set arglist {} + set arglist {} set post_values {} #val_min, val_max #puts stderr "rawargs: $rawargs" @@ -3565,7 +3565,7 @@ tcl::namespace::eval punk::args { set vals_total_possible [llength $rawargs] set vals_remaining_possible $vals_total_possible } else { - set vals_total_possible $val_max + set vals_total_possible $val_max set vals_remaining_possible $vals_total_possible } for {set i 0} {$i <= $maxidx} {incr i} { @@ -3573,7 +3573,7 @@ tcl::namespace::eval punk::args { set remaining_args_including_this [expr {[llength $rawargs] - $i}] #lowest val_min is 0 if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here + # if current arg is -- it will pass through as a value here set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] break @@ -3586,7 +3586,7 @@ tcl::namespace::eval punk::args { if {$val_max != -1} { #finite max number of vals if {$remaining_args_including_this == $val_max} { - #assume it's a value. + #assume it's a value. set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] } else { @@ -3626,7 +3626,7 @@ tcl::namespace::eval punk::args { tcl::dict::lappend opts $fullopt $flagval } } else { - tcl::dict::set opts $fullopt $flagval + tcl::dict::set opts $fullopt $flagval } #incr i to skip flagval incr vals_remaining_possible -2 @@ -3664,21 +3664,21 @@ tcl::namespace::eval punk::args { } if {$opt_any} { set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS if {[tcl::dict::get $argstate $a -type] ne "none"} { if {[tcl::dict::get $argstate $a -multiple]} { tcl::dict::lappend opts $a $newval } else { - tcl::dict::set opts $a $newval + tcl::dict::set opts $a $newval } if {[incr i] > $maxidx} { arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a } incr vals_remaining_possible -2 } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none if {[tcl::dict::get $argstate $a -multiple]} { if {![tcl::dict::exists $opts $a]} { tcl::dict::set opts $a 1 @@ -3702,7 +3702,7 @@ tcl::namespace::eval punk::args { } } } else { - #not flaglike + #not flaglike set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] break @@ -3759,9 +3759,9 @@ tcl::namespace::eval punk::args { } set validx 0 - set in_multiple "" + set in_multiple "" set valnames_received [list] - set values_dict $val_defaults + set values_dict $val_defaults set num_values [llength $values] foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { @@ -3775,9 +3775,9 @@ tcl::namespace::eval punk::args { } else { tcl::dict::lappend values_dict $valname $val } - set in_multiple $valname + set in_multiple $valname } else { - tcl::dict::set values_dict $valname $val + tcl::dict::set values_dict $valname $val } lappend valnames_received $valname } else { @@ -3826,14 +3826,14 @@ tcl::namespace::eval punk::args { } } - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. - #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? @@ -3841,10 +3841,10 @@ tcl::namespace::eval punk::args { #struct::set difference {x} {a b} #normal interp 0.18 u2 vs safe interp 9.4us #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" #} #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { @@ -3907,7 +3907,7 @@ tcl::namespace::eval punk::args { } #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels @@ -3930,7 +3930,7 @@ tcl::namespace::eval punk::args { } #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - + switch -- [tcl::dict::get $thisarg -ARGTYPE] { leader { @@ -3973,7 +3973,7 @@ tcl::namespace::eval punk::args { if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } + } #----------------------------------- set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list @@ -3997,14 +3997,14 @@ tcl::namespace::eval punk::args { set choice_exact_match 0 if {$c_check in $allchoices} { #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check + set chosen $c_check set choice_in_list 1 set choice_exact_match 1 } elseif {$v_test in $choices_test} { #assert - if we're here, nocase must be true #we know choice is present as full-length match except for case #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #we don't set choice_exact_match - because we will need to override the optimistic existing val below #review foreach avail [lsort -unique $allchoices] { if {[string match -nocase $c $avail]} { @@ -4014,7 +4014,7 @@ tcl::namespace::eval punk::args { #assert chosen will always get set set choice_in_list 1 } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. #in this block we can treat empty result from prefix match as a non-match if {$nocase} { @@ -4033,7 +4033,7 @@ tcl::namespace::eval punk::args { set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] + set choice_in_list [expr {$chosen ne ""}] } else { set chosen $bestmatch set choice_in_list 1 @@ -4057,7 +4057,7 @@ tcl::namespace::eval punk::args { } #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { + if {$choice_in_list && !$choice_exact_match} { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { if {$is_multiple} { set existing [tcl::dict::get [set $dname] $argname] @@ -4091,7 +4091,7 @@ tcl::namespace::eval punk::args { # lset existing $idx $v_test # tcl::dict::set $dname $argname $existing #} else { - # tcl::dict::set $dname $argname $v_test + # tcl::dict::set $dname $argname $v_test #} lappend vlist_validate $c lappend vlist_check_validate $c_check @@ -4186,10 +4186,10 @@ tcl::namespace::eval punk::args { string - ansistring - globstring { #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail @@ -4197,7 +4197,7 @@ tcl::namespace::eval punk::args { set pass_quick_list_e [list] set pass_quick_list_e_check [list] set remaining_e $vlist - set remaining_e_check $vlist_check + set remaining_e_check $vlist_check #review - order of -regexprepass and -regexprefail in original rawargs significant? #for now -regexprepass always takes precedence if {$regexprepass ne ""} { @@ -4225,7 +4225,7 @@ tcl::namespace::eval punk::args { } switch -- $type { ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi #.. so we need to look at the original values in $vlist not $vlist_check #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? @@ -4271,7 +4271,7 @@ tcl::namespace::eval punk::args { } } int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive if {[tcl::dict::exists $thisarg -range]} { lassign [tcl::dict::get $thisarg -range] low high if {"$low$high" ne ""} { @@ -4290,7 +4290,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } - #highside unspecified - check only low + #highside unspecified - check only low if {$e_check < $low} { arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname } @@ -4300,7 +4300,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } - #high and low specified + #high and low specified if {$e_check < $low || $e_check > $high} { arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname } @@ -4312,7 +4312,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname } - } + } } } double { @@ -4465,7 +4465,7 @@ tcl::namespace::eval punk::args { set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] if {[llength $receivednames]} { #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] set i -1 set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] } else { @@ -4474,15 +4474,15 @@ tcl::namespace::eval punk::args { #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) #(e.g using 'dict exists $received -flag') # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements + #It is actually a list of paired elements return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] } #proc sample1 {p1 args} { # #*** !doctools # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" + # #[para]Description of sample1 + # return "ok" #} @@ -4513,14 +4513,14 @@ tcl::namespace::eval punk::args::lib { tcl::namespace::path [list [tcl::namespace::parent]] #*** !doctools #[subsection {Namespace punk::args::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 + # #[para]Description of utility1 + # return 1 #} proc flatzip {l1 l2} { @@ -4540,8 +4540,8 @@ tcl::namespace::eval punk::args::lib { lsearch -all [lrepeat $count 0] * } } - - + + #experiment with equiv of js template literals with ${expression} in templates #e.g tstr {This is the value of x in calling scope ${$x} !} #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} @@ -4552,7 +4552,7 @@ tcl::namespace::eval punk::args::lib { "A rough equivalent of js template literals Substitutions: - \$\{$varName\} + \$\{$varName\} \$\{[myCommand]\} (when -allowcommands flag is given)" -allowcommands -default 0 -type none -help\ @@ -4569,7 +4569,7 @@ tcl::namespace::eval punk::args::lib { -paramindents -default line -choices {none line position} -choicelabels { line\ " Use leading whitespace in - the line in which the + the line in which the placeholder occurs." position\ " Use the position in @@ -4578,21 +4578,21 @@ tcl::namespace::eval punk::args::lib { none\ " No indents applied to subsequent placeholder value - lines. This will usually - result in text awkwardly + lines. This will usually + result in text awkwardly ragged unless the source code has also been aligned with the left margin or the value has been manually padded." } -help\ - "How indenting is done for subsequent lines in a + "How indenting is done for subsequent lines in a multi-line placeholder substitution value. The 1st line or a single line value is always placed at the placeholder. - paramindents are performed after the main + paramindents are performed after the main template has been indented/undented. (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) + unicode double-wide or grapheme cluster widths) " #choicelabels indented by 1 char is clearer for -return string - and reasonable in table -return -default string -choices {dict list string args}\ @@ -4603,7 +4603,7 @@ tcl::namespace::eval punk::args::lib { 'errors'" string\ " Return a single result - being the string with + being the string with placeholders substituted." list\ " Return a 2 element list. @@ -4636,7 +4636,7 @@ tcl::namespace::eval punk::args::lib { For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. contained variables in that case should be braced or whitespace separated, or the variable name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" @values -min 0 -max 1 templatestring -help\ "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} @@ -4645,19 +4645,19 @@ tcl::namespace::eval punk::args::lib { It can contain commands in square brackets if -allowcommands is true e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - Escape sequences such as \\n and unicode escapes are processed within placeholders. + Escape sequences such as \\n and unicode escapes are processed within placeholders. " }] proc tstr {args} { #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only + # - we use punk::args within the unhappy path only #set argd [punk::args::get_by_id ::punk::lib::tstr $args] #set templatestring [dict get $argd values templatestring] #set opt_allowcommands [dict get $argd opts -allowcommands] #set opt_return [dict get $argd opts -return] #set opt_eval [dict get $argd opts -eval] - + set templatestring [lindex $args end] set arglist [lrange $args 0 end-1] set opts [dict create\ @@ -4773,7 +4773,7 @@ tcl::namespace::eval punk::args::lib { } if {$opt_eval} { if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] + lappend params [string cat \$\{ $expression \}] dict set errors [expr {[llength $params]-1}] $result } else { set result [string map [list \n "\n$leader"] $result] @@ -4790,7 +4790,7 @@ tcl::namespace::eval punk::args::lib { if {$opt_return eq "dict"} { return [dict create template $textchunks params $params errors $errors] - } + } if {[dict size $errors]} { set einfo "" dict for {i e} $errors { @@ -4828,7 +4828,7 @@ tcl::namespace::eval punk::args::lib { set lastline [string range $pt $lastline_posn+1 end] } if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent + regexp {(\s*).*} $lastline _all lastindent } else { #position #TODO - detect if there are grapheme clusters @@ -4847,8 +4847,8 @@ tcl::namespace::eval punk::args::lib { } } else { append out $pt $param - } - append lastline $param + } + append lastline $param } } return $out @@ -4859,9 +4859,9 @@ tcl::namespace::eval punk::args::lib { proc tstr_test_one {args} { set argd [punk::args::get_dict { @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. - example: + example: set id 2 - tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] } @values -min 2 -max 2 @@ -4882,8 +4882,8 @@ tcl::namespace::eval punk::args::lib { } set chars [split $templatestring ""] set in_placeholder 0 - set tchars "" - set echars "" + set tchars "" + set echars "" set parts [list] set i 0 foreach ch $chars { @@ -4912,7 +4912,7 @@ tcl::namespace::eval punk::args::lib { } else { append echars $ch } - } + } } incr i } @@ -4932,7 +4932,7 @@ tcl::namespace::eval punk::args::lib { } set list [list] set start 0 - #ideally re should allow curlies within but we will probably need a custom parser to do it + #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 {\$\{(?:(?!\$\{).)*\}} @@ -4945,14 +4945,14 @@ tcl::namespace::eval punk::args::lib { #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 + 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] + 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]} { @@ -4967,7 +4967,7 @@ tcl::namespace::eval punk::args::lib { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { - lappend result "" + lappend result "" } else { lappend result $prefix[string trimright $line] } @@ -5009,7 +5009,7 @@ tcl::namespace::eval punk::args::lib { #hacky proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be + #leader usually whitespace - but doesn't have to be if {$text eq ""} { return "" } @@ -5044,7 +5044,7 @@ tcl::namespace::eval punk::args::lib { } return [join $result \n] } - #A version of textutil::string::longestCommonPrefixList + #A version of textutil::string::longestCommonPrefixList proc longestCommonPrefix {items} { if {[llength $items] <= 1} { return [lindex $items 0] @@ -5061,9 +5061,9 @@ tcl::namespace::eval punk::args::lib { } set n [string length $min] set prefix "" - set i -1 + set i -1 while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c + append prefix $c } return $prefix } @@ -5099,7 +5099,7 @@ tcl::namespace::eval punk::args::package { " -package_about_namespace -type string -optional 0 -help\ "Namespace containing the package about procedures - Must contain " + Must contain " -return\ -type string\ -default table\ @@ -5140,7 +5140,7 @@ tcl::namespace::eval punk::args::package { set pkgname [${pkgns}::package_name] set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] + set all_topics [${pkgns}::about_topics] if {![dict exists $received topic]} { set topics $all_topics } else { @@ -5214,7 +5214,7 @@ tcl::namespace::eval punk::args::package { #can't do this here? - as there is circular dependency with punk::lib #tcl::namespace::eval punk::args { # foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist +# punk::args::define {*}$deflist # } # set PUNKARGS "" #} @@ -5227,7 +5227,7 @@ lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::p tcl::namespace::eval punk::args::system { #*** !doctools #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #dict get value with default wrapper for tcl 8.6 if {[info commands ::tcl::dict::getdef] eq ""} { @@ -5240,11 +5240,11 @@ tcl::namespace::eval punk::args::system { } } } else { - #we pay a minor perf penalty for the wrap + #we pay a minor perf penalty for the wrap interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef } - #name to reflect maintenance - home is punk::lib::ldiff + #name to reflect maintenance - home is punk::lib::ldiff proc punklib_ldiff {fromlist removeitems} { if {[llength $removeitems] == 0} {return $fromlist} set result {} @@ -5260,12 +5260,12 @@ tcl::namespace::eval punk::args::system { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args 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/punk/assertion-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm index 8ad0af62..80f4b14d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/assertion-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::assertion 0 0.1.0] #[copyright "2024"] #[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] -#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] +#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] #[require punk::assertion] #[keywords module assertion assert debug] #[description] @@ -99,9 +99,9 @@ tcl::namespace::eval punk::assertion::class { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin +#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin tcl::namespace::eval punk::assertion::primary { - #tcl::namespace::export {[a-z]*} + #tcl::namespace::export {[a-z]*} tcl::namespace::export assertActive assertInactive proc assertActive {expr args} { @@ -112,7 +112,7 @@ tcl::namespace::eval punk::assertion::primary { if {![tcl::string::is boolean -strict $res]} { return -code error "invalid boolean expression: $expr" } - + if {$res} {return} if {[llength $args]} { @@ -130,9 +130,9 @@ tcl::namespace::eval punk::assertion::primary { } tcl::namespace::eval punk::assertion::secondary { - tcl::namespace::export * + tcl::namespace::export * #we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want. - proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] + proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] proc assertInactive args {} } @@ -151,7 +151,7 @@ tcl::namespace::eval punk::assertion { } do_ns_import #puts --------BBB - rename assertActive assert + rename assertActive assert } @@ -162,20 +162,20 @@ tcl::namespace::eval punk::assertion { #*** !doctools #[subsection {Namespace punk::assertion}] - #[para] Core API functions for punk::assertion + #[para] Core API functions for punk::assertion #[list_begin definitions] #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]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" #} #like tcllib's control::assert - we are limited to the same callback for all namespaces. @@ -218,7 +218,7 @@ tcl::namespace::eval punk::assertion { if {$on_off} { #Enable it in calling namespace if {"assert" eq $info_command} { - #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) + #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] @@ -243,7 +243,7 @@ tcl::namespace::eval punk::assertion { } return 1 } else { - #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace + #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] if {[tcl::string::match ::punk::assertion::* $assertorigin]} { @@ -303,8 +303,8 @@ tcl::namespace::eval punk::assertion { return 0 } } else { - #no assert command reachable - #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path + #no assert command reachable + #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" return 0 } @@ -327,14 +327,14 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::assertion::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 + # #[para]Description of utility1 + # return 1 #} @@ -352,7 +352,7 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::eval punk::assertion::system { #*** !doctools #[subsection {Namespace punk::assertion::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #Maintenance - snarfed from punk::ns to reduce dependencies - punk::ns::nsprefix is the master version #nsprefix/nstail are string functions - they do not concern themselves with what namespaces are present in the system @@ -375,7 +375,7 @@ tcl::namespace::eval punk::assertion::system { proc nstail {nspath args} { #normalize the common case of :::: set nspath [tcl::string::map [list :::: ::] $nspath] - set mapped [tcl::string::map [list :: \u0FFF] $nspath] + set mapped [tcl::string::map [list :: \u0FFF] $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] @@ -411,11 +411,11 @@ tcl::namespace::eval punk::assertion::system { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::assertion [tcl::namespace::eval punk::assertion { variable pkg punk::assertion 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/punk/cap-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm index 68d3252e..2ede3723 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap-0.1.0.tm @@ -26,7 +26,7 @@ #[para]punk::cap provides management of named capabilities and the provider packages and handler packages that implement a pluggable capability. #[para]see also [uri https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/pluginmgr/pluginmgr.md {tcllib pluginmgr}] for an alternative which uses safe interpreters #[subsection Concepts] -#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API +#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API # #[para][term {capability handler}] - a package/namespace which may provide validation and standardised ways of looking up provider data # registered (or not) using register_capabilityname @@ -49,7 +49,7 @@ package require oolib # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::cap { - variable pkgcapsdeclared [tcl::dict::create] + variable pkgcapsdeclared [tcl::dict::create] variable pkgcapsaccepted [tcl::dict::create] variable caps [tcl::dict::create] namespace eval class { @@ -71,8 +71,8 @@ tcl::namespace::eval punk::cap { #*** !doctools #[call class::interface_caphandler.registry [method pkg_register] [arg pkg] [arg capname] [arg capdict] [arg fullcapabilitylist]] #handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid - #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. - return 1 ;#default to permit + #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. + return 1 ;#default to permit } method pkg_unregister {pkg} { #*** !doctools @@ -106,9 +106,9 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.registration { #*** !doctools # [enum] CLASS [class interface_cappprovider.registration] - # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. + # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. # [para]If your package namespace is mypackages::providerpkg then the object command would be at mypackages::providerpkg::capsystem::capprovider.registration - # [para]Example code for your provider package to evaluate within its namespace: + # [para]Example code for your provider package to evaluate within its namespace: # [example { #namespace eval capsystem { # if {[info commands capprovider.registration] eq ""} { @@ -133,7 +133,7 @@ tcl::namespace::eval punk::cap { #[para] This method must be overridden by your provider using oo::objdefine cappprovider.registration as in the example above. # There must be at least one 2-element list in the result for the provider to be registerable. #[para]The first element of the list is the capabilityname - which can be custom to your provider/handler packages - or a well-known name that other authors may use/implement. - #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. + #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. error "interface_capprovider.registration not implemented by provider" } #*** !doctools @@ -142,11 +142,11 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.provider { #*** !doctools - # [enum] CLASS [class interface_capprovider.provider] - # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] + # [enum] CLASS [class interface_capprovider.provider] + # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] # [example { - # namespace eval mypackages::providerpkg { - # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg + # namespace eval mypackages::providerpkg { + # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg # } # }] # [list_begin definitions] @@ -229,7 +229,7 @@ tcl::namespace::eval punk::cap { #Not all capability names have to be registered. #A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated handler. - #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. + #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. #we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. proc register_capabilityname {capname capnamespace} { #puts stderr "REGISTER_CAPABILITYNAME $capname $capnamespace" @@ -243,10 +243,10 @@ tcl::namespace::eval punk::cap { } } #allow register of existing capname iff there is no current handler - #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package - #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers + #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package + #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers if {[set hdlr [capability_get_handler $capname]] ne ""} { - puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" + puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" return } #assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. @@ -295,14 +295,14 @@ tcl::namespace::eval punk::cap { if {$count == 0} { set pkgposn [lsearch $providers $pkg] if {$pkgposn >= 0} { - set updated_providers [lreplace $providers $posn $posn] + set updated_providers [lreplace $providers $posn $posn] tcl::dict::set caps $capname providers $updated_providers } } } } - + } } proc capability_exists {capname} { @@ -328,7 +328,7 @@ tcl::namespace::eval punk::cap { if {[tcl::dict::exists $caps $capname]} { return [tcl::dict::get $caps $capname handler] } - return "" + return "" } proc call_handler {capname args} { if {[set handler [capability_get_handler $capname]] eq ""} { @@ -461,7 +461,7 @@ tcl::namespace::eval punk::cap { #todo! proc unregister_package {pkg {capname *}} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] @@ -471,7 +471,7 @@ tcl::namespace::eval punk::cap { set capabilitylist [dict get $pkgcapsdeclared $pkg] foreach c $capabilitylist { set do_unregister 1 - lassign $c capname _capdict + lassign $c capname _capdict set cap_info [dict get $caps $capname] set pkglist [dict get $cap_info providers] set posn [lsearch $pkglist $pkg] @@ -479,9 +479,9 @@ tcl::namespace::eval punk::cap { if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { #review # it seems not useful to allow the callback to block this unregister action - #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter - #vetoing unregister would make this more complex for no particular advantage - #if per dataset deregistration required this should probably be a separate thing + #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter + #vetoing unregister would make this more complex for no particular advantage + #if per dataset deregistration required this should probably be a separate thing $capreg pkg_unregister $pkg $capname } set pkglist [lreplace $pkglist $posn $posn] @@ -510,7 +510,7 @@ tcl::namespace::eval punk::cap { } } proc pkgcaps {} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable pkgcapsaccepted set result [dict create] foreach {pkg capsdeclared} $pkgcapsdeclared { @@ -522,7 +522,7 @@ tcl::namespace::eval punk::cap { dict set result $pkg accepted $accepted } return $result - } + } proc capability {capname} { variable caps @@ -565,14 +565,14 @@ tcl::namespace::eval punk::cap { #[subsection {Namespace punk::cap::advanced}] #[para] punk::cap::advanced API. Functions here are generally not the preferred way to interact with punk::cap. #[para] In some cases they may allow interaction in less safe ways or may allow use of features that are unavailable in the base namespace. - #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. + #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. #[list_begin definitions] proc promote_provider {pkg} { #*** !doctools # [call advanced::[fun promote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. #[para] #[para] promote/demote doesn't always make a lot of sense .. should preferably be configurable per capapbility for multicap provider pkgs #[para]The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded @@ -615,7 +615,7 @@ tcl::namespace::eval punk::cap { #*** !doctools # [call advanced::[fun demote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { @@ -677,11 +677,11 @@ tcl::namespace::eval punk::cap { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap [namespace eval punk::cap { variable version variable pkg punk::cap - set version 0.1.0 + set version 0.1.0 variable README.md [string map [list %pkg% $pkg %ver% $version] { # punk capabilities system ## pkg: %pkg% version: %ver% diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm index 8fdce944..4a19666b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/caphandler-0.1.0.tm @@ -43,10 +43,10 @@ namespace eval punk::cap::handlers::caphandler { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { variable pkg punk::cap::handlers::caphandler variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm index 5624ec58..60764f07 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/cap/handlers/templates-0.1.0.tm @@ -23,7 +23,7 @@ package require punk::repo # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #register using: -# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates +# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates #By convention and for consistency, we don't register here during package loading - but require the calling app to do it. # (even if it tends to be done immediately after package require anyway) @@ -67,11 +67,11 @@ namespace eval punk::cap::handlers::templates { #for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called - #for template pathtype absolute - we can do the same. - #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. + #for template pathtype absolute - we can do the same. + #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. #adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time. - #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - + #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - #but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly. switch -- $pathtype { adhoc { @@ -95,7 +95,7 @@ namespace eval punk::cap::handlers::templates { } else { set tm_exists [file exists $tmfile] } - if {![file exists $tmfile]} { + if {!$tm_exists} { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" flush stderr return 0 @@ -128,7 +128,7 @@ namespace eval punk::cap::handlers::templates { } set extended_capdict $capdict - dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? + dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? } currentproject { if {[file pathtype $path] ne "relative"} { @@ -140,7 +140,7 @@ namespace eval punk::cap::handlers::templates { set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor } shellproject { if {[file pathtype $path] ne "relative"} { @@ -150,7 +150,7 @@ namespace eval punk::cap::handlers::templates { set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review set projectinfo [punk::repo::find_repos $shellbase] set projectbase [dict get $projectinfo closest] - + set extended_capdict $capdict dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase @@ -170,7 +170,7 @@ namespace eval punk::cap::handlers::templates { set projectbase [dict get $projectinfo closest] set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } absolute { @@ -188,7 +188,7 @@ namespace eval punk::cap::handlers::templates { #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict - dict set extended_capdict resolved_path $normpath + dict set extended_capdict resolved_path $normpath dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } @@ -199,7 +199,7 @@ namespace eval punk::cap::handlers::templates { } # -- --- --- --- --- --- --- ---- --- - # update package internal data + # update package internal data # -- --- --- --- --- --- --- ---- --- upvar ::punk::cap::handlers::templates::provider_info_$cname provider_info @@ -208,13 +208,13 @@ namespace eval punk::cap::handlers::templates { } if {![info exists provider_info] || $extended_capdict ni [dict get $provider_info $pkg]} { #this checks for duplicates from the same provider - but not if other providers already added the path - #review - + #review - dict lappend provider_info $pkg $extended_capdict } # -- --- --- --- --- --- --- ---- --- - # instantiation of api at punk::cap::handlers::templates::api_$capname + # instantiation of api at punk::cap::handlers::templates::api_$capname # -- --- --- --- --- --- --- ---- --- set apicmd "::punk::cap::handlers::templates::api_$capname" if {[info commands $apicmd] eq ""} { @@ -227,12 +227,12 @@ namespace eval punk::cap::handlers::templates { upvar ::punk::cap::handlers::templates::handled_caps hcaps foreach capname $hcaps { set cname [string map {. _} $capname] - upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info + upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info dict unset my_provider_info $pkg #destroy api objects? } } - } + } } } @@ -293,7 +293,7 @@ namespace eval punk::cap::handlers::templates { set found_paths_absolute [list] - foreach pkg $providerpkg { + foreach pkg $providerpkg { set found_paths [list] #set acceptedlist [dict get [punk::cap::pkgcap $pkg $capabilityname] accepted] @@ -314,13 +314,13 @@ namespace eval punk::cap::handlers::templates { set module_projectroot [dict get $capdecl_extended projectbase] dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] } elseif {$pathtype eq "currentproject_multivendor"} { - set searchbase $startdir + set searchbase $startdir set pathinfo [punk::repo::find_repos $searchbase] set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { set deckbase [file join $pwd_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -349,7 +349,7 @@ namespace eval punk::cap::handlers::templates { } } } elseif {$pathtype eq "currentproject"} { - set searchbase $startdir + set searchbase $startdir set pathinfo [punk::repo::find_repos $searchbase] set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { @@ -369,7 +369,7 @@ namespace eval punk::cap::handlers::templates { if {$shell_projectroot ne ""} { set deckbase [file join $shell_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -471,19 +471,19 @@ namespace eval punk::cap::handlers::templates { return $folderdict } method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { + set argd [punk::args::get_dict { @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" @opts -anyopts 1 #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here -startdir -default "" @values -maxvalues -1 - } $args] + } $args] set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { set searchbase [pwd] } else { - set searchbase $opt_startdir + set searchbase $opt_startdir } set refdict [my get_itemdict_projectlayoutrefs {*}$args] @@ -502,7 +502,7 @@ namespace eval punk::cap::handlers::templates { # e.g ref may be @vendor+punks+othersample@sample-0.1 or layoutalias-1.1@vendor+punk+othersample@sample-0.1 #there must always be an @ before vendor or custom . There is either a template-name alias or empty string before this first @ #trim off first @ part - set tailats [join [lrange $atparts 1 end] @] + set tailats [join [lrange $atparts 1 end] @] # @ parts after the first are part of the path within the project_layouts structure set subpathlist [split $tailats +] if {[dict exists $refinfo sourceinfo projectbase]} { @@ -553,7 +553,7 @@ namespace eval punk::cap::handlers::templates { if {$vendor ne "_project"} { set itemname $vendor.$itemname } - return $itemname + return $itemname }}} } set arglist [concat $config $args] @@ -623,7 +623,7 @@ namespace eval punk::cap::handlers::templates { }}}\ -command_get_item_name {apply {{vendor basefolder itempath} { - set relativepath [punk::path::relative $basefolder $itempath] + set relativepath [punk::path::relative $basefolder $itempath] set dirs [file dirname $relativepath] if {$dirs eq "."} { set dirs "" @@ -636,7 +636,7 @@ namespace eval punk::cap::handlers::templates { } if {$vendor ne "_project"} { set tname ${vendor}.$tname - } + } return $tname }}} } @@ -645,11 +645,11 @@ namespace eval punk::cap::handlers::templates { } #shared algorithm for get_itemdict_* methods - #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search + #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { + set argd [punk::args::get_dict { @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" @cmd -name _get_itemdict @opts -anyopts 0 @@ -657,7 +657,7 @@ namespace eval punk::cap::handlers::templates { -templatefolder_subdir -optional 0 -command_get_items_from_base -optional 0 -command_get_item_name -optional 0 - -not -default "" -multiple 1 + -not -default "" -multiple 1 @values -maxvalues -1 globsearches -default * -multiple 1 } $args] @@ -697,12 +697,12 @@ namespace eval punk::cap::handlers::templates { set items_here [dict create] ;#maintain a list keyed on name for sorting within this base only foreach itempath $matches { set itemname [{*}$opt_command_get_item_name $vendor $basefolder $itempath] - dict set items_here $itemname [list item $itempath baseinfo $baseinfo] + dict set items_here $itemname [list item $itempath baseinfo $baseinfo] #lappend items [list item $itempath baseinfo $baseinfo] } set ordered_names [lsort [dict keys $items_here]] - #add to the outer items list - foreach nm $ordered_names { + #add to the outer items list + foreach nm $ordered_names { set iteminfo [dict get $items_here $nm] lappend items [list originalname $nm iteminfo $iteminfo] } @@ -715,8 +715,8 @@ namespace eval punk::cap::handlers::templates { set itempath [dict get $iteminfo item] set baseinfo [dict get $iteminfo baseinfo] if {![dict exists $seen_dict $oname]} { - dict set seen_dict $oname 1 - dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number + dict set seen_dict $oname 1 + dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number } else { set n [dict get $seen_dict $oname] incr n @@ -730,7 +730,7 @@ namespace eval punk::cap::handlers::templates { set result [dict create] set keys [lreverse [dict keys $itemdict]] foreach k $keys { - set maybe "" + set maybe "" foreach g $globsearches { if {[string match $g $k]} { set maybe $k @@ -745,7 +745,7 @@ namespace eval punk::cap::handlers::templates { break } } - } + } if {$maybe ne "" && $not eq ""} { dict set result $k [dict get $itemdict $k] } @@ -762,10 +762,10 @@ namespace eval punk::cap::handlers::templates { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { variable pkg punk::cap::handlers::templates variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm index 43dcd6b5..675f42b0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/char-0.1.0.tm @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_punk::char 0 0.1.0] #[copyright "2024"] #[titledesc {character-set and unicode utilities}] [comment {-- Name section and table of contents description --}] -#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] +#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] #[require punk::char] #[keywords module encodings] #[description] @@ -49,11 +49,11 @@ #*** !doctools #[item] [package {overtype}] -#[para] - +#[para] - #[item] [package {textblock}] -#[para] - +#[para] - #[item] [package console] -#[para] - +#[para] - package require Tcl 8.6- #dependency on tcllib not ideal for bootstrapping as punk::char is core to many features.. (textutil::wcswidth is therefore included in bootsupport/include_modules.config) review @@ -92,20 +92,20 @@ tcl::namespace::eval punk::char { #just the 7-bit ascii. use [page ascii] for the 8-bit layout proc ascii {} {return { 00 NUL 01 SOH 02 STX 03 ETX 04 EOT 05 ENQ 06 ACK 07 BEL - 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI + 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI 10 DLE 11 DC1 12 DC2 13 DC3 14 DC4 15 NAK 16 SYN 17 ETB - 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US - 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' - 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / - 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 - 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? - 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G - 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O - 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W - 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ - 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g - 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o - 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w + 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US + 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' + 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / + 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 + 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? + 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G + 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O + 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W + 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ + 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g + 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o + 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w 78 x 79 y 7a z 7b { 7c | 7d } 7e ~ 7f DEL }} @@ -124,7 +124,7 @@ tcl::namespace::eval punk::char { } elseif {[tcl::string::length $v] == 0} { set v " " } - append out "$k $v " + append out "$k $v " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -143,7 +143,7 @@ tcl::namespace::eval punk::char { set out "" append out [page dingbats] \n set unicode_dict [charset_dictget Dingbats] - + append out " " set i 1 tcl::dict::for {k charinfo} $unicode_dict { @@ -155,7 +155,7 @@ tcl::namespace::eval punk::char { } else { set displayv $char } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -205,7 +205,7 @@ tcl::namespace::eval punk::char { tcl::dict::lappend d $encname $mname } } - } + } foreach enc [lsort $encnames] { set mime_enc [${encmimens}::mapencoding $enc] if {$mime_enc ne ""} { @@ -236,7 +236,7 @@ tcl::namespace::eval punk::char { tailcall page $encname {*}$args } - #This will not display for example, c0 glyphs for cp437 + #This will not display for example, c0 glyphs for cp437 # we could use the punk::ansi::cp437_map dict - but while that might be what some expect to see - it would probably be too much magic for this function - which is intended to align more with what Tcl's encoding convertfrom/to actually does. # for nonprinting members of the page, 2 and 3 letter codes are used rather than unicode visualisation replacements or even unicode equivalent replacements known to be appropriate for the page proc page {encname args} { @@ -255,7 +255,7 @@ tcl::namespace::eval punk::char { #set d_ascii [pagedict_raw ascii] set d_ascii [basedict] - set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi + set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi #The results of this are best seen by comparing the ebcdic and ascii pages set d_page [pagedict_raw $encname] @@ -285,7 +285,7 @@ tcl::namespace::eval punk::char { set displayv $bytedisplay } else { if {[tcl::string::length $rawchar] == 0} { - set displayv " " + set displayv " " } else { #presumed 1 set displayv " $rawchar " @@ -294,7 +294,7 @@ tcl::namespace::eval punk::char { } } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % $cols == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -318,7 +318,7 @@ tcl::namespace::eval punk::char { set outchar [encoding convertfrom $encpage $ch] } else { #here we will use \0xFFFD instead of our replacement string ??? - as the name pagechar implies always returning a single character. REVIEW. - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -348,7 +348,7 @@ tcl::namespace::eval punk::char { #set outchar [encoding convertto $encpage [format %c $num]] set outchar [format %c $num] } else { - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -381,7 +381,7 @@ tcl::namespace::eval punk::char { } proc pagedict_raw {encname} { - variable invalid ;# ="???" + variable invalid ;# ="???" set encname [encname $encname] set d [tcl::dict::create] for {set i 0} {$i < 256} {incr i} { @@ -409,7 +409,7 @@ tcl::namespace::eval punk::char { tcl::dict::set d $k [tcl::dict::get $a128 $k] } else { # - tcl::dict::set d $k $invalid + tcl::dict::set d $k $invalid } if {$i <=32} { @@ -457,7 +457,7 @@ tcl::namespace::eval punk::char { } return $d } - + proc basedict {} { #this gives same result independent of current value of 'encoding system' set d [tcl::dict::create] @@ -529,10 +529,10 @@ tcl::namespace::eval punk::char { return $d } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- # encoding convertfrom & encoding convertto can be somewhat confusing to think about. (Need to think in reverse.) # e.g encoding convertto dingbats will output something that doesn't look dingbatty on screen. - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- #must use Tcl instead of tcl (at least for 8.6) if {![package vsatisfies [package present Tcl] 8.7-]} { proc encodable "s {enc [encoding system]}" { @@ -574,7 +574,7 @@ tcl::namespace::eval punk::char { } } } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- proc test_japanese {{encoding jis0208}} { #A very basic test of 2char encodings such as jis0208 set yatbun 日本 ;# encoding convertfrom jis0208 F|K\\ @@ -584,7 +584,7 @@ tcl::namespace::eval punk::char { set ebun [encoding convertto $encoding $bun] puts "$encoding encoded: ${eyat} ${ebun}" puts "reencoded: [encoding convertfrom $encoding $eyat] [encoding convertfrom $encoding $ebun]" - return $yatbun + return $yatbun } proc test_grave {} { set g [format %c 0x300] @@ -692,7 +692,7 @@ tcl::namespace::eval punk::char { #ESC ( B ESC ) B ASCII Set #ESC ( 0 ESC ) 0 Special Graphics #ESC ( 1 ESC ) 1 Alternate Character ROM Standard Character Set - #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic + #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Unicode character sets - some hardcoded - some loadable from data files @@ -700,7 +700,7 @@ tcl::namespace::eval punk::char { variable charinfo [tcl::dict::create] variable charsets [tcl::dict::create] - + # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Aggregate character sets (ones that pick various ranges from underlying unicode ranges) # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -741,7 +741,7 @@ tcl::namespace::eval punk::char { } # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # Unicode ranges + # Unicode ranges # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- tcl::dict::set charsets "greek" [list ranges [list {start 880 end 1023} {start 7936 end 8191}] description "Greek and Coptic" settype "other"] @@ -975,9 +975,9 @@ tcl::namespace::eval punk::char { variable charset_extents_rangenames ;# dict keyed on start,end pointing to list of 2-tuples {setname rangeindex_within_set} #build 2 indexes for each range.(charsets are not just unicode blocks so can have multiple ranges) #Note that a range could be as small as a single char (startpoint = endpoint) so there can be many ranges with same start and end if charsets use some of the same subsets. - #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict - #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key - #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key + #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict + #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key + #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key proc _build_charset_extents {} { variable charsets variable charset_extents_startpoints @@ -995,7 +995,7 @@ tcl::namespace::eval punk::char { set end [tcl::dict::get [lindex $ranges 0] end] if {![tcl::dict::exists $charset_extents_startpoints $start] || $end ni [tcl::dict::get $charset_extents_startpoints $start]} { #assertion if end wasn't in startpoits list - then start won't be in endpoints list - tcl::dict::lappend charset_extents_startpoints $start $end + tcl::dict::lappend charset_extents_startpoints $start $end tcl::dict::lappend charset_extents_endpoints $end $start } tcl::dict::lappend charset_extents_rangenames ${start},${end} [list $setname 1] @@ -1023,14 +1023,14 @@ tcl::namespace::eval punk::char { #no need to sort charset_extents_rangenames - lookup only done using dict methods return [tcl::dict::size $charset_extents_startpoints] } - _build_charset_extents ;#rebuilds for all charsets + _build_charset_extents ;#rebuilds for all charsets #nerdfonts are within the Private use E000 - F8FF range proc load_nerdfonts {} { variable charsets variable charinfo package require fileutil - set ver [package provide punk::char] + set ver [package provide punk::char] if {$ver ne ""} { set ifneeded [package ifneeded punk::char [package provide punk::char]] #puts stderr "punk::char ifneeded script: $ifneeded" @@ -1038,7 +1038,7 @@ tcl::namespace::eval punk::char { set basedir [file dirname [lindex $sourceinfo end]] } else { #review - will only work at package load time - set scr [info script] + set scr [info script] if {$scr eq ""} { error "load_nerdfonts unable to determine package folder" } @@ -1048,7 +1048,7 @@ tcl::namespace::eval punk::char { set fname [file join $pkg_data_dir nerd-fonts-glyph-list.txt] if {[file exists $fname]} { #puts stderr "load_nerdfonts loading $fname" - set data [fileutil::cat -translation binary $fname] + set data [fileutil::cat -translation binary $fname] set short_seen [tcl::dict::create] set current_set_range [tcl::dict::create] set filesets_loading [list] @@ -1066,7 +1066,7 @@ tcl::namespace::eval punk::char { dict unset charset $setname } set newrange [list start $dec end $dec] - tcl::dict::set current_set_range $setname $newrange + tcl::dict::set current_set_range $setname $newrange tcl::dict::set charsets $setname [list ranges [list $newrange] description "nerd fonts $rawsetname" settype "nerdfonts privateuse"] lappend filesets_loading $setname @@ -1080,13 +1080,13 @@ tcl::namespace::eval punk::char { #overwrite last ranges element set rangelist [lrange [tcl::dict::get $charsets $setname ranges] 0 end-1] lappend rangelist [tcl::dict::get $current_set_range $setname] - tcl::dict::set charsets $setname ranges $rangelist + tcl::dict::set charsets $setname ranges $rangelist } else { #new range for set tcl::dict::set current_set_range $setname start $dec tcl::dict::set current_set_range $setname end $dec set rangelist [tcl::dict::get $charsets $setname ranges] - lappend rangelist [tcl::dict::get $current_set_range $setname] + lappend rangelist [tcl::dict::get $current_set_range $setname] tcl::dict::set charsets $setname ranges $rangelist } @@ -1130,7 +1130,7 @@ tcl::namespace::eval punk::char { proc package_base {} { #assume punk::char is in .tm form and we can use the package provide statement to determine base location - #review + #review set pkgver [package present punk::char] set pkginfo [package ifneeded punk::char $pkgver] set tmfile [lindex $pkginfo end] @@ -1156,7 +1156,7 @@ tcl::namespace::eval punk::char { if {[tcl::dict::exists $dictValue {*}$keys]} { return [tcl::dict::get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } } @@ -1181,7 +1181,7 @@ tcl::namespace::eval punk::char { } puts "ok.. loading" set fd [open $file r] - fconfigure $fd -translation binary + chan configure $fd -translation binary set data [read $fd] close $fd set block_count 0 @@ -1193,7 +1193,7 @@ tcl::namespace::eval punk::char { if {[set pcolon [tcl::string::first ";" $ln]] > 0} { set lhs [tcl::string::trim [tcl::string::range $ln 0 $pcolon-1]] set name [tcl::string::trim [tcl::string::range $ln $pcolon+1 end]] - set lhsparts [split $lhs .] + set lhsparts [split $lhs .] set start [lindex $lhsparts 0] set end [lindex $lhsparts end] #puts "$start -> $end '$name'" @@ -1207,9 +1207,9 @@ tcl::namespace::eval punk::char { return $block_count } - #unicode scripts + #unicode scripts - #unicode UnicodeData.txt + #unicode UnicodeData.txt @@ -1225,8 +1225,8 @@ tcl::namespace::eval punk::char { # -- --- #A = Ambiguous - All characters that can be sometimes wide and sometimes narrow. (wide in east asian legacy sets, narrow in non-east asian usage) (private use chars considered ambiguous) #F = East Asian Full-width - #H = East Asian Half-width - #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na + #H = East Asian Half-width + #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na #Na = East Asian Narrow - all other characters that are always narrow and have explicit full-width counterparts (e.g includes all of ASCII) #W = East Asian Wide - all other characters that are always wide (Occur only in the context of Eas Asian Typography) # -- --- @@ -1304,7 +1304,7 @@ tcl::namespace::eval punk::char { set initial_fields $known_fields if {"testwidth" ni $opt_fields} { if {"testwidth" ni $opt_except} { - lappend opt_except testwidth + lappend opt_except testwidth } } if {"char" ni $opt_fields} { @@ -1369,13 +1369,13 @@ tcl::namespace::eval punk::char { #testwidth is one of the main ones likely to be worthwhile excluding as querying the console via ansi takes time set existing_testwidth "" if {[tcl::dict::exists $charinfo $dec_char testwidth]} { - set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] + set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] } if {$existing_testwidth eq ""} { #no cached data - do expensive cursor-position test (Note this might not be 100% reliable - terminals lie e.g if ansi escape sequence has set to wide printing.) set char [format %c $dec_char] set chwidth [char_info_testwidth $char] - + tcl::dict::set returninfo testwidth $chwidth #cache it. todo - -verify flag to force recalc in case font/terminal changed in some way? tcl::dict::set charinfo $dec_char testwidth $chwidth @@ -1387,10 +1387,10 @@ tcl::namespace::eval punk::char { set char [format %c $dec_char] tcl::dict::set returninfo char $char } - memberof { + memberof { #memberof takes in the order of a few hundred microseconds if a simple scan of all ranges is taken - possibly worthwhile caching/optimising #note that memberof is not just unicode blocks - but scripts and other non-contiguous sets consisting of multiple ranges - some of which may include ranges of a single character. (e.g WGL4) - #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. + #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. #We could potentially populate it using a side-thread - but it seems reasonable to just cache result after first use here. #some efficiency could also be gained by pre-calculating the extents for each charset which isn't a simple unicode block. (and perhaps sorting by max char) set memberof [list] @@ -1435,7 +1435,7 @@ tcl::namespace::eval punk::char { set splen [tcl::dict::size $charset_extents_startpoints] set eplen [tcl::dict::size $charset_extents_endpoints] set s [lsearch -bisect -integer $skeys $dec] - set s_at_or_below [lrange $skeys 0 $s] + set s_at_or_below [lrange $skeys 0 $s] set e_of_s [list] foreach sk $s_at_or_below { lappend e_of_s {*}[tcl::dict::get $charset_extents_startpoints $sk] @@ -1472,16 +1472,16 @@ tcl::namespace::eval punk::char { set eps [list] } - + return [tcl::dict::create startpoints $splen endpoints $eplen midpoint [expr {floor($eplen/2)}] posn $e lhs_endpoints_to_check "[llength $reduced_endpoints]/[llength $e_of_s]=[llength $sps]ranges" rhs_startpoints_to_check "[llength $reduced_startpoints]/[llength $s_of_e]=[llength $eps]"] } #for just a few extra sets such as wgl4 and unicode blocks loaded - this gives e.g 5x + better performance than the simple search above, and up to twice as slow for tcl 8.6 #performance biased towards lower numbered characters (which is not too bad in the context of unicode) #todo - could be tuned to perform better at end by assuming a fairly even distribution of ranges - and so searching startpoint ranges first for items left of middle, endpoint ranges first for items right of middle - #review with scripts loaded and more defined ranges.. + #review with scripts loaded and more defined ranges.. #This algorithm supports arbitrary overlapping ranges and ranges with same start & endpoints #Should be much better than O(n) for n sets except for pathological case of member of all or nearly-all intervals ? - #review - compare with 'interval tree' algorithms. + #review - compare with 'interval tree' algorithms. proc char_info_dec_memberof {dec} { variable charset_extents_startpoints variable charset_extents_endpoints @@ -1563,7 +1563,7 @@ tcl::namespace::eval punk::char { set matchcount 0 foreach glob $and_globs { if {[tcl::string::match -nocase $glob $s] || [tcl::string::match -nocase $glob $d]} { - incr matchcount + incr matchcount } } if {$matchcount == [llength $and_globs]} { @@ -1595,12 +1595,12 @@ tcl::namespace::eval punk::char { } - #non-overlapping unicode blocks + #non-overlapping unicode blocks proc char_blocks {{name_or_glob *}} { variable charsets #todo - more efficient datastructures? if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { if {[tcl::dict::get $charsets $name_or_glob settype] eq "block"} { return [tcl::dict::create $name_or_glob [tcl::dict::get $charsets $name_or_glob]] @@ -1630,7 +1630,7 @@ tcl::namespace::eval punk::char { proc charset_names {{name_or_glob *}} { variable charsets if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { return [list $name_or_glob] } @@ -1641,7 +1641,7 @@ tcl::namespace::eval punk::char { } } else { if {$name_or_glob eq "*"} { - return [lsort [tcl::dict::keys $charsets]] + return [lsort [tcl::dict::keys $charsets]] } #tcl::dict::keys $dict doesn't have option for case insensitive searches return [lsort [lsearch -all -inline -nocase [tcl::dict::keys $charsets] $name_or_glob]] @@ -1655,7 +1655,7 @@ tcl::namespace::eval punk::char { variable charsets #dictionary sorting of the keys is slow! - we should obviously store it in sorted order instead of sorting entire list on retrieval - or just sort results #set sortedkeys [lsort -increasing -dictionary [tcl::dict::keys $charsets]] ;#NOTE must use -dictionary to use -sorted flag below - set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] + set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] if {$namesearch eq "*"} { return $sortedkeys } @@ -1664,7 +1664,7 @@ tcl::namespace::eval punk::char { return [lsearch -all -inline -nocase $sortedkeys $namesearch] ;#no point using -sorted flag when -all is used } else { #return [lsearch -sorted -inline -nocase $sortedkeys $namesearch] ;#no globs - bails out earlier if -sorted? - return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs + return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs } } proc charsets {{namesearch *}} { @@ -1738,7 +1738,7 @@ tcl::namespace::eval punk::char { set opt_ansi [tcl::dict::get $opts -ansi] set opt_lined [tcl::dict::get $opts -lined] # -- --- --- --- - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} if {$opt_ansi} { set a1 [a BLACK white bold] @@ -1768,7 +1768,7 @@ tcl::namespace::eval punk::char { } set i 1 append out \n $prefix $charsetname - append out \n + append out \n set marker_line $prefix set line $prefix @@ -1847,7 +1847,7 @@ tcl::namespace::eval punk::char { } else { set charset_dict [charset_dictget $charsetname] } - + set col_items_short [list] set col_items_desc [list] tcl::dict::for {k inf} $charset_dict { @@ -1873,7 +1873,7 @@ tcl::namespace::eval punk::char { return $out } - #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria + #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria proc charset_calibrate {namesearch args} { variable charsets variable charinfo @@ -1909,7 +1909,7 @@ tcl::namespace::eval punk::char { set twidth [tcl::dict::get $charinfo $dec testwidth] } if {$twidth eq ""} { - #puts -nonewline stdout "." ;#this + #puts -nonewline stdout "." ;#this set width [char_info_testwidth $ch] ;#based on console test rather than unicode props tcl::dict::set charinfo $dec testwidth $width } else { @@ -1925,10 +1925,10 @@ tcl::namespace::eval punk::char { #maint warning - also in overtype! #intended for single grapheme - but will work for multiple - #cannot contain ansi or newlines + #cannot contain ansi or newlines #(a cache of ansifreestring_width calls - as these are quite regex heavy) #review - effective memory leak on longrunning programs if never cleared - #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner + #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner proc grapheme_width_cached {ch {key ""}} { variable grapheme_widths #if key eq "*" - we won't be able to clear that cache individually. Perhaps that's ok @@ -1975,7 +1975,7 @@ tcl::namespace::eval punk::char { # - compare with wcswidth returning -1 for entire string containing such in python,perl proc wcswidth {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) #Tcl initial evaluation stack size is 2000 (? review) #REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!! set chunksize 2000 @@ -1984,14 +1984,14 @@ tcl::namespace::eval punk::char { set startidx 0 set endidx [expr {$startidx + $chunksize -1}] for {set i 0} {$i < $chunks_required} {incr i} { - set chunk [tcl::string::range $string $startidx $endidx] + set chunk [tcl::string::range $string $startidx $endidx] set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] foreach c $codes { if {$c <= 255 && !($c < 31 || $c == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$c < 917504 || $c > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $c] @@ -2023,7 +2023,7 @@ tcl::namespace::eval punk::char { set graphemes [list] while {$i < [tcl::string::length $string]} { set aftercluster [tk::endOfCluster $string $i] - lappend graphemes [string range $string $i $aftercluster-1] + lappend graphemes [string range $string $i $aftercluster-1] set i $aftercluster } return $graphemes @@ -2052,15 +2052,15 @@ tcl::namespace::eval punk::char { } } incr width $gw - + #if {[string first \u200d $g] >=0} { - # incr width 2 + # incr width 2 #} else { # #other joiners??? # incr width [wcswidth_unclustered $g] #} } else { - incr width [wcswidth_unclustered $g] + incr width [wcswidth_unclustered $g] } set i $aftercluster } @@ -2071,8 +2071,8 @@ tcl::namespace::eval punk::char { scan $char %c dec if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - return 1 + #todo - compare with python or other lang wcwidth + return 1 } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars return [textutil::wcswidth_char $dec] ;#note textutil::wcswidth_char takes a decimal codepoint! @@ -2086,8 +2086,8 @@ tcl::namespace::eval punk::char { scan $c %c dec if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $dec] ;#takes decimal codepoint @@ -2105,7 +2105,7 @@ tcl::namespace::eval punk::char { # - compare with wcswidth returning -1 for entire string containing such in python,perl proc wcswidth_unclustered {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) #Tcl initial evaluation stack size is 2000 (? review) #we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!. set chunksize 2000 @@ -2114,14 +2114,14 @@ tcl::namespace::eval punk::char { set startidx 0 set endidx [expr {$startidx + $chunksize -1}] for {set i 0} {$i < $chunks_required} {incr i} { - set chunk [tcl::string::range $string $startidx $endidx] + set chunk [tcl::string::range $string $startidx $endidx] set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] foreach dec $codes { if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $dec] @@ -2141,8 +2141,8 @@ tcl::namespace::eval punk::char { proc wcswidth0 {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ - #TODO + #..but - 'scan' is horrible for 400K+ + #TODO set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]] set width 0 foreach dec $codes { @@ -2150,9 +2150,9 @@ tcl::namespace::eval punk::char { if {$dec < 917504 || $dec > 917631} { if {$dec <= 255} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth + #todo - compare with python or other lang wcwidth if {!($dec < 31 || $dec == 127)} { - incr width + incr width } } else { #TODO - various other joiners and non-printing chars @@ -2179,11 +2179,11 @@ tcl::namespace::eval punk::char { #prerequisites - no ansi escapes - no newlines - utf8 encoding assumed #review - what about \r \t \b ? #NO processing of \b - already handled in ansi::printing_length which then calls this - #this version breaks string into sequences of ascii vs unicode + #this version breaks string into sequences of ascii vs unicode proc ansifreestring_width {text} { #caller responsible for calling ansistrip first if text may have ansi codes - and for ensuring no newlines #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2204,11 +2204,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] # -- --- --- --- --- --- --- @@ -2221,10 +2221,10 @@ tcl::namespace::eval punk::char { #for now - strip them out #ZWNJ \u200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u200b zero width space + #ZWSP \u200b zero width space #\uFFEFBOM/ ZWNBSP and others that should be zero width - #todo - work out proper way to mark/group zero width. + #todo - work out proper way to mark/group zero width. #set text [tcl::string::map [list \u200b "" \u200c "" \u200d "" \uFFEF ""] $text] set text [tcl::string::map [list \u200b "" \u200c "" \u200d ""] $text] @@ -2241,7 +2241,7 @@ tcl::namespace::eval punk::char { #c1 controls - first section of the Latin-1 Supplement block - all non-printable from a utf-8 perspective #some or all of these may have a visual representation in other encodings e.g cp855 seems to have 1 width for them all - #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here + #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here #they should also be unlikely to be present in an ansi-free string (as is a precondition for use of this function) set text [regsub -all {[\u0080-\u009f]+} $text ""] @@ -2262,7 +2262,7 @@ tcl::namespace::eval punk::char { #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] #tcl pre 2023-11 - braced high unicode regexes don't work #fixed in bug-4ed788c618 2023-11 - #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only #maintain unicode as sequences - todo - scan for grapheme clusters #set uc_sequences [punk::ansi::ta::_perlish_split "(?:\[\u0100-\U10FFFF\])+" $text] @@ -2291,7 +2291,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2312,11 +2312,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #review @@ -2325,7 +2325,7 @@ tcl::namespace::eval punk::char { #ZWNJ \u0200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u0200b zero width space + #ZWSP \u0200b zero width space #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2343,10 +2343,10 @@ tcl::namespace::eval punk::char { } #review - wcswidth should detect these - set re_ascii_fullwidth {[\uFF01-\uFF5e]} + set re_ascii_fullwidth {[\uFF01-\uFF5e]} set doublewidth_char_count 0 - set zerowidth_char_count 0 + set zerowidth_char_count 0 #split just to get the standalone character widths - and then scan for other combiners (?) #review #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] @@ -2354,7 +2354,7 @@ tcl::namespace::eval punk::char { #fixed in bug-4ed788c618 2023-11 #set uc_sequences [regexp -all -inline -indices {[\u0100-\U10FFFF]} $text] #set uc_sequences [regexp -all -inline -indices "\[\u0100-\U10FFFF\]" $text] ;#e.g for string: \U0001f9d1abc\U001f525ab returns {0 0} {4 4} - set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only foreach c $uc_chars { if {[regexp $re_ascii_fullwidth $c]} { incr doublewidth_char_count @@ -2364,12 +2364,12 @@ tcl::namespace::eval punk::char { # b)- textutil::wcswidth_char seems to be east-asian-width based - and not a reliable indicator of 'character cells taken by the character when printed to the terminal' despite this statement in tclllib docs. #(character width is a complex context-dependent topic) # c) by checking for a cached console testwidth first - we make this function less deterministic/repeatable depending on whether console tests have been run. - # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here + # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here #Despite all this - the mechanism is hoped to give best effort consistency for terminals - #further work needed for combining emojis etc - which can't be done in a per character loop + #further work needed for combining emojis etc - which can't be done in a per character loop #todo - see if wcswidth does any of this. It is very slow for strings that include mixed ascii/unicode - so perhaps we can use a perlish_split # to process sequences of unicode. - #- and the user has the option to test character sets first if terminal position reporting gives better results + #- and the user has the option to test character sets first if terminal position reporting gives better results if {[char_info_is_testwidth_cached $c]} { set width [char_info_testwidth_cached $c] } else { @@ -2378,7 +2378,7 @@ tcl::namespace::eval punk::char { set width [textutil::wcswidth_char [scan $c %c]] } if {$width == 0} { - incr zerowidth_char_count + incr zerowidth_char_count } elseif {$width == 2} { incr doublewidth_char_count } @@ -2395,7 +2395,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2416,11 +2416,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2437,7 +2437,7 @@ tcl::namespace::eval punk::char { return [tcl::string::length $text] } - #slow when ascii mixed with unicode (but why?) + #slow when ascii mixed with unicode (but why?) return [punk::char::wcswidth $text] } #This shouldn't be called on text containing ansi codes! @@ -2516,11 +2516,11 @@ tcl::namespace::eval punk::char { return [format $fmt {*}$declist] } - #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) + #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) proc combiner_split {text} { #split into odd numbered list (or zero) in a similar way to punk::ansi::ta::_perlish_split # - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set graphemes [list] if {[tcl::string::length $text] == 0} { return {} @@ -2528,12 +2528,12 @@ tcl::namespace::eval punk::char { set list [list] set start 0 set strlen [tcl::string::length $text] - #make sure our regexes aren't non-greedy - or we may not have exit condition for loop + #make sure our regexes aren't non-greedy - or we may not have exit condition for loop #review while {$start < $strlen && [regexp -start $start -indices -- {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} $text match]} { lassign $match matchStart matchEnd #puts "->start $start ->match $matchStart $matchEnd" - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] } lappend list [tcl::string::range $text $start end] @@ -2547,7 +2547,7 @@ tcl::namespace::eval punk::char { #This is difficult in Tcl without unicode property based Character Classes in the regex engine #review - this needs to be performant - it is used a lot by punk terminal/ansi features #todo - trie data structures for unicode? - #for now we can at least combine diacritics + #for now we can at least combine diacritics #should also handle the ZWJ (and the variation selectors? eg \uFE0F) character which should account for emoji clusters #Note - emoji cluster could be for example 11 code points/41 bytes (family emoji with skin tone modifiers for each member, 3 ZWJs) #This still leaves a whole class of clusters.. korean etc unhandled :/ @@ -2560,7 +2560,7 @@ tcl::namespace::eval punk::char { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] lappend graphemes [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2575,7 +2575,7 @@ tcl::namespace::eval punk::char { set combiner_decs [scan $combiners [tcl::string::repeat %c [tcl::string::length $combiners]]] lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] lappend graphemes {*}$pt_decs - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[scan [lindex $csplits end] [tcl::string::repeat %c [tcl::string::length [lindex $csplits end]]]] @@ -2592,7 +2592,7 @@ tcl::namespace::eval punk::char { lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] } lappend graphemes {*}$pt_decs - } + } return $graphemes } proc grapheme_split2 {text} { @@ -2601,7 +2601,7 @@ tcl::namespace::eval punk::char { foreach {pt combiners} [lrange $csplits 0 end-1] { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2645,10 +2645,10 @@ tcl::namespace::eval punk::char { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::char [tcl::namespace::eval punk::char { 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/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm index fbce0905..ac70e97b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -32,7 +32,7 @@ tcl::namespace::eval punk::config { if {$exename ne ""} { set exefolder [file dirname $exename] #default file logs to logs folder at same level as exe if writable, or empty string - set log_folder [file normalize $exefolder/../logs] + set log_folder [file normalize $exefolder/../logs] ;#~2ms #tcl::dict::set startup scriptlib $exefolder/scriptlib #tcl::dict::set startup apps $exefolder/../../punkapps 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 a8884746..a3f5d95c 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 @@ -777,13 +777,13 @@ namespace eval punk::console { set extension [lindex [split $waitvar($callid) -] 1] if {$extension eq ""} { puts "blank extension $waitvar($callid)" - puts "->[set $waitvar($callid]<-" + puts "->[set $waitvar($callid)]<-" } puts stderr "get_ansi_response_payload Extending timeout by $extension" after cancel $timeoutid($callid) set total_elapsed [expr {[clock millis] - $tslaunch($callid)}] set last_elapsed [expr {[clock millis] - $lastvwait}] - set remaining [expr {$remaining - $last_elapsed}] + set remaining [expr {$remaining - $last_elapsed}] if {$remaining < 0} {set remaining 0} set newtime [expr {$remaining + $extension}] set timeoutid($callid) [after $newtime [list set $waitvarname timedout]] @@ -797,7 +797,7 @@ namespace eval punk::console { } } } - #response handler automatically removes it's own chan event + #response handler automatically removes it's own chan event chan event $input readable {} ;#explicit remove anyway - review if {$waitvar($callid) ne "timedout"} { @@ -814,7 +814,7 @@ namespace eval punk::console { #it *might* be ok to restore entire state on an input channel #(it's not always on all channels - e.g stdout has -winsize which is read-only) #Safest to only restore what we think we've modified. - fconfigure $input -blocking [dict get $previous_input_state -blocking] + chan configure $input -blocking [dict get $previous_input_state -blocking] @@ -828,10 +828,10 @@ namespace eval punk::console { set prefixdata [string range $input_read {*}$prefix_indices] if {!$ignoreok && $prefixdata ne ""} { #puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (responsedata=[ansistring VIEW -lf 1 $responsedata])" - lappend input_chunks_waiting($input) $prefixdata + lappend input_chunks_waiting($input) $prefixdata } - } else { - #timedout - or eof? + } else { + #timedout - or eof? if {!$ignoreok} { puts stderr "get_ansi_response_payload callid:$callid regex match '$capturingendregex' to input_read '[ansistring VIEW -lf 1 -vt 1 $input_read]' not found" lappend input_chunks_waiting($input) $input_read @@ -872,11 +872,11 @@ namespace eval punk::console { flush stdout #concat and supply to existing handler in single text block - review - #Note will only + #Note will only set waitingdata [join $input_chunks_waiting($input) ""] set input_chunks_waiting($input) [list] #after idle [list after 0 [list {*}$existing_handler $waitingdata]] - after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review + after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review unset waitingdata } else { #! todo? for now, emit a clue as to what's happening. @@ -942,7 +942,7 @@ namespace eval punk::console { #review - reading 1 byte at a time and repeatedly running the small capturing/completion regex seems a little inefficient... but we don't have a way to peek or put back chars (?) #review (we do have the punk::console::input_chunks_waiting($chan) array to cooperatively put back data - but this won't work for user scripts not aware of this) #review - timeout - what if terminal doesn't put data on stdin? error vs stderr report vs empty results - #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? + #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? #e.g what happens to mouse-events while user code is executing? #we may still need this handler if such a loop doesn't exist. proc ansi_response_handler_regex {chan callid endregex} { @@ -973,14 +973,14 @@ namespace eval punk::console { chan event $chan readable {} set waits($callid) ok } else { - # 30ms 16ms? + # 30ms 16ms? set tsnow [clock millis] set total_elapsed [expr {[set tslaunch($callid)] - $tsnow}] set last_elapsed [expr {[set tsclock($callid)] - $tsnow}] if {[string length $chunks($callid)] % 10 == 0 || $last_elapsed > 16} { if {$total_elapsed > 3000} { #REVIEW - #too long since initial read handler launched.. + #too long since initial read handler launched.. #is other data being pumped into stdin? Eventloop starvation? Did we miss our codes? #For now we'll stop extending the timeout. after cancel $::punk::console::ansi_response_timeoutid($callid) @@ -1009,7 +1009,7 @@ namespace eval punk::console { chan event $chan readable {} # Something else puts stderr "ansi_response_handler_regex Situation shouldn't be possible. No error and no bytes read on channel $chan but not chan blocked or EOF" - set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof + set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof } } } ;#end namespace eval internal @@ -1034,7 +1034,7 @@ namespace eval punk::console { if {$ansi_wanted <= 0} { return } - #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here + #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here #tailcall punk::ansi::a+ {*}$args ::punk::ansi::a+ {*}$args } @@ -1092,7 +1092,7 @@ namespace eval punk::console { } default { set ansi_wanted 2 - } + } default { error "punk::console::ansi expected 0|1|on|off|true|false|yes|no|default" } @@ -1133,9 +1133,9 @@ namespace eval punk::console { } #test - find a better place to set terminal type - variable is_vt52 0 + variable is_vt52 0 proc vt52 {{onoff {}}} { - #todo - return to colour state beforehand?. support 0-15 vt52 colours? + #todo - return to colour state beforehand?. support 0-15 vt52 colours? #we shouldn't have to trun off colour to enter vt52 - we should make punk::console emit correct codes variable is_vt52 if {$onoff eq ""} { @@ -1146,7 +1146,7 @@ namespace eval punk::console { } if {$is_vt52} { if {!$onoff} { - puts -nonewline "\x1b<" + puts -nonewline "\x1b<" set is_vt52 0 colour on } @@ -1156,7 +1156,7 @@ namespace eval punk::console { set is_vt52 1 colour off } else { - puts -nonewline "\x1b<" + puts -nonewline "\x1b<" #emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ } } @@ -1222,10 +1222,10 @@ namespace eval punk::console { return $onoff } else { if {$onoff} { - {*}[auto_execok stty] echo + {*}[auto_execok stty] echo return 1 } else { - {*}[auto_execok stty] -echo + {*}[auto_execok stty] -echo return 0 } } @@ -1259,7 +1259,7 @@ namespace eval punk::console { set expected [dict get $opts -expected_ms] set capturingregex {(((.*)))$} ;#capture entire response same as response-payload - set ts_start [clock millis] + set ts_start [clock millis] set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] set ts_end [clock millis] puts stderr $response @@ -1273,7 +1273,7 @@ namespace eval punk::console { # -- --- --- --- --- --- --- #get_ansi_response functions - #review - can these functions sensibly be used on channels not attached to the local console? + #review - can these functions sensibly be used on channels not attached to the local console? #ie can we default to {stdin stdout} but allow other channel pairs? # -- --- --- --- --- --- --- proc get_cursor_pos {{inoutchannels {stdin stdout}}} { @@ -1284,13 +1284,13 @@ namespace eval punk::console { #e.g \033\[46;1R set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} ;#must capture prefix,entire-response,response-payload - set request "\033\[6n" + set request "\033\[6n" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] #some terminals fail to respond properly to \x1b\[6n but do respond to \x1b\[?6n and vice-versa :/ - #todo - what? + #todo - what? #often terminals that fail will just put the raw request code on stdin - we could detect that and then #try the other? - + return $payload } proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} { @@ -1333,7 +1333,7 @@ namespace eval punk::console { proc get_device_attributes {{inoutchannels {stdin stdout}}} { #DA1 variable last_da1_result - #first element in result is the terminal's architectural class 61,62,63,64.. ? + #first element in result is the terminal's architectural class 61,62,63,64.. ? #for vt100 we get things like: "ESC\[?1;0c" #for vt102 "ESC\[?6c" @@ -1368,7 +1368,7 @@ namespace eval punk::console { proc get_tabstops {{inoutchannels {stdin stdout}}} { #DECTABSR \x1b\[2\$w #response example " ^[P2$u9/17/25/33/41/49/57/65/73/81^[\ " (where ^[ is \x1b) - #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} + #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} #set capturingregex {(.*)(\x1bP2$u((?:[0-9]+)*(?:\/[0-9]+)*)\x1b\\)$} set capturingregex {(.*)(\x1bP2\$u(.*)\x1b\\)$} set request "\x1b\[2\$w" @@ -1387,7 +1387,7 @@ namespace eval punk::console { #either terminal failed to report - or none set. set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } #We don't support none - default to 8 return 8 @@ -1397,7 +1397,7 @@ namespace eval punk::console { if {[llength $tslist] == 1} { set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } return 8 } else { @@ -1441,7 +1441,7 @@ namespace eval punk::console { set cell_size "" set cell_size_fallback 10x20 - #todo - change -inoutchannels to -terminalobject with prebuilt default + #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::define { @id -id ::punk::console::cell_size @@ -1450,7 +1450,7 @@ namespace eval punk::console { newsize -default "" -help\ "character cell pixel dimensions WxH or omit to query cell size." - } + } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] @@ -1462,11 +1462,11 @@ namespace eval punk::console { if {$cell_size eq ""} { #not set - try to query terminal's overall dimensions set pixeldict [punk::console::get_xterm_pixels $inoutchannels] - lassign $pixeldict _w sw _h sh + lassign $pixeldict _w sw _h sh if {[string is integer -strict $sw] && [string is integer -strict $sh]} { lassign [punk::console::get_size] _cols columns _rows rows #review - is returned size in pixels always a multiple of rows and cols? - set w [expr {$sw / $columns}] + set w [expr {$sw / $columns}] set h [expr {$sh / $rows}] set cell_size ${w}x${h} return $cell_size @@ -1511,7 +1511,7 @@ namespace eval punk::console { return [expr {$payload in {Z K M}}] } - #todo - determine cursor on/off state before the call to restore properly. + #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { lassign $inoutchannels in out #we can't reliably use [chan names] for stdin,stdout. There could be stacked channels and they may have a names such as file22fb27fe810 @@ -1521,7 +1521,7 @@ namespace eval punk::console { } else { if {$is_eof} { error "punk::console::get_size eof on output channel $out ([info level 1])" - } + } } #we don't need to care about the input channel if chan configure on the output can give us the info. #short circuit ansi cursor movement method if chan configure supports the -winsize value @@ -1529,7 +1529,7 @@ namespace eval punk::console { if {[dict exists $outconf -winsize]} { #this mechanism is much faster than ansi cursor movements #REVIEW check if any x-platform anomalies with this method? - #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least + #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least lassign [dict get $outconf -winsize] cols lines if {[string is integer -strict $cols] && [string is integer -strict $lines]} { return [list columns $cols rows $lines] @@ -1542,7 +1542,7 @@ namespace eval punk::console { } else { if {$is_eof} { error "punk::console::get_size eof on input channel $in ([info level 1])" - } + } } #keep out of catch - no point in even trying a restore move if we can't get start position - just fail here. @@ -1565,7 +1565,7 @@ namespace eval punk::console { puts -nonewline $out [$func_coff][$movefunc 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols puts -nonewline $out [$movefunc $start_row $start_col][$func_con];flush stdout - set result [list columns $cols rows $lines] + set result [list columns $cols rows $lines] } errM]} { puts -nonewline $out [$movefunc $start_row $start_col] puts -nonewline $out [$func_con] @@ -1578,7 +1578,7 @@ namespace eval punk::console { #faster than get_size when it is using ansi mechanism - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore proc get_size_cursorrestore {{inoutchannels {stdin stdout}}} { lassign $inoutchannels in out - #we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly + #we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly set outconf [chan configure $out] if {[dict exists $outconf -winsize]} { lassign [dict get $outconf -winsize] cols lines @@ -1592,8 +1592,8 @@ namespace eval punk::console { #This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::cursor_save_dec][punk::ansi::move 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols - puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out - set result [list columns $cols rows $lines] + puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out + set result [list columns $cols rows $lines] } errM]} { puts -nonewline $out [punk::ansi::cursor_restore_dec] puts -nonewline $out [punk::ansi::cursor_on] @@ -1611,14 +1611,14 @@ namespace eval punk::console { set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[18t" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] - lassign [split $payload {;}] rows cols + lassign [split $payload {;}] rows cols return [list columns $cols rows $rows] } proc get_xterm_pixels {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[4;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[14t" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] - lassign [split $payload {;}] height width + lassign [split $payload {;}] height width return [list width $width height $height] } @@ -1629,7 +1629,7 @@ namespace eval punk::console { set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } - #Terminals generally default to LNM being reset (off) ie enter key sends a lone + #Terminals generally default to LNM being reset (off) ie enter key sends a lone #Terminals tested on windows either don't respond to this query, or respond with 0 (meaning mode not understood) #I presume from this that almost nobody is using LNM 1 (which sends both and ) proc get_mode_LNM {{inoutchannels {stdin stdout}}} { @@ -1689,7 +1689,7 @@ namespace eval punk::console { #terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate. #todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position. #todo - determine if these anomalies are independent of font - #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. + #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. #review - vertical movements (e.g /n /v will cause emit 0 to be ineffective - todo - disallow?) proc test_char_width {char_or_string {emit 0}} { #return 1 @@ -1797,7 +1797,7 @@ namespace eval punk::console { #don't set ansi_avaliable here - we want to be able to change things, retest etc. if {"windows" eq "$::tcl_platform(platform)"} { if {[package provide twapi] ne ""} { - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set existing_mode [twapi::GetConsoleMode $h_out] if {[expr {$existing_mode & 4}]} { #virtual terminal processing happens to be enabled - so it's supported @@ -1808,12 +1808,12 @@ namespace eval punk::console { #try temporarily setting it - if we get an error - ansi not supported if {[catch { - twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] } errM]} { return 0 } #restore - twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] return 1 } else { #todo - try a cursorpos query and read stdin to see if we got a response? @@ -1837,26 +1837,26 @@ namespace eval punk::console { set ansi_available [test_can_ansi] return $ansi_available } - return 1 + return 1 } - variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested + variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested #todo - flag to retest? (for consoles where grapheme cluster support can be disabled e.g via decmode 2027) proc grapheme_cluster_support {} { variable grapheme_cluster_support if {[dict size $grapheme_cluster_support]} { - return $grapheme_cluster_support + return $grapheme_cluster_support } if {[info exists ::env(TERM_PROGRAM)]} { #terminals known to support grapheme clusters, but unable to respond to decmode request 2027 #wezterm (on windows as at 2024-12 decmode 2027 doesn't work) - #REVIEW - what if terminal is remote wezterm? can/will this env variable + #REVIEW - what if terminal is remote wezterm? can/will this env variable # iterm and apple terminal also set TERM_PROGRAM if {[string tolower $::env(TERM_PROGRAM)] in [list wezterm]} { set is_available 1 - return [dict create available 1 mode set] + return [dict create available 1 mode set] } } #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) @@ -1884,7 +1884,7 @@ namespace eval punk::console { set m "BAD_RESPONSE" } } - return [dict create available $is_available mode $m] + return [dict create available $is_available mode $m] } @@ -1947,7 +1947,7 @@ namespace eval punk::console { set was_raw 1 } puts -nonewline stdout \033\[6n ;flush stdout - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 set info [read stdin 20] ;# after 1 if {[string first "R" $info] <=0} { @@ -2015,8 +2015,8 @@ namespace eval punk::console { (aka: cursor home) The sequence emitted will depend on the mode of the - terminal as stored in the consolehandle. - Directly setting the mode via raw escape sequences: + terminal as stored in the consolehandle. + Directly setting the mode via raw escape sequences: e.g unset_mode DECANM for vt52 or puts \x1b< to return to ANSI will not necessarily update the application of @@ -2036,7 +2036,7 @@ namespace eval punk::console { This sequence will generally not be understood by terminals that are not in vt52 mode even if higher modes are supported. - + } @values -min 2 -max 2 row -type integer -help\ @@ -2045,7 +2045,7 @@ namespace eval punk::console { "column number - starting at 1" }] proc move {row col} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { return [punk::ansi::move $row $col] } else { @@ -2053,7 +2053,7 @@ namespace eval punk::console { } } proc move_forward {n} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_forward $n] } else { @@ -2061,7 +2061,7 @@ namespace eval punk::console { } } proc move_back {n} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_back $n] } else { @@ -2075,7 +2075,7 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::move_down $n] } proc move_column {col} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_column $col] } else { @@ -2086,7 +2086,7 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::move_row $row] } proc move_emit {row col data args} { - upvar ::punk::console::is_v52 is_vt52 + upvar ::punk::console::is_v52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] } else { @@ -2226,7 +2226,7 @@ namespace eval punk::console { } proc titleset {windowtitle} { puts -nonewline stdout [punk::ansi::titleset $windowtitle] - } + } proc test_decaln {} { puts -nonewline stdout [punk::ansi::test_decaln] } @@ -2239,10 +2239,10 @@ namespace eval punk::console { if { $ansi_wanted <= 0} { punk::console::local::titleset $windowtitle } else { - ansi::titleset $windowtitle + ansi::titleset $windowtitle } } - #no known pure-ansi solution + #no known pure-ansi solution proc titleget {} { return [local::titleget] } @@ -2272,14 +2272,14 @@ namespace eval punk::console { #experimental proc rhs_prompt {col text} { package require textblock - lassign [textblock::size $text] _w tw _h th + lassign [textblock::size $text] _w tw _h th if {$th > 1} { #move up first.. need to know current line? } #set blanks [string repeat " " [expr {$col + $tw}]] #puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text #puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] - cursor_save_dec + cursor_save_dec #move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text #puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text puts -nonewline [punk::ansi::erase_eol][punk::ansi::move_column $col]$text @@ -2323,7 +2323,7 @@ namespace eval punk::console { 18 30 60 C0 60 30 18 00 00 00 7E 00 7E 00 00 00 60 30 18 0C 18 30 60 00 - 3C 66 0C 18 18 00 18 00 + 3C 66 0C 18 18 00 18 00 } #libungif extras append fontmap1 { @@ -2491,7 +2491,7 @@ namespace eval punk::console { #curses attr off reverse #a noreverse set reverse 0 - set output "" + set output "" set charno 0 foreach char [split $str {}] { binary scan $char c f @@ -2528,9 +2528,9 @@ namespace eval punk::console { } proc display {} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5] punk::console::move $orig_row $orig_col @@ -2539,9 +2539,9 @@ namespace eval punk::console { proc displaystr {str} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr $str 10 5] punk::console::move $orig_row $orig_col @@ -2571,13 +2571,13 @@ namespace eval punk::console { if {$dingbat_heavy_plus_width == 2} { set can_terminal_report_dingbat_width 1 } else { - puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." + puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." } set diacritic_width [punk::console::test_char_width a\u0300] if {$diacritic_width == 1} { set can_terminal_report_diacritic_width 1 } else { - puts stderr "punk::console warning: terminal unable to report diacritic width properly." + puts stderr "punk::console warning: terminal unable to report diacritic width properly." } if {$can_high_unicode && $can_regex_high_unicode && $can_terminal_report_dingbat_width && $can_terminal_report_diacritic_width} { @@ -2617,7 +2617,7 @@ namespace eval punk::console::check { } return $has_bug_legacysymbolwidth } - return 1 + return 1 } variable has_bug_zwsp -1 ;#undetermined proc has_bug_zwsp {} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm index 1f02859b..ca222524 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -9,7 +9,7 @@ # @@ Meta Begin # Application punk::fileline 0.1.0 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::fileline 0 0.1.0] #[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 --}] +#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] #[require punk::fileline] #[keywords module text parse file encoding BOM] #[description] @@ -33,7 +33,7 @@ #[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]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] @@ -42,13 +42,13 @@ # 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 +# 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]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. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -141,7 +141,7 @@ namespace eval punk::fileline::class { variable o_line_epoch variable o_payloadlist variable o_linemap - variable o_LF_C + variable o_LF_C variable o_CRLF_C @@ -158,7 +158,7 @@ namespace eval punk::fileline::class { #[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] - # fconfigure $fd -translation binary + # chan configure $fd -translation binary # set chunkdata [lb]read $fd[rb]] #or # set chunkdata [lb]fileutil::cat -translation binary[rb] @@ -191,7 +191,7 @@ namespace eval punk::fileline::class { set o_bom "" ;#review set o_chunk $datachunk - set o_line_epoch [list] + 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\ @@ -206,11 +206,11 @@ namespace eval punk::fileline::class { } } 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" @@ -261,7 +261,7 @@ namespace eval punk::fileline::class { #[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 + #[para] objName chunk 0 end return [string range $o_chunk $chunkstart $chunkend] } method chunklen {} { @@ -273,7 +273,7 @@ namespace eval punk::fileline::class { 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]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\ @@ -331,7 +331,7 @@ namespace eval punk::fileline::class { if {$opt_ansi} { set ::punk::fileline::ansi::enabled 1 } else { - set ::punk::fileline::ansi::enabled 0 + set ::punk::fileline::ansi::enabled 0 } if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { proc ::punk::fileline::a {args} { @@ -350,7 +350,7 @@ namespace eval punk::fileline::class { } proc ::punk::fileline::ansistrip {str} { if {$::punk::fileline::ansi::enabled} { - tailcall ::punk::fileline::ansi::ansistrip $str + tailcall ::punk::fileline::ansi::ansistrip $str } else { return $str } @@ -361,10 +361,10 @@ namespace eval punk::fileline::class { #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 + #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) " + 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] @@ -402,7 +402,7 @@ namespace eval punk::fileline::class { } else { set linebase $maxline } - set linebase ${sign}$linebase + set linebase ${sign}$linebase } elseif {[string match start* $tail]} { set endmath [string range $tail 5 end] if {[string length $endmath]} { @@ -489,7 +489,7 @@ namespace eval punk::fileline::class { 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 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] @@ -503,11 +503,11 @@ namespace eval punk::fileline::class { set e [dict get $lineinfo end] set boundarymarker "" - set displayidx "" + 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 [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] @@ -527,29 +527,29 @@ namespace eval punk::fileline::class { set linenum_display ${linenum_display},$idx } - set lhs_status $opt_cmark ;#default + 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 + set lhs_status $opt_tmark + set rhs_status $opt_tmark } elseif {"left" in $tside} { - set lhs_status $opt_tmark + set lhs_status $opt_tmark } elseif {"right" in $tside} { set rhs_status $opt_tmark } } else { - set line [my line $lineidx] + set line [my line $lineidx] } if {$displayidx ne ""} { - set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] + 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 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 *] @@ -586,12 +586,12 @@ namespace eval punk::fileline::class { 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]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 + 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] @@ -641,13 +641,13 @@ namespace eval punk::fileline::class { set opt_strategy [dict get $opts -strategy] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_start [dict get $opts -start] - set opt_start [expr {$opt_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 + set opt_end $max_line_index } #TODO if {$opt_end < $max_line_index} {error "-end less than max_line_index unimplemented"} @@ -705,7 +705,7 @@ namespace eval punk::fileline::class { #[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 + lassign [my numeric_linerange $lineindex 0] lineindex return [lindex $o_payloadlist $lineindex] } method linepayloads {startindex endindex} { @@ -722,17 +722,17 @@ namespace eval punk::fileline::class { #[list_begin itemized] #[item] le #[para] A string representing the type of line-ending: crlf|lf|none - #[item] linelen + #[item] linelen #[para] The number of characters/bytes in the whole line including line-ending if any - #[item] payloadlen + #[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 + #[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 + lassign [my numeric_linerange $lineindex 0] lineindex dict get $o_linemap $lineindex } method lineinfo {lineindex} { @@ -797,7 +797,7 @@ namespace eval punk::fileline::class { 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 + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set linestart -1 for {set i 0} {$i < [llength $o_payloadlist]} {incr i} { @@ -829,7 +829,7 @@ namespace eval punk::fileline::class { #[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 + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set defaults [dict create\ -show_truncated 0\ ] @@ -840,9 +840,9 @@ namespace eval punk::fileline::class { } } 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] @@ -878,8 +878,8 @@ namespace eval punk::fileline::class { 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 + dict set first truncated $truncated + dict set first truncatedleft $lhs } } ########################### @@ -908,7 +908,7 @@ namespace eval punk::fileline::class { if {$chunkend < [dict get $end_info end]} { #there is rhs truncation if {[dict get $first is_truncated]} { - dict set first truncatedside [list left right] + dict set first truncatedside [list left right] } else { dict set first is_truncated 1 dict set first truncatedside [list right] @@ -925,7 +925,7 @@ namespace eval punk::fileline::class { 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 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]} { @@ -971,13 +971,13 @@ namespace eval punk::fileline::class { set payload_and_le "${payload}${le_chars}" set split [expr {$chunkend - $line_start}] - set truncated [string range $payload_and_le 0 $split] + 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' + #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' } } @@ -991,7 +991,7 @@ namespace eval punk::fileline::class { ########################### #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. + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. return $infolist } @@ -1017,12 +1017,12 @@ namespace eval punk::fileline::class { #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 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. @@ -1035,7 +1035,7 @@ namespace eval punk::fileline::class { #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] } @@ -1061,13 +1061,13 @@ namespace eval punk::fileline::class { 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]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 + #[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 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] { @@ -1078,9 +1078,9 @@ namespace eval punk::fileline::class { set index $max } "*-*" { - #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions + #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions lassign [split $index -] A B - if {$A eq "end"} { + if {$A eq "end"} { set index [expr {$max - $B}] } else { set index [expr {$A - $B}] @@ -1088,7 +1088,7 @@ namespace eval punk::fileline::class { } "*+*" { lassign [split $index +] A B - if {$A eq "end"} { + 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}] @@ -1098,9 +1098,9 @@ namespace eval punk::fileline::class { } 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. + #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 + #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 } @@ -1109,13 +1109,13 @@ namespace eval punk::fileline::class { } } } - #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. + #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" + 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)" + error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" } return [list $startidx $endidx] } @@ -1136,7 +1136,7 @@ namespace eval punk::fileline::class { 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 lf_lines [split $normalised_data $o_LF_C] set idx 0 set lf_count 0 @@ -1145,14 +1145,14 @@ namespace eval punk::fileline::class { set i 0 set imax [expr {[llength $lf_lines]-1}] foreach lfln $lf_lines { - set crlf_parts [split $lfln $o_CRLF_C] + 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 + #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 @@ -1177,7 +1177,7 @@ namespace eval punk::fileline::class { 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 filedata_offset $linelen incr crlf_count incr idx } @@ -1200,7 +1200,7 @@ namespace eval punk::fileline::class { set le lf } - lappend o_payloadlist $lfpart + 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 @@ -1221,8 +1221,11 @@ namespace eval punk::fileline::class { #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 + #??? + #set } @@ -1248,19 +1251,19 @@ namespace eval punk::fileline { #*** !doctools #[subsection {Namespace punk::fileline}] - #[para] Core API functions for punk::fileline + #[para] Core API functions for punk::fileline #[list_begin definitions] - punk::args::define { + 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 + -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]] @@ -1272,7 +1275,7 @@ namespace eval punk::fileline { #[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]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. @@ -1285,10 +1288,10 @@ namespace eval punk::fileline { # -- --- --- --- if {$opt_file ne ""} { - set filename $opt_file - set fd [open $filename r] - fconfigure $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 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]} { @@ -1335,7 +1338,7 @@ namespace eval punk::fileline { 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) + #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 @@ -1360,7 +1363,7 @@ namespace eval punk::fileline { set bomenc "binary" ;# utf-8??? set startdata 3 } elseif {$maybe_bom eq "84319533"} { - if {![dict exists [punk::char::page_names_dict gb18030]]} { + 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 { @@ -1374,7 +1377,7 @@ namespace eval punk::fileline { 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!" + 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 @@ -1433,7 +1436,7 @@ namespace eval punk::fileline { } 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]] @@ -1443,7 +1446,7 @@ namespace eval punk::fileline { #!? if {$bomenc eq "binary"} { set datachunk [string range $rawchunk $startdata end] - set encoding_selected binary + set encoding_selected binary } else { set datachunk [encoding convertfrom utf-8 [string range $rawchunk $startdata end]] set encoding_selected utf-8 @@ -1485,7 +1488,7 @@ namespace eval punk::fileline { proc file_boundary_display {filename startbyte endbyte chunksize args} { set fd [open $filename r] ;#use default error if file not readable - fconfigure $fd -translation binary + chan configure $fd -translation binary set rawfiledata [read $fd] close $fd set textobj [class::textinfo new $rawfiledata] @@ -1510,7 +1513,7 @@ namespace eval punk::fileline::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::fileline::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] @@ -1532,12 +1535,12 @@ namespace eval punk::fileline::lib { #[para]e.g #[example_begin] # range_spans_chunk_boundaries 10 1750 512 - # is_span 1 boundaries {512 1024 1536} + # is_span 1 boundaries {512 1024 1536} #[example_end] - #[para]The -offset option + #[para]The -offset option #[example_begin] # range_spans_chunk_boundaries 10 1750 512 -offset 2 - # is_span 1 boundaries {514 1026 1538} + # 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-}]} { @@ -1576,12 +1579,12 @@ namespace eval punk::fileline::lib { namespace eval punk::fileline::system { #*** !doctools #[subsection {Namespace punk::fileline::system}] - #[para] Internal functions that are not part of the API + #[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 + return [binary format S* $elements] ;#format big endian } proc wordswap32 {data} { binary scan $data i* elements @@ -1622,7 +1625,7 @@ namespace eval punk::fileline::system { 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 @@ -1632,7 +1635,7 @@ namespace eval punk::fileline::system { } else { set overflow 0 } - set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] + set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] if {$overflow} { #we don't know how many overflowed.. set inrange [list] @@ -1668,7 +1671,7 @@ namespace eval punk::fileline::system { set opt_offset [dict get $opts -offset] # -- --- --- --- - set is_span 0 + set is_span 0 set smod [expr {$start % $chunksize}] if {$smod != 0} { set start [expr {$start + ($chunksize - $smod)}] @@ -1681,7 +1684,7 @@ namespace eval punk::fileline::system { 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 + incr btrack $chunksize set boff [expr {$btrack + $opt_offset}] } set bstart $btrack @@ -1689,9 +1692,9 @@ namespace eval punk::fileline::system { set bstart $start } for {set b $bstart} {[set boff [expr {$b + $opt_offset}]] <= $end} {incr b $chunksize} { - lappend boundaries $boff - } - + lappend boundaries $boff + } + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries offset $opt_offset] } @@ -1707,7 +1710,7 @@ 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 + #[para]See [package punk::ansi] for documentation #[list_begin definitions] variable enabled 1 #*** !doctools @@ -1720,11 +1723,11 @@ namespace eval punk::fileline::ansi { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::fileline [namespace eval punk::fileline { variable pkg punk::fileline 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/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm index 09a73385..b6c6dd4a 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application punk::lib 0.1.1 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::lib 0 0.1.1] #[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 --}] +#[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]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 # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -34,7 +34,7 @@ #[section Overview] #[para] overview of punk::lib #[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[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. @@ -108,7 +108,7 @@ tcl::namespace::eval punk::lib::ensemble { tcl::namespace::eval $extension [ list namespace ensemble create -command $routine -unknown [ list apply {{renamed ensemble routine args} { - list $renamed $routine + list $renamed $routine }} $renamed ] ] @@ -126,7 +126,7 @@ tcl::namespace::eval punk::lib::check { uplevel #0 $script set rep1 [tcl::unsupported::representation $::j] set script "" - set rep2 [tcl::unsupported::representation $::j] + set rep2 [tcl::unsupported::representation $::j] set nostring1 [string match "*no string" $rep1] set nostring2 [string match "*no string" $rep2] @@ -185,15 +185,15 @@ tcl::namespace::eval punk::lib::check { #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 + 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 + #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} { @@ -244,7 +244,7 @@ tcl::namespace::eval punk::lib::compat { 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 + #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 ""} { @@ -305,7 +305,7 @@ tcl::namespace::eval punk::lib::compat { 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 + #[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] @@ -356,7 +356,7 @@ tcl::namespace::eval punk::lib::compat { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -454,7 +454,7 @@ namespace eval punk::lib { #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) proc aliases {{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] + 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]]} { @@ -464,7 +464,7 @@ namespace eval punk::lib { set segcount [llength $segments] ;#only match number of segments matching current ns - set all_aliases [interp aliases {}] + set all_aliases [interp aliases {}] set matched [list] foreach a $all_aliases { #normalize with leading :: @@ -477,7 +477,7 @@ namespace eval punk::lib { set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] set acount [llength $asegs] #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {[expr {$acount - 1}] == $segcount} { + 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 @@ -485,7 +485,7 @@ namespace eval punk::lib { } } } - } + } #set matched_abs [lsearch -all -inline $all_aliases $glob] return $matched @@ -513,7 +513,7 @@ namespace eval punk::lib { set target [interp alias "" $aliasorglob] if {[llength $target]} { return $target - } + } if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { set aliaslist [punk::lib::aliases $aliasorglob] @@ -611,7 +611,7 @@ namespace eval punk::lib { } } 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. @@ -619,10 +619,10 @@ namespace eval punk::lib { #also 1b3 == 1b0003 if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "tm_version_required_canonical - invalid version specification" + 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 + #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'" @@ -634,7 +634,7 @@ namespace eval punk::lib { error "$errmsg '$versionspec'" } } else { - # min- or min-max + # 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 @@ -700,29 +700,29 @@ namespace eval punk::lib { #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 + #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) set a_index [lindex_resolve $l $a] set a_msg "" switch -- $a_index { -2 { - set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" + set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" } -3 { - set a_msg "1st supplied index $a is below the lower bound for the list (0)" + set a_msg "1st supplied index $a is below the lower bound for the list (0)" } } set z_index [lindex_resolve $l $z] set z_msg "" switch -- $z_index { -2 { - set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" - } + set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" + } -3 { - set z_msg "2nd supplied index $z is below the lower bound for the list (0)" + set z_msg "2nd supplied index $z is below the lower bound for the list (0)" } } - set errmsg "lswap cannot swap indices $a and $z" + set errmsg "lswap cannot swap indices $a and $z" if {$a_msg ne ""} { append errmsg \n $a_msg } @@ -732,7 +732,7 @@ namespace eval punk::lib { error $errmsg } set item2 [lindex $l $z] - lset l $z [lindex $l $a] + lset l $z [lindex $l $a] lset l $a $item2 return $l } @@ -760,20 +760,20 @@ namespace eval punk::lib { #proc swap_intvars2 {swapv1 swapv2} { # upvar $swapv1 _x $swapv2 _y # set _x [expr {$_x ^ $_y}] - # set _y [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 _x $_y # set _y $z #} #*** !doctools #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib + #[para] Core API functions for punk::lib #[list_begin definitions] if {[info commands lseq] ne ""} { @@ -785,7 +785,7 @@ namespace eval punk::lib { } } else { #lseq accepts basic expressions e.g 4-2 for both arguments - #e.g we can do lseq 0 [llength $list]-1 + #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] @@ -798,16 +798,16 @@ namespace eval punk::lib { incr from -1 return [lmap v [lrepeat $count 0] {incr from}] } - #slower methods. + #slower methods. #2) - #set i -1 + #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] + # lappend L [incr from] #} #return $L } elseif {$from > $to} { @@ -821,14 +821,14 @@ namespace eval punk::lib { } #2) - #set i -1 + #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] + # lappend L [incr from -1] #} #return $L } else { @@ -839,7 +839,7 @@ namespace eval punk::lib { proc lzip {args} { switch -- [llength $args] { - 0 {return {}} + 0 {return {}} 1 {return [lindex $args 0]} 2 {return [lzip2lists {*}$args]} 3 {return [lzip3lists {*}$args]} @@ -874,7 +874,7 @@ namespace eval punk::lib { } proc Build_lzipn {n} { - set arglist [list] + 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 " @@ -890,7 +890,7 @@ namespace eval punk::lib { puts "proc punk::lib::lzip${n}lists {$arglist} \{" puts "$body" puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body + proc ::punk::lib::lzip${n}lists $arglist $body } #fastest is to know the number of lists to be zipped @@ -923,7 +923,7 @@ namespace eval punk::lib { } #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - + # review - proc lzipn_alt args { #stackoverflow - courtesy glenn jackman (modified) foreach l $args { @@ -961,7 +961,7 @@ namespace eval punk::lib { 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 $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] ledit flatlist $s [expr {$s + $len - 1}] {*}$list incr s $numcolumns } @@ -977,7 +977,7 @@ namespace eval punk::lib { set numcolumns [::tcl::mathfunc::max {*}$lens] set flatlist [list] foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] } lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} } @@ -988,9 +988,9 @@ namespace eval punk::lib { set numcolumns [::tcl::mathfunc::max {*}$lens] set flatlist [list] foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] } - set zip_l {} + set zip_l {} set cols_remaining $numcolumns for {set c 0} {$c < $numcolumns} {incr c} { if {$cols_remaining == 1} { @@ -1006,14 +1006,14 @@ namespace eval punk::lib { #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] } - + namespace import ::punk::args::lib::tstr - + proc invoke command { @@ -1030,7 +1030,7 @@ namespace eval punk::lib { #}] #see https://wiki.tcl-lang.org/page/open - lassign [chan pipe] chanout chanin + lassign [chan pipe] chanout chanin lappend command 2>@$chanin set fh [open |$command] set stdout [read $fh] @@ -1045,7 +1045,7 @@ namespace eval punk::lib { } elseif {$sysmsg eq {CHILDSTATUS}} { return [list $stdout $stderr $exit] } else { - return -options $e $stderr + return -options $e $stderr } } return [list $stdout $stderr 0] @@ -1055,7 +1055,7 @@ namespace eval punk::lib { package require punk::args variable has_punk_ansi if {!$has_punk_ansi} { - set sep " = " + set sep " = " } else { #set sep " [a+ Web-seagreen]=[a] " set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " @@ -1081,18 +1081,18 @@ namespace eval punk::lib { 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) + 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. + 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 + 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 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 */%# + 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* + 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. @@ -1101,9 +1101,9 @@ namespace eval punk::lib { 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 segement 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. + 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::get_dict $argspec $args] @@ -1152,7 +1152,7 @@ namespace eval punk::lib { @cmd -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject -return -default "tailtohead" -choices {tailtohead sidebyside} - -channel -default none + -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 @@ -1181,7 +1181,7 @@ namespace eval punk::lib { }] $args] #for punk::lib - we want to reduce pkg dependencies. - # - so we won't even use the tcllib debug pkg here + # - 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 ""} { @@ -1222,18 +1222,18 @@ namespace eval punk::lib { 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 + #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: + #we currently return: #0 = v0 #1 = v1 #2 = v2 @@ -1245,7 +1245,7 @@ namespace eval punk::lib { #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}} { @@ -1263,7 +1263,7 @@ namespace eval punk::lib { set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] #puts stderr "showdict-->_split_patterns: $patterninfo" foreach v_idx $patterninfo { - lassign $v_idx v idx + 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 "!"} { @@ -1283,28 +1283,28 @@ namespace eval punk::lib { set keys [dict keys $dval] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p 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 } } %# { - 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 + dict set pattern_this_structure $p list lappend keyset # lappend keyset_structure list } ## { - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict lappend keyset [list ## query] - lappend keyset_structure dict + lappend keyset_structure dict } @* { #puts "showdict ---->@*<----" @@ -1323,19 +1323,19 @@ namespace eval punk::lib { #returns keys only lappend keyset [list $p query] lappend keyset_structure dict - dict set pattern_this_structure $p 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 + 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 + #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 @@ -1351,7 +1351,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @@* { #exact match key - review - should raise error to match punk pipe behaviour? @@ -1360,10 +1360,10 @@ namespace eval punk::lib { if {[dict exists $dval $k]} { set keys [dict keys [dict remove $dval $k]] lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] + lappend keyset_structure {*}[lrepeat [llength $keys] dict] } else { lappend keyset {*}[dict keys $dval] - lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] } } else { if {[dict exists $dval $k]} { @@ -1371,7 +1371,7 @@ namespace eval punk::lib { lappend keyset_structure dict } } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @k@* - @K@* { #TODO get_not @@ -1380,7 +1380,7 @@ namespace eval punk::lib { lappend keyset $k lappend keyset_structure dict } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*@*} { #return list of values @@ -1392,7 +1392,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*.@*} { #TODO get_not @@ -1400,61 +1400,61 @@ namespace eval punk::lib { set keys [dict keys $dval $k] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p 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'" + #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 + 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 + 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 + 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 + dict set pattern_this_structure $p dict } default { - set this_type $opt_roottype + set this_type $opt_roottype if {[string match @* $p]} { - #list mode - trim optional list specifier @ + #list mode - trim optional list specifier @ set p [string range $p 1 end] - dict set pattern_this_structure $p list - set this_type list + dict set pattern_this_structure $p list + set this_type list } elseif {[string match %* $p]} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string lappend keyset $p - lappend keyset_structure string + lappend keyset_structure string set this_type string } if {$this_type eq "list"} { - dict set pattern_this_structure $p 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] + lappend keyset_structure {*}[lrepeat [llength $keys] list] } else { lappend keyset $p - lappend keyset_structure list + lappend keyset_structure list } } elseif {[string match "?*-?*" $p]} { #could be either - don't change type @@ -1469,7 +1469,7 @@ namespace eval punk::lib { #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds if {${lower_resolve} == -2} { ##x - #lower bound is above upper list range + #lower bound is above upper list range #match with decreasing indices is still possible set lower [expr {[llength $dval]-1}] ;#set to max } elseif {$lower_resolve == -3} { @@ -1510,15 +1510,15 @@ namespace eval punk::lib { } else { lappend keyset [list @$p query] } - lappend keyset_structure list - } + lappend keyset_structure list + } } elseif {$this_type eq "string"} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string } elseif {$this_type eq "dict"} { #default equivalent to @\*@* - dict set pattern_this_structure $p dict + 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] + set keys [dict keys $dval $p] if {$get_not} { set keys [dict keys [dict remove $dval {*}$keys]] } @@ -1533,9 +1533,9 @@ namespace eval punk::lib { } } - # -- --- --- --- + # -- --- --- --- #check next pattern-segment for substructure type to use - # -- --- --- --- + # -- --- --- --- set substructure "" set pnext [lindex $segments 1] set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] @@ -1556,7 +1556,7 @@ namespace eval punk::lib { set substructure dict } # { - set substructure list + set substructure list } ## { set substructure dict @@ -1579,7 +1579,7 @@ namespace eval punk::lib { if {[string match @* $pnext]} { set substructure list } elseif {[string match %* $pnext]} { - set substructure string + set substructure string } else { #set substructure $opt_roottype #set substructure [dict get $pattern_this_structure $pattern_nest] @@ -1590,13 +1590,13 @@ namespace eval punk::lib { } } } else { - #e.g /@0,%str,.../ + #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 @@ -1629,7 +1629,7 @@ namespace eval punk::lib { } #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" } else { - puts stdout "unrecognised roottype: $opt_roottype" + puts stdout "unrecognised roottype: $opt_roottype" return $dval } @@ -1684,7 +1684,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] set subansibasekeys [lrange $opt_ansibase_keys 1 end] @@ -1692,7 +1692,7 @@ namespace eval punk::lib { #dict set nextopts -substructure $nextsub dict set nextopts -keytemplates $nextkeytemplates dict set nextopts -ansibase_keys $subansibasekeys - dict set nextopts -roottype $nextsub + dict set nextopts -roottype $nextsub dict set nextopts -channel none #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" @@ -1724,7 +1724,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] dict set nextopts -roottype $nextsub dict set nextopts -channel none @@ -1751,22 +1751,22 @@ namespace eval punk::lib { set thisval [ansistring VIEWSTYLE -lf 1 $dval] } elseif {[string match *lpad-* $key]} { set hidekey 1 - lassign [split $key -] _ extra + 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 + 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 + 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 + 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 { @@ -1789,14 +1789,14 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - #set nextopts [dict get $argd opts] + #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} { @@ -1838,7 +1838,7 @@ namespace eval punk::lib { } } "sidebyside" { - # TODO - fix + # 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?) @@ -1942,7 +1942,7 @@ namespace eval punk::lib { #also struct::set difference with critcl is faster proc setdiff {A B} { if {[llength $A] == 0} {return {}} - set d [dict create] + set d [dict create] foreach x $A {dict set d $x {}} foreach x $B {dict unset d $x} return [dict keys $d] @@ -1950,7 +1950,7 @@ namespace eval punk::lib { #bulk dict remove is slower than a foreach with dict unset #proc setdiff2 {fromlist removeitems} { # #if {[llength $fromlist] == 0} {return {}} - # set d [dict create] + # set d [dict create] # foreach x $fromlist { # dict set d $x {} # } @@ -1975,8 +1975,8 @@ namespace eval punk::lib { struct::set union $list {} } } else { - puts stderr "WARNING: struct::set union no longer dedupes!" - #we could also test a sequence of: struct::set add + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add } } @@ -2026,9 +2026,9 @@ namespace eval punk::lib { } 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] + } } [info vars] } ] # -- --- --- set cvars [tcl::dict::get $capture vars] @@ -2039,13 +2039,13 @@ namespace eval punk::lib { 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% }] @@ -2075,7 +2075,7 @@ namespace eval punk::lib { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -2110,7 +2110,7 @@ namespace eval punk::lib { # if {[tcl::dict::exists $dictValue {*}$keys]} { # return [tcl::dict::get $dictValue {*}$keys] # } else { - # return [lindex $args end] + # return [lindex $args end] # } #} if {[info commands ::tcl::dict::getdef] eq ""} { @@ -2123,7 +2123,7 @@ namespace eval punk::lib { } } } else { - #we pay a minor perf penalty for the wrap + #we pay a minor perf penalty for the wrap interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef } @@ -2131,13 +2131,13 @@ namespace eval punk::lib { #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" #} #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features @@ -2158,14 +2158,14 @@ namespace eval punk::lib { } } - # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side + # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side proc lindex_resolve {list index} { #*** !doctools #[call [fun lindex_resolve] [arg list] [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 #[para]Users may define procs which accept a list 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]Sometimes the actual integer index is desired. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]lindex_resolve will parse the index expression and return: #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) @@ -2183,13 +2183,13 @@ namespace eval punk::lib { #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { - #can match +i -i + #can match +i -i if {$index < 0} { return -3 } elseif {$index >= [llength $list]} { - return -2 + return -2 } else { - #integer may still have + sign - normalize with expr + #integer may still have + sign - normalize with expr return [expr {$index}] } } else { @@ -2223,7 +2223,7 @@ namespace eval punk::lib { set index [expr {([llength $list]-1) - $offset}] } if {$index < 0} { - return -3 + return -3 } else { return $index } @@ -2258,30 +2258,30 @@ namespace eval punk::lib { #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) #[para] returns -1 for out of range at either end, or a valid integer index #[para] 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 Tcl which has the builtin lseq command + #[para] This is only likely to be faster than average over lindex_resolve 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 + #[para] For pure integer indices the performance should be equivalent #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ - # - which + # - which #for {set i 0} {$i < [llength $list]} {incr i} { # lappend indices $i - #} + #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { - #can match +i -i + #can match +i -i #avoid even the lseq overhead when the index is simple if {$index < 0 || ($index >= [llength $list])} { #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. return -1 } else { - #integer may still have + sign - normalize with expr + #integer may still have + sign - normalize with expr return [expr {$index}] } - } + } if {[llength $list]} { set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. - #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) + #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) } else { set indices [list] } @@ -2290,7 +2290,7 @@ namespace eval punk::lib { #we have no way to determine if out of bounds is at lower vs upper end return -1 } else { - return $idx + return $idx } } proc lindex_get {list index} { @@ -2308,26 +2308,26 @@ namespace eval punk::lib { 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]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. + #[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] 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) + 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 + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for ) $ } $bytes @@ -2347,7 +2347,7 @@ namespace eval punk::lib { 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) + #[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 :-) ^ (?: @@ -2362,7 +2362,7 @@ namespace eval punk::lib { 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] 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. @@ -2377,9 +2377,9 @@ namespace eval punk::lib { [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) ) + } $rawbytes completeChars]} { - return $completeChars - } - return "" + return $completeChars + } + return "" } proc hex2dec {args} { #*** !doctools @@ -2403,10 +2403,10 @@ namespace eval punk::lib { 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} { @@ -2427,7 +2427,7 @@ namespace eval punk::lib { 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}}]] + 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]]] @@ -2460,7 +2460,7 @@ namespace eval punk::lib { 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] { @@ -2504,7 +2504,7 @@ namespace eval punk::lib { #[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 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 expr {log($x)/log($b)} } proc factors {x} { @@ -2513,14 +2513,14 @@ namespace eval punk::lib { #[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]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]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. + #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]* 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 @@ -2537,7 +2537,7 @@ namespace eval punk::lib { proc oddFactors {x} { #*** !doctools #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order + #[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] @@ -2572,7 +2572,7 @@ namespace eval punk::lib { set max [expr {sqrt($x)}] while {$j <= $max} { if {$x % $j == 0} { - return [expr {$x / $j}] + return [expr {$x / $j}] } incr j 2 } @@ -2597,14 +2597,14 @@ namespace eval punk::lib { if {$other % 2 == 0} { set god $j } else { - set god [expr {$x / $j}] + set god [expr {$x / $j}] #lowest j - so other side must be highest break } } incr j 2 } - return $god + return $god } proc greatestOddFactor {x} { #*** !doctools @@ -2660,7 +2660,7 @@ namespace eval punk::lib { #[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]] + return [factors [gcd $x $y]] } #experimental only - there are better/faster ways @@ -2701,8 +2701,8 @@ namespace eval punk::lib { 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. + #[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 } @@ -2720,7 +2720,7 @@ namespace eval punk::lib { proc substring_count {str substring} { #*** !doctools #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of 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} @@ -2736,7 +2736,7 @@ namespace eval punk::lib { #[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] + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] } proc askuser {question} { @@ -2744,7 +2744,7 @@ namespace eval punk::lib { #[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]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 @@ -2755,12 +2755,12 @@ namespace eval punk::lib { # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { # puts "Proceeding" # } else { - # puts "Cancelled by user" + # puts "Cancelled by user" # } #[example_end] puts stdout $question flush stdout - set stdin_state [fconfigure stdin] + set stdin_state [chan configure stdin] if {[catch { package require punk::console set console_raw [tsv::get console is_raw] @@ -2769,7 +2769,7 @@ namespace eval punk::lib { set console_raw 0 } try { - fconfigure stdin -blocking 1 + chan configure stdin -blocking 1 if {$console_raw} { punk::console::disableRaw set answer [gets stdin] @@ -2778,7 +2778,7 @@ namespace eval punk::lib { set answer [gets stdin] } } finally { - fconfigure stdin -blocking [tcl::dict::get $stdin_state -blocking] + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] } return $answer } @@ -2788,7 +2788,7 @@ namespace eval punk::lib { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { - lappend result "" + lappend result "" } else { lappend result $prefix[string trimright $line] } @@ -2827,7 +2827,7 @@ namespace eval punk::lib { } return [join $result \n] } - #A version of textutil::string::longestCommonPrefixList + #A version of textutil::string::longestCommonPrefixList proc longestCommonPrefix {items} { if {[llength $items] <= 1} { return [lindex $items 0] @@ -2844,9 +2844,9 @@ namespace eval punk::lib { } set n [string length $min] set prefix "" - set i -1 + set i -1 while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c + append prefix $c } return $prefix } @@ -2855,7 +2855,7 @@ namespace eval punk::lib { proc linesort {args} { #*** !doctools #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] - #[para]Sort lines in 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} { @@ -2871,7 +2871,7 @@ namespace eval punk::lib { #*** !doctools #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] #[para]This simply joines 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]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 @@ -2903,8 +2903,8 @@ namespace eval punk::lib { #*** !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 + #[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 @@ -2928,7 +2928,7 @@ namespace eval punk::lib { } #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 + #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) @@ -2938,14 +2938,14 @@ namespace eval punk::lib { } $args]] 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" + error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] set text [string map {\r\n \n} $text] ;#review - option? @@ -2957,7 +2957,7 @@ namespace eval punk::lib { -commandprefix ""\ -ansiresets auto\ -ansireplays 0\ - ] + ] foreach {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets - -ansireplays { @@ -2989,16 +2989,16 @@ namespace eval punk::lib { } if {"trimall" in $opt_block} { #no other block options make sense in combination with this - set opt_block [list "trimall"] + set opt_block [list "trimall"] } - #TODO + #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } - + # -- --- --- --- --- --- set opt_line [tcl::dict::get $opts -line] @@ -3056,7 +3056,7 @@ namespace eval punk::lib { } } elseif {$tl_left} { foreach ln $nlsplit { - lappend linelist [string trimleft $ln] + lappend linelist [string trimleft $ln] } } elseif {$tl_right} { foreach ln $nlsplit { @@ -3074,7 +3074,7 @@ namespace eval punk::lib { set last "-" } else { if {$last ne ""} { - lappend linelist "" + lappend linelist "" } set last "" } @@ -3090,11 +3090,11 @@ namespace eval punk::lib { set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { - break + break } else { set lastempty $idx } - incr idx + incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] @@ -3107,7 +3107,7 @@ namespace eval punk::lib { set i 0 foreach ln $revlinelist { if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] + set linelist [lreverse [lrange $revlinelist $i end]] break } incr i @@ -3131,13 +3131,13 @@ namespace eval punk::lib { } #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 + #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" + set RST "\x1b\[0m" } else { set RST "" } @@ -3157,7 +3157,7 @@ namespace eval punk::lib { } } else { - #INLINE punk::ansi::codetype::is_sgr_reset + #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 @@ -3176,30 +3176,30 @@ namespace eval punk::lib { #leave replaycodes as is for next line set nextreplay $replaycodes } else { - set tail $RST + 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 + 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 + 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 + #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 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 + set tail $RST #determine effective replay for line set codestack [list start] foreach code $ansisplits { @@ -3211,7 +3211,7 @@ namespace eval punk::lib { 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. + #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 @@ -3241,7 +3241,7 @@ namespace eval punk::lib { } } else { set nextreplay $replaycodes - } + } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay @@ -3260,7 +3260,7 @@ namespace eval punk::lib { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] - } + } set linelist $transformed } @@ -3271,14 +3271,14 @@ namespace eval punk::lib { 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 + #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" + error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] set text [string map {\r\n \n} $text] ;#review - option? @@ -3290,7 +3290,7 @@ namespace eval punk::lib { -commandprefix ""\ -ansiresets auto\ -ansireplays 0\ - ] + ] foreach {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets - -ansireplays { @@ -3322,16 +3322,16 @@ namespace eval punk::lib { } if {"trimall" in $opt_block} { #no other block options make sense in combination with this - set opt_block [list "trimall"] + set opt_block [list "trimall"] } - #TODO + #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } - + # -- --- --- --- --- --- set opt_line [tcl::dict::get $opts -line] @@ -3389,7 +3389,7 @@ namespace eval punk::lib { } } elseif {$tl_left} { foreach ln $nlsplit { - lappend linelist [string trimleft $ln] + lappend linelist [string trimleft $ln] } } elseif {$tl_right} { foreach ln $nlsplit { @@ -3407,7 +3407,7 @@ namespace eval punk::lib { set last "-" } else { if {$last ne ""} { - lappend linelist "" + lappend linelist "" } set last "" } @@ -3423,11 +3423,11 @@ namespace eval punk::lib { set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { - break + break } else { set lastempty $idx } - incr idx + incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] @@ -3440,7 +3440,7 @@ namespace eval punk::lib { set i 0 foreach ln $revlinelist { if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] + set linelist [lreverse [lrange $revlinelist $i end]] break } incr i @@ -3464,13 +3464,13 @@ namespace eval punk::lib { } #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 + #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" + set RST "\x1b\[0m" } else { set RST "" } @@ -3490,7 +3490,7 @@ namespace eval punk::lib { } } else { - #INLINE punk::ansi::codetype::is_sgr_reset + #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 @@ -3507,28 +3507,28 @@ namespace eval punk::lib { #leave replaycodes as is for next line set nextreplay $replaycodes } else { - set tail $RST + 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 + 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 + 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 + #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 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 + set tail $RST #determine effective replay for line set codestack [list start] foreach {pt code} $ansisplits { @@ -3540,7 +3540,7 @@ namespace eval punk::lib { 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. + #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 @@ -3570,7 +3570,7 @@ namespace eval punk::lib { } } else { set nextreplay $replaycodes - } + } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay @@ -3589,7 +3589,7 @@ namespace eval punk::lib { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] - } + } set linelist $transformed } @@ -3600,17 +3600,17 @@ namespace eval punk::lib { 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 + #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 + 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 + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance set i 0 - set times {} + set times {} if {$iters < 2} {set iters 2} for {set i 0} {$i < $iters} {incr i} { @@ -3629,8 +3629,8 @@ namespace eval punk::lib { set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] } - set sigma [expr {int(sqrt($s2))}] - set average [expr int($average)] + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] return "$average +/- $sigma microseconds per iteration" } @@ -3673,9 +3673,9 @@ namespace eval punk::lib { default { return [list $dec $c] } - } + } + - } @@ -3686,7 +3686,7 @@ namespace eval punk::lib { 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. + #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" @@ -3701,7 +3701,7 @@ namespace eval punk::lib { set data [tcl::unsupported::disassemble method $obj $method] } } else { - error "show_jump_tables expected a procname or a class/object and method" + error "show_jump_tables expected a procname or a class/object and method" } set result "" set in_jt 0 @@ -3786,10 +3786,10 @@ namespace eval punk::lib { } #todo - get configured user defaults if {$delim eq ""} { - set delim $default_delim + set delim $default_delim } if {$groupsize eq ""} { - set groupsize $default_groupsize + set groupsize $default_groupsize } lappend results [delimit_number $number $delim $groupsize] @@ -3820,10 +3820,10 @@ namespace eval punk::lib { # 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 [expr $point + 1] end]; + set PostDecimal [string range $number $point+1 end]; set PostDecimalP 1; } else { - set point [expr [string length $number] + 1] + set point [expr {[string length $number] + 1}] set PostDecimal ""; set PostDecimalP 0; } @@ -3834,16 +3834,16 @@ namespace eval punk::lib { incr ind; } set FirstNonSpace $ind; - set LastSpace [expr $FirstNonSpace - 1]; + 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 [expr $point -1]]; + 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 Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; set DelimitedMain ""; #First we deal with the extra stuff. @@ -3851,7 +3851,7 @@ namespace eval punk::lib { append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; } set FirstInGroup $Phase; - set LastInGroup [expr $FirstInGroup + $GroupSize -1]; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; while {$LastInGroup < $Length} { if {$FirstInGroup > 0} { append DelimitedMain $delim; @@ -3869,7 +3869,7 @@ namespace eval punk::lib { } } - + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib ---}] @@ -3884,10 +3884,10 @@ tcl::namespace::eval punk::lib::flatgrid { #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 {$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]] @@ -3895,7 +3895,7 @@ tcl::namespace::eval punk::lib::flatgrid { set rows [list] set i 1 foreach s [lrange $splits 0 end-1] { - lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] incr i } return $rows @@ -3958,16 +3958,20 @@ tcl::namespace::eval punk::lib::flatgrid { } } +tcl::namespace::eval punk::lib::test { + +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #todo - way to generate 'internal' docs separately? #*** !doctools #[section Internal] tcl::namespace::eval punk::lib::system { - #*** !doctools + #*** !doctools #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #[list_begin definitions] @@ -3975,7 +3979,7 @@ tcl::namespace::eval punk::lib::system { ##*** !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) + #[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} { @@ -3988,9 +3992,9 @@ tcl::namespace::eval punk::lib::system { return [list number $most numfactors $mostcount] } proc factorCountBelow_punk {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[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! @@ -4001,9 +4005,9 @@ tcl::namespace::eval punk::lib::system { return $tally } proc factorCountBelow_numtheory {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[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) @@ -4070,7 +4074,7 @@ tcl::namespace::eval punk::lib::system { lappend innerpartials "" } else { if {[lindex $waiting end] eq {"}} { - #this quote is endquote + #this quote is endquote set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { @@ -4078,7 +4082,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting {"} lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4089,7 +4093,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\]" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4098,7 +4102,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\}" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4109,13 +4113,13 @@ tcl::namespace::eval punk::lib::system { set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } } } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } set escaped 0 @@ -4192,20 +4196,20 @@ tcl::namespace::eval punk::lib::system { } #get info about punk nestindex key ie type: list,dict,undetermined - # pdict devel + # pdict devel proc nestindex_info {args} { set argd [punk::args::get_dict { -parent -default "" - nestindex + nestindex } $args] 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 + 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 @@ -4221,11 +4225,11 @@ namespace eval ::punk::args::register { lappend ::punk::args::register::NAMESPACES ::punk::lib } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::lib [tcl::namespace::eval punk::lib { variable pkg punk::lib 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/mix/base-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm index c5ec5551..69f2f5cb 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -18,7 +18,7 @@ namespace eval punk::mix::base { set extension "" } #--------- - + uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] } proc _cli {args} { @@ -69,7 +69,7 @@ namespace eval punk::mix::base { } #puts stderr "arglen:[llength $args]" #puts stdout "_unknown '$ns' '$args'" - + set d_commands [get_commands -extension $extension] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] @@ -98,11 +98,11 @@ namespace eval punk::mix::base { } tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns } else { - if {[regexp {.*[*?].*} $subcommand]} { + if {[regexp {.*[*?].*} $subcommand]} { set d_commands [get_commands -extension $from_ns] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] set matched_commands [lsearch -all -inline $all_commands $subcommand] - set commands "" + set commands "" foreach m $matched_commands { append commands $m \n } @@ -113,12 +113,12 @@ namespace eval punk::mix::base { } proc _split_args {arglist} { #don't assume arglist is fully paired. - set posn [lsearch $arglist -extension] + set posn [lsearch $arglist -extension] set opts [list] if {$posn >= 0} { if {$posn+2 <= [llength $arglist]} { set opts [list -extension [lindex $arglist $posn+1]] - set argsremaining [lreplace $arglist $posn $posn+1] + set argsremaining [lreplace $arglist $posn $posn+1] } else { #no value supplied to -extension error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." @@ -151,7 +151,7 @@ namespace eval punk::mix::base { if {![string length $extension]} { set extension [namespace qualifiers [lindex [info level -1] 0]] } - + set maincommands [list] #extension may still be blank e.g if punk::mix::base::get_commands called directly if {[string length $extension]} { @@ -164,7 +164,7 @@ namespace eval punk::mix::base { } foreach c $nscommands { set cmd [namespace tail $c] - lappend maincommands $cmd + lappend maincommands $cmd } set maincommands [lsort $maincommands] } @@ -190,29 +190,29 @@ namespace eval punk::mix::base { set basecommands [lsort $basecommands] - return [list main $maincommands base $basecommands] + return [list main $maincommands base $basecommands] } proc help {args} { #' **%ensemblecommand% help** *args* - #' + #' #' Help for ensemble commands in the command line interface - #' - #' + #' + #' #' Arguments: - #' + #' #' * args - first word of args is the helptopic requested - usually a command name #' - calling help with no arguments will list available commands - #' + #' #' Returns: help text (text) - #' + #' #' Examples: - #' + #' #' ``` #' %ensemblecommand% help #' ``` - #' - #' - + #' + #' + #extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| # >} inspect -label a {| @@ -220,7 +220,7 @@ namespace eval punk::mix::base { # pipecase ,0/1/#= $switchargs {| # e/0 # >} .=>. {set e} - # pipecase /1,1/1/#= $switchargs + # pipecase /1,1/1/#= $switchargs #} |@@ok/result> " opts $opts] } @@ -620,7 +620,7 @@ namespace eval punk::mix::base { if {$path eq $base} { #attempting to cksum at root/volume level of a filesystem.. extra work - #This needs fixing for general use.. not necessarily just for project repos + #This needs fixing for general use.. not necessarily just for project repos puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" return [list error unsupported_path opts $opts] } @@ -671,8 +671,8 @@ namespace eval punk::mix::base { set archivename $tmplocation/[punk::mix::util::tmpfile].tar cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) - - #temp emission to stdout.. todo - repl telemetry channel + + #temp emission to stdout.. todo - repl telemetry channel puts stdout "cksum_path: creating temporary tar archive for $path" puts -nonewline stdout " at: $archivename ..." set tsstart [clock millis] @@ -692,7 +692,7 @@ namespace eval punk::mix::base { set ms [expr {$tsend - $tsstart}] puts stdout " tar::create done ($ms ms)" puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing" - } + } if {$ftype eq "file"} { set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)" @@ -718,7 +718,7 @@ namespace eval punk::mix::base { set cksum [{*}$cksum_command $path] } } else { - error "cksum_path unsupported $opts for path type [file type $path]" + error "cksum_path unsupported $opts for path type [file type $path]" } } set result [dict create] @@ -733,7 +733,7 @@ namespace eval punk::mix::base { #base can be empty string in which case paths must be absolute #expect dict_path_cksum to be a dict keyed on relpath where each value is a dictionary with keys cksum and opts # ie subdict for can be created from output of cksum_path (for already known values not requiring filling) - # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) + # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { if {$base eq ""} { set error_paths [list] @@ -775,7 +775,7 @@ namespace eval punk::mix::base { } } if {$base ne ""} { - set fullpath [file join $base $path] + set fullpath [file join $base $path] } else { set fullpath $path } @@ -820,7 +820,7 @@ namespace eval punk::mix::base { #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will honour valid-looking prefilled cksum values (ie will pass them through) #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) proc get_relativecksum_from_base {base specifiedpath args} { - if {$base ne ""} { + if {$base ne ""} { #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix if {[file pathtype $specifiedpath] eq "relative"} { @@ -846,9 +846,9 @@ namespace eval punk::mix::base { #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" } - set targetpath $specifiedpath + set targetpath $specifiedpath set storedpath [punk::path::relative $base $specifiedpath] - + } } else { if {[file type $specifiedpath] eq "relative"} { @@ -863,7 +863,7 @@ namespace eval punk::mix::base { # #NOTE: specifiedpath can be a relative path (to cwd) when base is empty - #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc + #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc #possibly also: base: somewhere targetpath: ../elsewhere/etc # #todo - write tests @@ -881,7 +881,7 @@ namespace eval punk::mix::base { set ckopts [cksum_filter_opts {*}$args] set ckinfo [cksum_path $targetpath {*}$ckopts] - + set keyvals $args ;# REVIEW dict set keyvals cksum [dict get $ckinfo cksum] #dict set keyvals cksum_all_opts [dict get $ckinfo opts] @@ -891,7 +891,7 @@ namespace eval punk::mix::base { } #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop - #storedpath is relative if possible + #storedpath is relative if possible return [dict create $storedpath $keyvals] } @@ -910,7 +910,7 @@ namespace eval punk::mix::base { dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] } - #buildruntime.exe obsolete.. + #buildruntime.exe obsolete.. set fullpath_buildruntime $buildfolder/buildruntime.exe set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] @@ -944,7 +944,7 @@ namespace eval punk::mix::base { } proc get_all_build_cksums_stored {path} { set buildfolder [get_build_workdir $path] - + set vfscontainer [file dirname $buildfolder] set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] set dict_cksums [dict create] @@ -963,7 +963,7 @@ namespace eval punk::mix::base { } set vfscontainer [file dirname $vfsfolder] set buildfolder $vfscontainer/_build - set dict_vfs [get_vfs_build_cksums $vfsfolder] + set dict_vfs [get_vfs_build_cksums $vfsfolder] set data "" dict for {path cksum} $dict_vfs { append data "$path $cksum" \n diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm index 5d38fad8..3cf64b33 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::mix::cli 0.3.1 +# Application punk::mix::cli 0.3.1 # Meta platform tcl # Meta license # @@ Meta End @@ -19,7 +19,7 @@ ##e.g package require frobz package require punk::repo package require punk::ansi -package require punkcheck ;#checksum and/or timestamp records +package require punkcheck ;#checksum and/or timestamp records @@ -33,7 +33,7 @@ namespace eval punk::mix::cli { namespace ensemble create variable initialised 0 - #lazy _init - called by punk::mix::base::_cli when ensemble used + #lazy _init - called by punk::mix::base::_cli when ensemble used proc _init {args} { variable initialised if {$initialised} { @@ -52,7 +52,7 @@ namespace eval punk::mix::cli { catch { package require punk::mix::commandset::project punk::overlay::import_commandset project . ::punk::mix::commandset::project - punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection } if {[catch { package require punk::mix::commandset::layout @@ -91,12 +91,12 @@ namespace eval punk::mix::cli { } proc stat {{workingdir ""} args} { - dict set args -v 0 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 0 + punk::mix::cli::lib::get_status $workingdir {*}$args } proc status {{workingdir ""} args} { - dict set args -v 1 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 1 + punk::mix::cli::lib::get_status $workingdir {*}$args } @@ -128,13 +128,13 @@ namespace eval punk::mix::cli { set project_base [punk::repo::find_candidate] set sourcefolder $project_base/src puts stderr "WARNING - project not under git or fossil control" - puts stderr "Using base folder $project_base" + puts stderr "Using base folder $project_base" } else { set sourcefolder $startdir } } - #review - why can't we be anywhere in the project? + #review - why can't we be anywhere in the project? #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { puts stderr "dev make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" @@ -157,7 +157,7 @@ namespace eval punk::mix::cli { if {![string length $project_base]} { puts stderr "WARNING no git or fossil repository detected." - puts stderr "Using base folder $startdir" + puts stderr "Using base folder $startdir" set project_base $startdir } @@ -178,7 +178,7 @@ namespace eval punk::mix::cli { } } #cd $sourcefolder - + #use run so that stdout visible as it goes if {![catch {run --timeout=55000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { #todo - notify if exit because of timeout! @@ -198,7 +198,7 @@ namespace eval punk::mix::cli { puts stdout "OK make finished " return true } - } + } proc Kettle {args} { tailcall lib::kettle_call lib {*}$args @@ -241,7 +241,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- if {$opt_strict} { if {[regexp {[A-Z]} $modulename]} { - error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" + error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" } } @@ -272,7 +272,7 @@ namespace eval punk::mix::cli { } elseif {[regexp {[A-Z]} $modulename]} { set msg "module names containing uppercase are not recommended (see tip 590).\n" append msg "Please retype the module name '$modulename' to proceed.\n" - append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" append msg "Retype it all in lowercase to use recommended naming" set answer [util::askuser $msg] if {[regexp {[A-Z]} $answer]} { @@ -285,11 +285,11 @@ namespace eval punk::mix::cli { } set modulename $answer } else { - #user has resupplied modulename all as lowercase + #user has resupplied modulename all as lowercase if {$answer eq [string tolower $modulename]} { set finalised 1 } else { - #.. but it doesn't match original - require rerun + #.. but it doesn't match original - require rerun } set modulename $answer } @@ -332,7 +332,7 @@ namespace eval punk::mix::cli { if {[string first "::" $projectname] >= 0} { error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" } - return $projectname + return $projectname } proc validate_name_not_empty_or_spaced {name args} { set opts [list\ @@ -394,7 +394,7 @@ namespace eval punk::mix::cli { set result "" if {$workingdir ne ""} { if {[file pathtype $workingdir] ne "absolute"} { - set workingdir [file normalize $workingdir] + set workingdir [file normalize $workingdir] } set active_dir $workingdir } else { @@ -403,10 +403,10 @@ namespace eval punk::mix::cli { set defaults [dict create\ -v 1\ ] - set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- set opt_v [dict get $opts -v] - # -- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- set repopaths [punk::repo::find_repos [pwd]] @@ -417,7 +417,7 @@ namespace eval punk::mix::cli { append result [dict get $repopaths warnings] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { - #review - multiple process launches to fossil a bit slow on windows.. + #review - multiple process launches to fossil a bit slow on windows.. #could we query global db in one go instead? # set fossil_prog [auto_execok fossil] @@ -444,14 +444,14 @@ namespace eval punk::mix::cli { if {"project" in $repotypes} { #punk project if {![catch {package require textblock; package require patternpunk}]} { - set result [textblock::join -- [>punk . logo] " " $result] + set result [textblock::join -- [>punk . logo] " " $result] append result \n - } - } + } + } set timeline [exec fossil timeline -n 5 -t ci] set timeline [string map {\r\n \n} $timeline] - append result $timeline + append result $timeline if {$opt_v} { set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] append result \n [punk::repo::workingdir_state_summary $repostate] @@ -516,7 +516,7 @@ namespace eval punk::mix::cli { puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" exit 2 } - set srcdirname [file tail $srcdir] + set srcdirname [file tail $srcdir] set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir if {[llength $subdirlist] == 0} { @@ -578,7 +578,7 @@ namespace eval punk::mix::cli { } set fileparts [split [file rootname $modpath] -] #set tmfile_versionsegment [lindex $fileparts end] - lassign [split_modulename_version $modpath] basename tmfile_versionsegment + lassign [split_modulename_version $modpath] basename tmfile_versionsegment if {$tmfile_versionsegment eq ""} { #split_modulename_version version part will be empty if not valid tcl version #last segment doesn't look even slightly versiony - fail. @@ -634,8 +634,8 @@ namespace eval punk::mix::cli { set modulefile $buildfolder/$basename-$module_build_version.tm - $build_event targetset_init INSTALL $podtree_copy - $build_event targetset_addsource $current_source_dir/$modpath + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath if {$tmfile_versionsegment eq $magicversion} { $build_event targetset_addsource $versionfile } @@ -667,7 +667,7 @@ namespace eval punk::mix::cli { if {[file exists $tmfile]} { set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm file rename $tmfile $newname - set tmfile $newname + set tmfile $newname } set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd set data [string map [list $magicversion $module_build_version] $data] @@ -745,12 +745,12 @@ namespace eval punk::mix::cli { $build_event targetset_end SKIPPED } $build_event destroy - $build_installer destroy + $build_installer destroy - #JMN - review + #JMN - review if {!$had_error} { - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm - $event targetset_addsource $modulefile + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile if {\ [llength [dict get [$event targetset_source_changes] changed]]\ || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ @@ -759,12 +759,12 @@ namespace eval punk::mix::cli { $event targetset_started # -- --- --- --- --- --- if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} - lappend module_list $modulefile + lappend module_list $modulefile if {[catch { file copy -force $modulefile $target_module_dir } errMsg]} { puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir" - $event targetset_end FAILED -note "could not copy $modulefile" + $event targetset_end FAILED -note "could not copy $modulefile" } else { puts stderr "Copied zip modpod module $modulefile to $target_module_dir" # -- --- --- --- --- --- @@ -782,7 +782,7 @@ namespace eval punk::mix::cli { } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar } file { set m $modpath @@ -808,12 +808,12 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #rebuild the .tm from the #tarjar + #rebuild the .tm from the #tarjar if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - + } else { - + } #REVIEW - should be in same structure/depth as $target_module_dir in _build? @@ -824,22 +824,22 @@ namespace eval punk::mix::cli { set tmfile $buildfolder/$basename-$module_build_version.tm file delete -force $buildfolder/#tarjar-$basename-$module_build_version file delete -force $tmfile - - + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version # #bsdtar doesn't seem to work.. or I haven't worked out the right options? #exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version package require tar - tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version if {![file exists $tmfile]} { puts stdout "ERROR: failed to build tarjar file $tmfile" exit 4 } #copy the file? - #set target $target_module_dir/$basename-$module_build_version.tm + #set target $target_module_dir/$basename-$module_build_version.tm #file copy -force $tmfile $target - + lappend module_list $tmfile } else { #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. @@ -851,7 +851,7 @@ namespace eval punk::mix::cli { # #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm $event targetset_addsource $versionfile $event targetset_addsource $current_source_dir/$m @@ -902,7 +902,7 @@ namespace eval punk::mix::cli { #------------------------------ } - + continue } ##------------------------------ @@ -917,7 +917,7 @@ namespace eval punk::mix::cli { #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] #set changed_list [dict get $changed_unchanged changed] #---------- - $event targetset_init INSTALL $target_module_dir/$m + $event targetset_init INSTALL $target_module_dir/$m $event targetset_addsource $current_source_dir/$m if {\ [llength [dict get [$event targetset_source_changes] changed]]\ @@ -981,7 +981,7 @@ namespace eval punk::mix::cli { } if {$CALLDEPTH == 0} { $event destroy - $installer destroy + $installer destroy } return $module_list } @@ -1017,7 +1017,7 @@ namespace eval punk::mix::cli { } dict set kettle_reset_args $p $arglist } - } + } } #call kettle_reinit to ensure recipes point to current project @@ -1095,14 +1095,14 @@ namespace eval punk::mix::cli { kettle_reinit } } - set first [lindex $args 0] + set first [lindex $args 0] if {[string match @* $first]} { error "deck kettle doesn't support special operations - try calling tclsh kettle directly" } if {$first eq "-f"} { set args [lassign $args __ path] } else { - set path $startdir/build.tcl + set path $startdir/build.tcl } set opts [list] @@ -1123,9 +1123,9 @@ namespace eval punk::mix::cli { } } - #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names + #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) - #REVIEW - needs to be updated to keep in sync with kettle. + #REVIEW - needs to be updated to keep in sync with kettle. set knownopts [list\ --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ @@ -1202,7 +1202,7 @@ namespace eval punk::mix::cli { package require punk::mix::base package require punk::overlay if {[catch { - punk::overlay::custom_from_base [namespace current] ::punk::mix::base + punk::overlay::custom_from_base [namespace current] ::punk::mix::base } errM]} { puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" error "punk::mix::cli error: $errM" @@ -1213,9 +1213,9 @@ namespace eval punk::mix::cli { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::cli [namespace eval punk::mix::cli { variable version - set version 0.3.1 + set version 0.3.1 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm index dab5312f..63b5335c 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/templates-0.1.0.tm @@ -47,7 +47,7 @@ namespace eval punk::mix::templates { lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. #review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. - #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. + #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. return $decls } } @@ -86,9 +86,9 @@ namespace eval punk::mix::templates { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::templates [namespace eval punk::mix::templates { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file 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 79150d6c..8e4699dc 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 @@ -57,7 +57,7 @@ namespace eval punk::mix::util { incr i set last_opt $i } else { - set last_opt [expr {$i - 1}] + set last_opt [expr {$i - 1}] break } } @@ -73,7 +73,7 @@ namespace eval punk::mix::util { #puts stderr "opts: $opts paths: $paths" - #let's proceed, but warn the user if an apparent option is in paths + #let's proceed, but warn the user if an apparent option is in paths foreach opt [list -encoding -eofchar -translation] { if {$opt in $paths} { puts stderr "fcat WARNING: apparent option $opt found after file argument(s) (expected them before filenames). Passing to fileutil::cat anyway - but for at least some versions, these options may be ignored. commandline 'fcat $args'" @@ -142,7 +142,7 @@ namespace eval punk::mix::util { } #---------------------------------------- - #namespace import ::punk::ns::nsimport_noclobber + #namespace import ::punk::ns::nsimport_noclobber proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { set source_ns [namespace qualifiers $pattern] @@ -153,7 +153,7 @@ namespace eval punk::mix::util { set nscaller [uplevel 1 {namespace current}] set ns [punk::nsjoin $nscaller $ns] } - set a_export_patterns [namespace eval $source_ns {namespace export}] + set a_export_patterns [namespace eval $source_ns {namespace export}] set a_commands [info commands $pattern] set a_tails [lmap v $a_commands {namespace tail $v}] set a_exported_tails [list] @@ -359,9 +359,9 @@ namespace eval punk::mix::util { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::util [namespace eval punk::mix::util { 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/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 140f2678..bce44dee 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::nav::fs 0 0.1.0] #[copyright "2024"] #[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] -#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] +#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] #[require punk::nav::fs] #[keywords module filesystem terminal] #[description] @@ -117,9 +117,9 @@ tcl::namespace::eval punk::nav::fs { #Both tcl's notion of pwd and VIRTUAL_CWD can be out of sync with the process CWD. This happens when in a VFS. #We can also have VIRTUAL_CWD navigate to spaces that Tcl's cd can't - review - variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint + variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint if {![interp issafe]} { - set VIRTUAL_CWD [pwd] + set VIRTUAL_CWD [pwd] } else { set VIRTUAL_CWD "" } @@ -127,25 +127,25 @@ tcl::namespace::eval punk::nav::fs { variable VIRTUAL_CWD set cwd [pwd] if {$cwd ne $VIRTUAL_CWD} { - puts stderr "pwd: $cwd" + puts stderr "pwd: $cwd" } return $::punk::nav::fs::VIRTUAL_CWD } - #TODO - maintain per 'volume/server' CWD - #e.g cd and ./ to: - # d: + #TODO - maintain per 'volume/server' CWD + #e.g cd and ./ to: + # d: # //zipfs: # //server # https://example.com # should return to the last CWD for that volume/server - + #VIRTUAL_CWD follows pwd when changed via cd set stackrecord [commandstack::rename_command -renamer punk::nav::fs cd {args} { if {![catch { $COMMANDSTACKNEXT {*}$args } errM]} { - set ::punk::nav::fs::VIRTUAL_CWD [pwd] + set ::punk::nav::fs::VIRTUAL_CWD [pwd] } else { error $errM } @@ -153,7 +153,7 @@ tcl::namespace::eval punk::nav::fs { #*** !doctools #[subsection {Namespace punk::nav::fs}] - #[para] Core API functions for punk::nav::fs + #[para] Core API functions for punk::nav::fs #[list_begin definitions] @@ -170,7 +170,7 @@ tcl::namespace::eval punk::nav::fs { #This seems unfortunate - as a multithreaded set of test runs might otherwise have made some sense.. but perhaps for tests more serious isolation is a good idea. #It also seems common to cd when loading certain packages e.g tls from starkit. #While in most/normal cases the library will cd back to the remembered working directory after only a brief time - there seem to be many opportunities for issues - #if the repl is used to launch/run a number of things in the one process + #if the repl is used to launch/run a number of things in the one process proc d/ {args} { variable VIRTUAL_CWD @@ -205,7 +205,7 @@ tcl::namespace::eval punk::nav::fs { } set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] - set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) + set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) #set location [file normalize [dict get $matchinfo location]] set location [dict get $matchinfo location] @@ -217,7 +217,7 @@ tcl::namespace::eval punk::nav::fs { set filesizes [lsearch -all -inline -not $filesizes na] set filebytes [tcl::mathop::+ {*}$filesizes] lappend result filebytes [punk::lib::format_number $filebytes] - } + } if {[punk::nav::fs::system::codethread_is_running]} { if {[llength [info commands ::punk::console::titleset]]} { #if ansi is off - punk::console::titleset will try 'local' api method - which can fail @@ -252,18 +252,18 @@ tcl::namespace::eval punk::nav::fs { set a1 [lindex $args 0] switch -exact -- $a1 { . - ./ { - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } .. - ../ { if {$VIRTUAL_CWD eq "//zipfs:/" && ![string match //zipfs:/* [pwd]]} { #exit back to last nonzipfs path that was in use set VIRTUAL_CWD [pwd] - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } - #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) - # [file join //server ..] would become /server/.. - use normjoin to get //server - # file dirname //server/share would stay as //server/share + #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) + # [file join //server ..] would become /server/.. - use normjoin to get //server + # file dirname //server/share would stay as //server/share #set up1 [file dirname $VIRTUAL_CWD] set up1 [punk::path::normjoin $VIRTUAL_CWD ..] if {[string match //zipfs:/* $up1]} { @@ -277,7 +277,7 @@ tcl::namespace::eval punk::nav::fs { cd $up1 #set VIRTUAL_CWD [file normalize $a1] } - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } } @@ -318,13 +318,13 @@ tcl::namespace::eval punk::nav::fs { } } if {[file type $target] eq "directory"} { - set VIRTUAL_CWD $target + set VIRTUAL_CWD $target } } tailcall punk::nav::fs::d/ } set curdir $VIRTUAL_CWD - } else { + } else { set curdir [pwd] } @@ -365,7 +365,7 @@ tcl::namespace::eval punk::nav::fs { set location $path set glob * if {$searchspec_relative} { - set searchbase [pwd] + set searchbase [pwd] } else { set searchbase $path } @@ -373,19 +373,19 @@ tcl::namespace::eval punk::nav::fs { set location [file dirname $path] set glob [file tail $path] ;#search for exact match file if {$searchspec_relative} { - set searchbase [pwd] + set searchbase [pwd] } else { set searchbase [file dirname $path] } } } - set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] + set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] #puts stderr "=--->$matchinfo" set location [file normalize [dict get $matchinfo location]] if {[string match //xzipfs:/* $location] || $location ne $last_location} { - #REVIEW - zipfs test disabled with leading x + #REVIEW - zipfs test disabled with leading x #emit previous result if {[dict size $this_result]} { dict set this_result filebytes [punk::lib::format_number [dict get $this_result filebytes]] @@ -398,7 +398,7 @@ tcl::namespace::eval punk::nav::fs { set this_result [dict create] set dircount 0 set filecount 0 - } + } incr dircount [llength [dict get $matchinfo dirs]] incr filecount [llength [dict get $matchinfo files]] @@ -406,7 +406,7 @@ tcl::namespace::eval punk::nav::fs { dict set this_result location $location dict set this_result dircount $dircount dict set this_result filecount $filecount - + set filesizes [dict get $matchinfo filesizes] if {[llength $filesizes]} { set filesizes [lsearch -all -inline -not $filesizes na] @@ -468,7 +468,7 @@ tcl::namespace::eval punk::nav::fs { } set normpath [file normalize $path] cd $normpath - set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] + set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] set location [file normalize [dict get $matchinfo location]] @@ -479,7 +479,7 @@ tcl::namespace::eval punk::nav::fs { set filesizes [lsearch -all -inline -not $filesizes na] set filebytes [tcl::mathop::+ {*}$filesizes] lappend result filebytes [punk::lib::format_number $filebytes] - } + } set out [dirfiles_dict_as_lines -stripbase 1 $matchinfo] #return $out\n[pwd] @@ -583,7 +583,7 @@ tcl::namespace::eval punk::nav::fs { set ext [file extension $path] set extlower [string tolower $ext] if {$extlower in $tcl_extensions} { - set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first set ::argv0 $path set ::argc [llength $newargs] set ::argv $newargs @@ -609,7 +609,7 @@ tcl::namespace::eval punk::nav::fs { } } if {$tcl_indicator} { - set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. set ::argv0 $path set ::argc [llength $newargs] set ::argv $newargs @@ -645,7 +645,7 @@ tcl::namespace::eval punk::nav::fs { } proc dirfiles {args} { set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] - lassign [dict values $argd] leaders opts values_dict + lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] set opt_formatsizes [dict get $opts -formatsizes] @@ -663,11 +663,11 @@ tcl::namespace::eval punk::nav::fs { #dirfiles_dict would handle simple cases of globs within paths anyway - but we need to explicitly set tailglob here in all branches so that next level doesn't need to do file vs dir checks to determine user intent. #(dir-listing vs file-info when no glob-chars present is inherently ambiguous so we test file vs dir to make an assumption - more explicit control via -tailglob can be done manually with dirfiles_dict) if {$relativepath} { - set searchbase [pwd] + set searchbase [pwd] if {!$has_tailglobs} { if {[file isdirectory [file join $searchbase $searchspec]]} { set location [file join $searchbase $searchspec] - set tailglob * + set tailglob * } else { set location [file dirname [file join $searchbase $searchspec]] set tailglob [file tail $searchspec] ;#use exact match as a glob - will retrieve size,attributes etc. @@ -700,29 +700,29 @@ tcl::namespace::eval punk::nav::fs { return [dirfiles_dict_as_lines -stripbase $opt_stripbase -formatsizes $opt_formatsizes $contents] } - #todo - package as punk::nav::fs + #todo - package as punk::nav::fs #todo - in thread #todo - streaming version #glob patterns in path prior to final segment should already be resolved before using dirfiles_dict - as the underlying filesystem mechanisms can't do nested globbing themselves. #dirfiles_dict will assume the path up to the final segment is literal even if globchars are included therein. #final segment globs will be recognised only if -tailglob is passed as empty string #if -tailglob not supplied and last segment has globchars - presume searchspec parendir is the container and last segment is globbing within that. - #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * + #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * #caller should use parentdir as location and set tailglob to search-pattern or exact match if location is intended to match a file rather than a directory #examples: # somewhere/files = search is effectively somewhere/files/* (location somewhere/files glob is *) # somewhere/files/* = (as above) - # -tailglob * somewhere/files = (as above) + # -tailglob * somewhere/files = (as above) # # -tailglob "" somewhere/files = search somewhere folder for exactly 'files' (location somewhere glob is files) # -tailglob files somewhere = (as above) # # somewhere/f* = search somewhere folder for f* (location somewhere glob is f*) - # -tailglob f* somewhere = (as above) - # + # -tailglob f* somewhere = (as above) + # # This somewhat clumsy API is so that simple searches can be made in a default sensible manner without requiring extra -tailglob argument for the common cases - with lack of trailing glob segment indicating a directory listing # - but we need to distinguish somewhere/files as a search of that folder vs somewhere/files as a search for exactly 'files' within somewhere, hence the -tailglob option to fine-tune. - # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. + # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. # #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied @@ -733,7 +733,7 @@ tcl::namespace::eval punk::nav::fs { -searchbase -default "" -tailglob -default "\uFFFF" #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) - -with_sizes -default "\uFFFF" -type string + -with_sizes -default "\uFFFF" -type string -with_times -default "\uFFFF" -type string @values -min 0 -max -1 -type string } @@ -743,7 +743,7 @@ tcl::namespace::eval punk::nav::fs { #puts stderr "searchspecs: $searchspecs [llength $searchspecs]" #puts stdout "arglist: $opts" - + if {[llength $searchspecs] > 1} { #review - spaced paths ? error "dirfiles_dict: multiple listing not *yet* supported" @@ -757,7 +757,7 @@ tcl::namespace::eval punk::nav::fs { # -- --- --- --- --- --- --- #we don't want to normalize.. - #for example if the user supplies ../ we want to see ../result + #for example if the user supplies ../ we want to see ../result set is_relativesearchspec [expr {[file pathtype $searchspec] eq "relative"}] if {$opt_searchbase eq ""} { @@ -770,7 +770,7 @@ tcl::namespace::eval punk::nav::fs { switch -- $opt_tailglob { "" { if {$searchspec eq ""} { - set location + set location } else { if {$is_relativesarchspec} { #set location [file dirname [file join $opt_searchbase $searchspec]] @@ -821,13 +821,13 @@ tcl::namespace::eval punk::nav::fs { set location $searchspec } } - set match_contents $opt_tailglob + set match_contents $opt_tailglob } } #puts stdout "searchbase: $searchbase searchspec:$searchspec" - #file attr //cookit:/ returns {-vfs 1 -handle {}} + #file attr //cookit:/ returns {-vfs 1 -handle {}} #we will treat it differently for now - use generic handler REVIEW set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit. if {[llength [package provide vfs]]} { @@ -873,11 +873,11 @@ tcl::namespace::eval punk::nav::fs { #we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name? set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob) } else { - #we could use 'file attr' here to test if {-vfs 1} - #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) + #we could use 'file attr' here to test if {-vfs 1} + #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) #instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume } - + } } @@ -885,7 +885,7 @@ tcl::namespace::eval punk::nav::fs { #relative vs absolute? review - cwd valid for //zipfs:/ ?? set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } elseif {$in_cookit} { - #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ + #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ #don't use twapi #could possibly use du_dirlisting_tclvfs REVIEW #files and folders are all returned with the -types hidden option for glob on windows @@ -928,12 +928,12 @@ tcl::namespace::eval punk::nav::fs { lappend dirs $vfsmount } } - } + } #NOTE: -types {hidden d} * may return . & .. on unix platforms - but will not show them on windows. #A mounted vfs exe (e.g sometclkit.exe) may be returned by -types {hidden d} on windows - but at the same time has "-hidden 0" in the result of file attr. - + #non-unix platforms may have attributes to indicate hidden status even if filename doesn't have leading dot. #mac & windows have these #windows doesn't consider dotfiles as hidden - mac does (?) @@ -946,8 +946,8 @@ tcl::namespace::eval punk::nav::fs { set flaggedhidden [punk::lib::lunique_unordered $flaggedhidden] } - set dirs [lsort $dirs] ;#todo - natsort - + set dirs [lsort $dirs] ;#todo - natsort + #foreach d $dirs { @@ -958,7 +958,7 @@ tcl::namespace::eval punk::nav::fs { #glob -types {hidden} will not always return the combination of glob -types {hidden f} && -types {hidden d} (on windows anyway) - # -- --- + # -- --- #can't lsort files without lsorting filesizes #Note - the sort by index would convert an empty filesizes list to a list of empty strings - one for each entry in files #We want to preserve the empty list if that's what the dirlisting mechanism returned (presumably because -with_sizes was 0 or explicitly excluded files) @@ -971,22 +971,22 @@ tcl::namespace::eval punk::nav::fs { set sorted_filesizes [list] foreach i $sortorder { lappend sorted_files [lindex $files $i] - lappend sorted_filesizes [lindex $filesizes $i] + lappend sorted_filesizes [lindex $filesizes $i] } } set files $sorted_files set filesizes $sorted_filesizes - # -- --- + # -- --- #jmn foreach nm [list {*}$dirs {*}$files] { if {[punk::winpath::illegalname_test $nm]} { lappend nonportable $nm - } + } } - set front_of_dict [dict create location $location searchbase $opt_searchbase] + set front_of_dict [dict create location $location searchbase $opt_searchbase] set listing [dict merge $front_of_dict $listing] set updated [dict create dirs $dirs files $files filesizes $filesizes nonportable $nonportable flaggedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes] @@ -1045,7 +1045,7 @@ tcl::namespace::eval punk::nav::fs { set prefix_test_list [tcl::prefix all $searchbases [lindex $shortest_to_longest 0 0]] #if shortest doesn't match all searchbases - we have no common base if {[llength $prefix_test_list] == [llength $searchbases]} { - set common_base [lindex $shortest_to_longest 0 0]; #we + set common_base [lindex $shortest_to_longest 0 0]; #we } } } @@ -1082,11 +1082,11 @@ tcl::namespace::eval punk::nav::fs { } set $fileset $stripped } - #Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. + #Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. } # -- --- --- --- --- --- --- --- --- --- --- - #assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out + #assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out #As at 2024-09 for windows symlinks - Tcl can't do file readlink on symlinks created with mklink /D name target (SYMLINKD) or mklink name target (SYMLINK) #We can't read the target information - best we can do is classify it as a file or a dir #we can't use 'file type' as that will report just 'link' - but file isfile and file isdirectory work and should work for links on all platforms - REVIEW @@ -1110,7 +1110,7 @@ tcl::namespace::eval punk::nav::fs { } } } else { - #fallback if no target_type + #fallback if no target_type if {[file isfile $s]} { lappend file_symlinks $s #will be appended in finfo_plus later @@ -1125,9 +1125,9 @@ tcl::namespace::eval punk::nav::fs { } #we now have the issue that our symlinks aren't sorted within the dir/file categorisation - they currently will have to appear at beginning or end - TODO # -- --- --- --- --- --- --- --- --- --- --- - - - #todo - sort whilst maintaining order for metadata? + + + #todo - sort whilst maintaining order for metadata? #we need to co-sort files only with filesizes (other info such as times is keyed on fname so cosorting not required) @@ -1135,7 +1135,7 @@ tcl::namespace::eval punk::nav::fs { if {$opt_formatsizes} { set filesizes [punk::lib::format_number $filesizes] ;#accepts a list and will process each } - + #col2 (file info) with subcolumns set widest2a [tcl::mathfunc::max {*}[lmap v [list {*}$files {*}$file_symlinks ""] {string length $v}]] @@ -1162,7 +1162,7 @@ tcl::namespace::eval punk::nav::fs { set mtime [dict get $contents times $key m] set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] } else { - #set ts [string repeat { } 19] + #set ts [string repeat { } 19] set ts "$key vs [dict keys [dict get $contents times]]" } set note "" @@ -1181,7 +1181,7 @@ tcl::namespace::eval punk::nav::fs { set mtime [dict get $contents times $key m] set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] } else { - set ts "[string repeat { } 19]" + set ts "[string repeat { } 19]" } set note "link" ;#default only if {[dict exists $contents linkinfo $key linktype]} { @@ -1207,24 +1207,24 @@ tcl::namespace::eval punk::nav::fs { set fname [dict get $fdict file] if {[file extension $fname] eq ".lnk"} { if {![catch {package require punk::winlnk}]} { - set shortcutinfo [punk::winlnk::file_get_info $fname] + set shortcutinfo [punk::winlnk::file_get_info $fname] set target_type "file" ;#default/fallback if {[dict exists $shortcutinfo link_target]} { - set is_valid_lnk 1 + set is_valid_lnk 1 set tgt [dict get $shortcutinfo link_target] if {[file exists $tgt]} { #file type could return 'link' - we will use isfile/isdirectory if {[file isfile $tgt]} { set target_type file } elseif {[file isdirectory $tgt]} { - set target_type directory + set target_type directory } else { set target_type file ;## ? } } else { #todo - see if punk::winlnk has info about the type at the time of linking #for now - treat as file - } + } } else { #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. set is_valid_lnk 0 @@ -1239,7 +1239,7 @@ tcl::namespace::eval punk::nav::fs { } directory { #target of link is a dir - for display/categorisation purposes we want to see it as a dir - #will be styled later based on membership of dir_shortcuts + #will be styled later based on membership of dir_shortcuts lappend dirs $fname lappend dir_shortcuts $fname } @@ -1292,7 +1292,7 @@ tcl::namespace::eval punk::nav::fs { set fdisp "" if {[string length $d]} { if {$d in $flaggedhidden} { - set d1 [punk::ansi::a+ cyan normal] + set d1 [punk::ansi::a+ cyan normal] } if {$d in $vfsmounts} { if {$d in $flaggedhidden} { @@ -1313,7 +1313,7 @@ tcl::namespace::eval punk::nav::fs { } } else { if {$d in $nonportable} { - set d1 [punk::ansi::a+ red bold] + set d1 [punk::ansi::a+ red bold] } } #dlink-style & dshortcut_style are for underlines - can be added with colours already set @@ -1336,11 +1336,11 @@ tcl::namespace::eval punk::nav::fs { } lappend displaylist [overtype::left $col1 $d1$d$RST]$f1$fdisp$RST } - + return [punk::lib::list_as_lines $displaylist] - } + } - #pass in base and platform to head towards purity/testability. + #pass in base and platform to head towards purity/testability. #this function can probably never be pure in such a simple form - as it needs to read state from the os storage system configuration #consider haskells approach of well-typed paths for cross-platform paths: https://hackage.haskell.org/package/path #review: punk::winpath calls cygpath! @@ -1360,8 +1360,8 @@ tcl::namespace::eval punk::nav::fs { set path_absolute [punk::unixywindows::towinpath $path] #puts stderr "winpath: $path" } else { - #todo handle volume-relative paths with volume specified c:etc c: - #note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd + #todo handle volume-relative paths with volume specified c:etc c: + #note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd #not clear whether tcl can/will fix this - but it means these paths are dangerous. #The cwd of the process can get out of sync with what tcl thinks is the working directory when you swap drives #Arguably if ...? @@ -1421,14 +1421,14 @@ tcl::namespace::eval punk::nav::fs::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::nav::fs::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 + # #[para]Description of utility1 + # return 1 #} @@ -1446,7 +1446,7 @@ tcl::namespace::eval punk::nav::fs::lib { tcl::namespace::eval punk::nav::fs::system { #*** !doctools #[subsection {Namespace punk::nav::fs::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #ordinary emission of chunklist when no repl proc emit_chunklist {chunklist} { @@ -1471,18 +1471,18 @@ tcl::namespace::eval punk::nav::fs::system { proc codethread_is_running {} { if {[info commands ::punk::repl::codethread::is_running] ne ""} { - return [punk::repl::codethread::is_running] + return [punk::repl::codethread::is_running] } return 0 } } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::nav::fs [tcl::namespace::eval punk::nav::fs { variable pkg punk::nav::fs 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/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 feee9d87..a64eef0f 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 @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::repl::codethread 0 0.1.1] #[copyright "2024"] #[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] -#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] +#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] #[require punk::repl::codethread] #[keywords module repl] #[description] -#[para] This is part of the infrastructure required for the punk::repl to operate +#[para] This is part of the infrastructure required for the punk::repl to operate # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -122,7 +122,7 @@ tcl::namespace::eval punk::repl::codethread { #*** !doctools #[subsection {Namespace punk::repl::codethread}] - #[para] Core API functions for punk::repl::codethread + #[para] Core API functions for punk::repl::codethread #[list_begin definitions] @@ -130,13 +130,13 @@ tcl::namespace::eval punk::repl::codethread { #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" #} variable run_command_cache @@ -145,7 +145,7 @@ tcl::namespace::eval punk::repl::codethread { #if {[catch {interp children}]} { # #8.6.10 doesn't have it.. when was it introduced? #} else { - + #} proc is_running {} { @@ -153,14 +153,14 @@ tcl::namespace::eval punk::repl::codethread { return $running } proc runscript {script} { - + #puts stderr "->runscript" - variable replthread_cond + variable replthread_cond #variable output_stdout "" #variable output_stderr "" #expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available - #if a thread::send is done from the commandline in a codethread - Tcl will + #if a thread::send is done from the commandline in a codethread - Tcl will if {![interp exists code] || ![info exists replthread_cond]} { #in case someone tries calling from codethread directly - don't do anything or change any state #(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) @@ -233,12 +233,12 @@ tcl::namespace::eval punk::repl::codethread { flush stderr #interp transfer code $errhandle "" - #flush $errhandle + #flush $errhandle #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code [list set ::punk::repl::codethread::output_stdout]]] end] - set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] + set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] #note we could be in a *large* ansi segment such as sixel data - #review - why do we need to ansistrip? + #review - why do we need to ansistrip? set lastoutchar [string index [punk::ansi::ansistrip $lastoutpart] end] #set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] @@ -247,7 +247,7 @@ tcl::namespace::eval punk::repl::codethread { #puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" set tid [thread::id] - tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] + tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] tsv::set codethread_$tid status $status tsv::set codethread_$tid result $result tsv::set codethread_$tid errorcode $::errorCode @@ -277,14 +277,14 @@ tcl::namespace::eval punk::repl::codethread::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::repl::codethread::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 + # #[para]Description of utility1 + # return 1 #} @@ -302,17 +302,17 @@ tcl::namespace::eval punk::repl::codethread::lib { tcl::namespace::eval punk::repl::codethread::system { #*** !doctools #[subsection {Namespace punk::repl::codethread::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::repl::codethread [tcl::namespace::eval punk::repl::codethread { variable pkg punk::repl::codethread 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/punkcheck-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punkcheck-0.1.0.tm index db8a3db5..fbf9a4e4 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 @@ -69,7 +69,7 @@ namespace eval punkcheck { } - proc load_records_from_file {punkcheck_file} { + proc load_records_from_file {punkcheck_file} { set record_list [list] if {[file exists $punkcheck_file]} { set tdlscript [punk::mix::util::fcat $punkcheck_file] @@ -86,7 +86,7 @@ namespace eval punkcheck { set linecount [llength [split $newtdl \n]] #puts stdout $newtdl set fd [open $punkcheck_file w] - fconfigure $fd -translation binary + chan configure $fd -translation binary puts -nonewline $fd $newtdl close $fd return [list recordcount [llength $recordlist] linecount $linecount] @@ -94,7 +94,7 @@ namespace eval punkcheck { #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? - #an installtrack objects represents an installation path from sourceroot to targetroot + #an installtrack objects represents an installation path from sourceroot to targetroot #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. # set objname [namespace current]::installtrack @@ -104,7 +104,7 @@ namespace eval punkcheck { #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD #each FILEINFO body being a list of SOURCE records oo::class create targetset { - variable o_targets + variable o_targets variable o_keep_installrecords variable o_keep_skipped variable o_keep_inprogress @@ -132,7 +132,7 @@ namespace eval punkcheck { -keep_inprogress $o_keep_inprogress\ body $o_records } - + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS method get_last_record {fileset_record} { set body [dict_getwithdefault $fileset_record body [list]] @@ -189,11 +189,11 @@ namespace eval punkcheck { } set o_ts_end [dict get $opts -tsend] set o_types [dict get $opts -types] - set o_configdict [dict get $opts -config] + set o_configdict [dict get $opts -config] set o_rel_sourceroot $rel_sourceroot set o_rel_targetroot $rel_targetroot - } + } destructor { #puts "[self] destructor called" } @@ -339,14 +339,14 @@ namespace eval punkcheck { set installing_record [lindex $fileinfo_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset fileinfo_body end $installing_record - + return [dict set o_fileset_record body $fileinfo_body] } else { #legacy call @@ -368,7 +368,7 @@ namespace eval punkcheck { } set status [string toupper $status] - set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] if {$o_operation_start_ts eq ""} { error "[self] targetset_end $status - no current operation - call targetset_started first" } @@ -383,7 +383,7 @@ namespace eval punkcheck { error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" } set operation_end_ts [clock microseconds] - set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] set file_record_body [dict get $o_fileset_record body] set installing_record [lindex $file_record_body end] set punkcheck_file [$o_installer get_checkfile] @@ -414,12 +414,12 @@ namespace eval punkcheck { } } set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] - dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -targets_cksums $new_targets_cksums dict set installing_record -cksum_all_opts $cksum_all_opts dict set installing_record -cksum_us $cksum_us } lset file_record_body end $installing_record - dict set o_fileset_record body $file_record_body + dict set o_fileset_record body $file_record_body set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] @@ -436,8 +436,8 @@ namespace eval punkcheck { set o_operation "" return $o_fileset_record } - #can supply empty cksum value - # - that will influence the opts used if there is no existing install record + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record method targetset_cksumcache_set {path_cksum_dict} { set o_path_cksum_cache $path_cksum_dict } @@ -504,12 +504,12 @@ namespace eval punkcheck { variable o_ts variable o_keep_events variable o_checkfile - variable o_sourceroot + variable o_sourceroot variable o_rel_sourceroot variable o_targetroot variable o_rel_targetroot variable o_record_list - variable o_active_event + variable o_active_event variable o_events constructor {installername punkcheck_file} { set o_active_event "" @@ -546,7 +546,7 @@ namespace eval punkcheck { #$o_events add $e [dict get $e -id] $o_events add $eobj [dict get $e -id] } - + } destructor { #puts "[self] destructor called" @@ -562,7 +562,7 @@ namespace eval punkcheck { } #call set_source_target before calling start_event/end_event - #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. method set_source_target {sourceroot targetroot} { if {[file pathtype $sourceroot] ne "absolute"} { error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" @@ -605,7 +605,7 @@ namespace eval punkcheck { } method save_installer_record {} { set file_records [punkcheck::load_records_from_file $o_checkfile] - + set this_installer_record [my as_record] set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] @@ -658,13 +658,13 @@ namespace eval punkcheck { set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] } method get_recordlist {} { - return $o_recordlist + return $o_recordlist } method end_event {} { if {$o_active_event eq ""} { error "[self] end_event error - no active event" } - $o_active_event end + $o_active_event end } method get_event {} { return $o_active_event @@ -720,7 +720,7 @@ namespace eval punkcheck { append msg "Call in order:" \n append msg " start_installer_event (get dict with eventid and recordset keys)" append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n - append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n append msg " ( - possibly with same algorithm as previous installrecord)" \n append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n append msg "Finalize by calling:" \n @@ -749,7 +749,7 @@ namespace eval punkcheck { set punkcheck_file [file join $punkcheck_folder/.punkcheck] set record_list [load_records_from_file $punkcheck_file] - + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] set installer_record_position [dict get $resultinfo position] if {$installer_record_position == -1} { @@ -805,7 +805,7 @@ namespace eval punkcheck { #validate any passed cached_cksums foreach cacheinfo $cached_cksums { if {[llength $cacheinfo] % 2 != 0} { - error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" } dict for {k v} $cacheinfo { switch -- $k { @@ -814,7 +814,7 @@ namespace eval punkcheck { #todo - validate $v keys } default { - error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" } } @@ -837,7 +837,7 @@ namespace eval punkcheck { } } } - #check that this relpath not already added as child of *-INPROGRESS + #check that this relpath not already added as child of *-INPROGRESS set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body set installing_record [lindex $file_record_body end] set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] @@ -871,14 +871,14 @@ namespace eval punkcheck { #use first entry in cached_cksums if we can if {[llength $cached_cksums]} { set use_cache 1 - set use_cache_record [lindex $cached_cksums 0] + set use_cache_record [lindex $cached_cksums 0] } } #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) #if same cksum_opts - then use cached data instead of checksumming here. - #allow nonexistant as a source + #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] if {![file exists $fpath]} { set ftype "missing" @@ -939,14 +939,14 @@ namespace eval punkcheck { set installing_record [lindex $file_record_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] - + dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset file_record_body end $installing_record - + dict set file_record body $file_record_body @@ -983,7 +983,7 @@ namespace eval punkcheck { dict set installing_record tag "INSTALL-RECORD" lset file_record_body end $installing_record - dict set file_record body $file_record_body + dict set file_record body $file_record_body set file_record [punkcheck::recordlist::file_record_prune $file_record] @@ -1016,8 +1016,8 @@ namespace eval punkcheck { set tsnow [clock microseconds] set elapsed_us [expr {$tsnow - $ts_start}] dict set installing_record -elapsed_us $elapsed_us - dict set installing_record tag "INSTALL-SKIPPED" - + dict set installing_record tag "INSTALL-SKIPPED" + lset file_record_body end $installing_record dict set file_record body $file_record_body @@ -1076,7 +1076,7 @@ namespace eval punkcheck { #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL proc install_record_get_matching_source_record {install_record source_relpath} { - set body [dict_getwithdefault $install_record body [list]] + set body [dict_getwithdefault $install_record body [list]] foreach src $body { if {[dict get $src tag] eq "SOURCE"} { if {[dict_getwithdefault $src -path ""] eq $source_relpath} { @@ -1124,7 +1124,7 @@ namespace eval punkcheck { set do_normalize 1 } } else { - #case differences in volumes is common on windows + #case differences in volumes is common on windows set do_normalize 1 } if {$do_normalize} { @@ -1207,7 +1207,7 @@ namespace eval punkcheck { if {[dict exists $dictValue {*}$keys]} { return [dict get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } lappend PUNKARGS [list { @@ -1273,11 +1273,11 @@ namespace eval punkcheck { # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target # -overwrite all-targets will copy regardless of timestamp at target - # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry # review - timestamps unreliable - # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? - # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? # if such a content-mismatch - what default behaviour and what options would make sense? # probably it's reasonable that only all-targets would overwrite such files. @@ -1369,7 +1369,7 @@ namespace eval punkcheck { if {[llength [file split $af]] > 1} { error "punkcheck::install received invalid -antiglob_file entry '$af'. -antiglob_file entries are meant to match to a file name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] if {$opt_antiglob_dir_core eq "\uFFFF"} { @@ -1383,7 +1383,7 @@ namespace eval punkcheck { if {[llength [file split $ad]] > 1} { error "punkcheck::install received invalid -antiglob_dir entry '$ad'. -antiglob_dir entries are meant to match to a directory name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment @@ -1482,7 +1482,7 @@ namespace eval punkcheck { } else { set store_source_cksums 0 } - + @@ -1545,12 +1545,12 @@ namespace eval punkcheck { } if {$suppress == 0} { lappend match_list $m - } + } } #sample .punkcheck file record (raw form) to make the code clearer #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist - #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS # #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { @@ -1563,15 +1563,15 @@ namespace eval punkcheck { # } #} - if {[llength $match_list]} { + if {[llength $match_list]} { #example - target dir has a file where there is a directory at the source if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" } } - + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} - + #puts stdout "Current target dir: $current_target_dir" foreach m $match_list { @@ -1581,7 +1581,7 @@ namespace eval punkcheck { set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing file - globmatchpath $antipath vs $relative_source_path" + #puts "testing file - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched $current_source_dir set is_antipath 1 @@ -1598,7 +1598,7 @@ namespace eval punkcheck { #puts stdout " rel_target: $punkcheck_target_relpath" - + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] #change to use extract_or_create_fileset_record ? set existing_filerec_posn [dict get $fetch_filerec_result position] @@ -1614,7 +1614,7 @@ namespace eval punkcheck { set filerec [dict get $fetch_filerec_result record] } set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] - + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. @@ -1630,7 +1630,7 @@ namespace eval punkcheck { #different volume or root } #Note this isn't a recordlist function - so it doesn't purely operate on the records - #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] @@ -1697,7 +1697,7 @@ namespace eval punkcheck { } else { #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it set is_skip 1 - puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" lappend files_skipped $current_source_dir/$m } } else { @@ -1728,7 +1728,7 @@ namespace eval punkcheck { #if {$store_source_cksums} { #} - set install_records [dict get $filerec body] + set install_records [dict get $filerec body] set current_install_record [lindex $install_records end] #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED if {$is_skip} { @@ -1790,7 +1790,7 @@ namespace eval punkcheck { set relative_source_path [file join $relative_source_dir $d] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing folder - globmatchpath $antipath vs $relative_source_path" + #puts "testing folder - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched [file join $current_source_dir $d] #puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath " @@ -1801,11 +1801,11 @@ namespace eval punkcheck { if {$is_antipath} { continue } - + #if {![file exists $current_target_dir/$d]} { # file mkdir $current_target_dir/$d #} - + set sub_opts_1 [list\ -call-depth-internal [expr {$CALLDEPTH + 1}]\ @@ -1828,7 +1828,7 @@ namespace eval punkcheck { -punkcheck_folder $punkcheck_folder\ -punkcheck_eventid $punkcheck_eventid\ -punkcheck_records $punkcheck_records\ - ] + ] set sub_opts [dict merge $opts $sub_opts] set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] @@ -1838,7 +1838,7 @@ namespace eval punkcheck { lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] set punkcheck_records [dict get $sub_result punkcheck_records] } - + if {[string match *store* $opt_source_checksum]} { #puts "subdirlist: $subdirlist" if {$CALLDEPTH == 0} { @@ -1849,7 +1849,7 @@ namespace eval punkcheck { #puts stdout ">>>>>>>>>>>>>>>>>>>" } else { #todo - write db INSTALLER record if -debug true - + } #puts stdout "sources_unchanged" #puts stdout "$sources_unchanged" @@ -2108,7 +2108,7 @@ namespace eval punkcheck { if {[dict get $file_record tag] ne "FILEINFO"} { error "file_record_set_defaults bad file_record: tag not FILEINFO" } - set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] foreach {k v} $defaults { if {![dict exists $file_record $k]} { dict set file_record $k $v @@ -2186,10 +2186,10 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punkcheck [namespace eval punkcheck { set pkg punkcheck 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/textblock-0.1.3.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.3.tm index 8d66978f..2d185f01 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 @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_textblock 0 0.1.3] #[copyright "2024"] #[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] +#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] #[require textblock] #[keywords module ansi text layout colour table frame console terminal] #[description] @@ -29,7 +29,7 @@ #*** !doctools #[section Overview] -#[para] overview of textblock +#[para] overview of textblock #[subsection Concepts] #[para] @@ -39,7 +39,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by textblock +#[para] packages used by textblock #[list_begin itemized] #*** !doctools @@ -90,7 +90,7 @@ package require textutil tcl::namespace::eval textblock { #review - what about ansi off in punk::console? tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ - tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus #(more likely to be optimised for modern cpu features?) @@ -102,7 +102,7 @@ tcl::namespace::eval textblock { namespace eval argdoc { proc hash_algorithm_choices_and_help {} { set choices [list none] - set unavailable [list] + set unavailable [list] set unloaded [dict create] set algorithm_packages {md5 sha1 sha256} foreach p $algorithm_packages { @@ -219,7 +219,7 @@ tcl::namespace::eval textblock { #ie only vll,blc,hlb used for cells except top row and right column #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 + #e.g for 4x4 # C C C O # L L L U # L L L U @@ -229,7 +229,7 @@ tcl::namespace::eval textblock { set L [list vll blc hlb] set U [list vll blc hlb brc vlr] set tops [list trc hlt tlc] - set lefts [list tlc vll blc] + set lefts [list tlc vll blc] set bottoms [list blc hlb brc] set rights [list trc brc vlr] @@ -491,8 +491,8 @@ tcl::namespace::eval textblock { set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v + set seps_h $requested_seps_h + set seps_v $requested_seps_v if {$requested_seps eq ""} { if {$requested_seps_h eq ""} { set seps_h 1 @@ -502,10 +502,10 @@ tcl::namespace::eval textblock { } } else { if {$requested_seps_h eq ""} { - set seps_h $seps + set seps_h $seps } if {$requested_seps_v eq ""} { - set seps_v $seps + set seps_v $seps } } return [tcl::dict::create horizontal $seps_h vertical $seps_v] @@ -515,8 +515,8 @@ tcl::namespace::eval textblock { set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body + set ft_header $requested_ft_header + set ft_body $requested_ft_body switch -- $requested_ft { light { if {$requested_ft_header eq ""} { @@ -544,10 +544,10 @@ tcl::namespace::eval textblock { } default { if {$requested_ft_header eq ""} { - set ft_header $requested_ft + set ft_header $requested_ft } if {$requested_ft_body eq ""} { - set ft_body $requested_ft + set ft_body $requested_ft } } } @@ -621,7 +621,7 @@ tcl::namespace::eval textblock { if {![llength $args]} { return $o_opts_table - } + } if {[llength $args] == 1} { if {[lindex $args 0] in [list %topt_keys%]} { #query single option @@ -634,7 +634,7 @@ tcl::namespace::eval textblock { tcl::dict::set infodict debug [ansistring VIEW $val] } -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] } } tcl::dict::set returndict info $infodict @@ -663,11 +663,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; + set ansi_codes [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend ansi_codes $code @@ -684,7 +684,7 @@ tcl::namespace::eval textblock { -framemap_body - -framemap_header { #upvar ::textblock::class::opts_table_defaults tdefaults #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map + #todo - check keys and map if {[llength $v] == 1} { if {$v eq "default"} { upvar ::textblock::class::opts_table_defaults tdefaults @@ -700,7 +700,7 @@ tcl::namespace::eval textblock { switch -- $subk { topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" } } #safe jumptable test @@ -752,14 +752,14 @@ tcl::namespace::eval textblock { } -show_hseps { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations } -show_edge { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play @@ -768,7 +768,7 @@ tcl::namespace::eval textblock { -show_vseps { #we allow empty string - so don't use -strict boolean check if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } #affects width calculations set o_calculated_column_widths [list] @@ -807,7 +807,7 @@ tcl::namespace::eval textblock { if {[my width] < [expr {$twidth+2}]} { set o_calculated_column_widths [list] tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] - } + } tcl::dict::set o_opts_table -title $v } default { @@ -840,7 +840,7 @@ tcl::namespace::eval textblock { } } #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] return $o_opts_table } @@ -858,7 +858,7 @@ tcl::namespace::eval textblock { for {set c 0} {$c < $matrix_colcount} {incr c} { my add_column -headers "" } - } + } set table_colcount [my column_count] if {$table_colcount != $matrix_colcount} { error "textblock::table::printmatrix column count of table doesn't match column count of matrix" @@ -874,7 +874,7 @@ tcl::namespace::eval textblock { method as_matrix {{cmd ""}} { #*** !doctools #[call class::table [method as_matrix] [arg ?cmd?]] - #[para] return a struct::matrix command representing the data portion of the table. + #[para] return a struct::matrix command representing the data portion of the table. if {$cmd eq ""} { set m [struct::matrix] @@ -883,8 +883,8 @@ tcl::namespace::eval textblock { } $m add columns [tcl::dict::size $o_columndata] $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v + tcl::dict::for {k v} $o_columndata { + $m set column $k $v } return $m } @@ -907,17 +907,17 @@ tcl::namespace::eval textblock { } } } - set colcount [tcl::dict::size $o_columndefs] + set colcount [tcl::dict::size $o_columndefs] tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { + if {[catch { my configure_column $colcount {*}$opts } errMsg]} { #configure failed - ensure o_columndata and o_columndefs entries are removed @@ -926,7 +926,7 @@ tcl::namespace::eval textblock { tcl::dict::unset o_columnstates $colcount #undo cache invalidation set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" } #any add_column that succeeds should invalidate the calculated column widths set o_calculated_column_widths [list] @@ -945,7 +945,7 @@ tcl::namespace::eval textblock { method column_count {} { #*** !doctools #[call class::table [method column_count]] - #[para] return the number of columns + #[para] return the number of columns return [tcl::dict::size $o_columndefs] } method configure_column {index_expression args} { @@ -956,7 +956,7 @@ tcl::namespace::eval textblock { set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } + } if {![llength $args]} { return [tcl::dict::get $o_columndefs $cidx] } else { @@ -991,7 +991,7 @@ tcl::namespace::eval textblock { } set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - set hstates $o_headerstates ;#operate on a copy + set hstates $o_headerstates ;#operate on a copy set colstate [tcl::dict::get $o_columnstates $cidx] set args_got_headers 0 set args_got_header_colspans 0 @@ -1000,7 +1000,7 @@ tcl::namespace::eval textblock { -headers { set args_got_headers 1 set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. foreach hdr $v { set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns #set this_header_height [textblock::height $hdr] @@ -1052,7 +1052,7 @@ tcl::namespace::eval textblock { # } #} else { set header_spans [tcl::dict::get $cspans $h] - set remaining [lindex $header_spans 0] + set remaining [lindex $header_spans 0] if {$remaining ne "any"} { incr remaining -1 } @@ -1109,11 +1109,11 @@ tcl::namespace::eval textblock { } -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; + set col_ansibase_items [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend col_ansibase_items $code @@ -1146,13 +1146,13 @@ tcl::namespace::eval textblock { } #args checked - ok to update headerstates, headerdefs and columndefs and columnstates tcl::dict::set o_columndefs $cidx $checked_opts - set o_headerstates $hstates + set o_headerstates $hstates dict for {hidx hstate} $hstates { #configure_header if {![dict exists $o_headerdefs $hidx]} { #remove calculated members -values -colspans set hdefaults [dict remove $o_opts_header_defaults -values -colspans] - dict set o_headerdefs $hidx $hdefaults + dict set o_headerdefs $hidx $hdefaults } } @@ -1183,7 +1183,7 @@ tcl::namespace::eval textblock { method header_count {} { #*** !doctools #[call class::table [method header_count]] - #[para] return the number of header rows + #[para] return the number of header rows return [tcl::dict::size $o_headerstates] } method header_count_calc {} { @@ -1232,7 +1232,7 @@ tcl::namespace::eval textblock { method header_colspans {} { #*** !doctools #[call class::table [method header_colspans]] - #[para] Show the colspans configured for all headers + #[para] Show the colspans configured for all headers #set num_headers [my header_count_calc] set num_headers [my header_count] @@ -1242,9 +1242,9 @@ tcl::namespace::eval textblock { set colspans_for_column [tcl::dict::get $cdef -header_colspans] for {set h 0} {$h < $num_headers} {incr h} { set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] + set defined_span [lindex $colspans_for_column $h] set i 0 - set spanremaining [lindex $headerspans 0] + set spanremaining [lindex $headerspans 0] if {$spanremaining ne "any"} { if {$spanremaining eq ""} { set spanremaining 1 @@ -1256,7 +1256,7 @@ tcl::namespace::eval textblock { set spanremaining "any" } elseif {$s == 0} { if {$spanremaining ne "any"} { - incr spanremaining -1 + incr spanremaining -1 } } else { set spanremaining [expr {$s - 1}] @@ -1273,7 +1273,7 @@ tcl::namespace::eval textblock { } else { lappend headerspans $defined_span } - tcl::dict::set colspans_by_header $h $headerspans + tcl::dict::set colspans_by_header $h $headerspans } } return $colspans_by_header @@ -1301,10 +1301,10 @@ tcl::namespace::eval textblock { } incr spanlen } - #overwrite the 'any' with it's actual span + #overwrite the 'any' with it's actual span set modified_spans [dict get $hcolspans $h] lset modified_spans $c $spanlen - dict set hcolspans $h $modified_spans + dict set hcolspans $h $modified_spans } incr c } @@ -1315,7 +1315,7 @@ tcl::namespace::eval textblock { method configure_header {index_expression args} { #*** !doctools #[call class::table [method configure_header]] - #[para] - configure header row-wise + #[para] - configure header row-wise #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis @@ -1331,7 +1331,7 @@ tcl::namespace::eval textblock { } if {![llength $args]} { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] set header_row_items [list] @@ -1339,9 +1339,9 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - tcl::dict::set result -values $header_row_items + tcl::dict::set result -values $header_row_items #review - ensure always a headerdef record for each header? if {[tcl::dict::exists $o_headerdefs $hidx]} { @@ -1359,7 +1359,7 @@ tcl::namespace::eval textblock { #set val [tcl::dict::get $o_rowdefs $ridx $k] set infodict [tcl::dict::create] - #todo + #todo # -blockalignments and -textalignments lists # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} #if there is a value it overrides alignments specified on the column @@ -1370,14 +1370,14 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - set val $header_row_items + set val $header_row_items set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] } -colspans { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] set val [tcl::dict::get $colspans_by_header $hidx] #ansireset not required @@ -1412,11 +1412,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; + set header_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend header_ansibase_items $code @@ -1443,7 +1443,7 @@ tcl::namespace::eval textblock { if {[llength $v] > $numcols} { error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" } - if {[llength $v] < $numcols} { + if {[llength $v] < $numcols} { puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" } @@ -1457,7 +1457,7 @@ tcl::namespace::eval textblock { } if {!$first_is_ok} { error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" - } + } #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) set remaining $firstspan if {$remaining ne "any"} { @@ -1469,7 +1469,7 @@ tcl::namespace::eval textblock { foreach span [lrange $v 1 end] { if {$remaining eq "any"} { if {$span eq "any"} { - set remaining "any" + set remaining "any" } elseif {$span > 0} { #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { @@ -1479,7 +1479,7 @@ tcl::namespace::eval textblock { set remaining $span incr remaining -1 } else { - #zero following an any - leave remaining as any + #zero following an any - leave remaining as any } } else { if {$span eq "0"} { @@ -1546,7 +1546,7 @@ tcl::namespace::eval textblock { # -- -- -- -- -- -- #also update maxwidthseen & maxheightseen set i 0 - set maxwidthseen 0 + set maxwidthseen 0 #set maxheightseen 0 foreach hdr $thiscol_headers_vertical { lassign [textblock::size $hdr] _w this_header_width _h this_header_height @@ -1567,7 +1567,7 @@ tcl::namespace::eval textblock { } } -colspans { - #sequence has been verified above - we need to split it and store across columns + #sequence has been verified above - we need to split it and store across columns set c 0 ;#column index foreach span $v { set colspans [tcl::dict::get $o_columndefs $c -header_colspans] @@ -1615,7 +1615,7 @@ tcl::namespace::eval textblock { } #set o_headerstate $hidx -minheight? -maxheight? ??? - tcl::dict::set o_headerdefs $hidx $update_hdefs + tcl::dict::set o_headerdefs $hidx $update_hdefs } method add_row {valuelist args} { @@ -1635,14 +1635,14 @@ tcl::namespace::eval textblock { if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { error "add_row - no values supplied, and no columns defined, so cannot use default column values" } - + set defaults [tcl::dict::create\ -minheight 1\ -maxheight ""\ -ansibase ""\ -ansireset "\uFFEF"\ ] - set o_opts_row_defaults $defaults + set o_opts_row_defaults $defaults if {[llength $args] %2 !=0} { error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" @@ -1676,23 +1676,23 @@ tcl::namespace::eval textblock { } } set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure if {[catch { my configure_row $rowcount {*}$opts } errMsg]} { #undo anything we saved before configure_row tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns + #remove auto_columns if {$auto_columns} { set o_columndata [tcl::dict::create] set o_columndefs [tcl::dict::create] set o_columnstate [tcl::dict::create] } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" } - + set c 0 set max_height_seen 1 foreach v $valuelist { @@ -1774,11 +1774,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; + set row_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend row_ansibase_items $code @@ -1954,7 +1954,7 @@ tcl::namespace::eval textblock { } method get_column_by_index {index_expression args} { #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. set opts [tcl::dict::create\ -position "inner"\ -return "string"\ @@ -1992,7 +1992,7 @@ tcl::namespace::eval textblock { set topt_show_header [tcl::dict::get $o_opts_table -show_header] if {$topt_show_header eq ""} { - set allheaders 0 + set allheaders 0 set all_cols [tcl::dict::keys $o_columndefs] foreach c $all_cols { incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] @@ -2015,8 +2015,8 @@ tcl::namespace::eval textblock { set boxlimits "" set joins "" - set header_boxlimits [list] - set header_body_joins [list] + set header_boxlimits [list] + set header_body_joins [list] set ftypes [my Get_frametypes] @@ -2035,9 +2035,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] @@ -2060,9 +2060,9 @@ tcl::namespace::eval textblock { set sep_elements_horizontal $::textblock::class::table_hseps set sep_elements_vertical $::textblock::class::table_vseps - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] set onlymap [tcl::dict::get $fmap only$opt_posn] set hdrmap [tcl::dict::get $hmap only${opt_posn}] @@ -2074,7 +2074,7 @@ tcl::namespace::eval textblock { set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] lassign [my Get_seps] _h show_seps_h _v show_seps_v @@ -2091,7 +2091,7 @@ tcl::namespace::eval textblock { set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] set ansiborder_final $ansibase_header$ansiborder_header$extrabg } else { set ansiborder_final $ansibase_header$ansiborder_header @@ -2099,7 +2099,7 @@ tcl::namespace::eval textblock { set RST [punk::ansi::a] - set hcolwidth $colwidth + set hcolwidth $colwidth #set hcolwidth [my column_width_configured $cidx] set hcell_line_blank [tcl::string::repeat " " $hcolwidth] @@ -2149,7 +2149,7 @@ tcl::namespace::eval textblock { if {$hrow == $hmax} { set header_joins $header_body_joins } else { - set header_joins $joins + set header_joins $joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] @@ -2167,7 +2167,7 @@ tcl::namespace::eval textblock { set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] set spanbelow [lindex $next_spanlist $cidx] if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins + #we don't want a down-join for blc - use a framedef with only left joins tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] } } else { @@ -2181,7 +2181,7 @@ tcl::namespace::eval textblock { #May be better to require user to pre-wrap as needed ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) # -width is always +2 - as the boxlimits take into account show_vseps and show_edge @@ -2219,10 +2219,10 @@ tcl::namespace::eval textblock { #puts ">> remaining_spans: $remaining_spans" set spancol [expr {$cidx + 1}] set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + - set last [expr {[llength $remaining_spans] -1}] set i 0 foreach s $remaining_spans { @@ -2238,9 +2238,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $next_posn $fname_body] set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] @@ -2263,14 +2263,14 @@ tcl::namespace::eval textblock { } } else { #join to body - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype } } if {$hrow == $hmax} { set header_joins $span_joins_body } else { - set header_joins $span_joins + set header_joins $span_joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] @@ -2285,7 +2285,7 @@ tcl::namespace::eval textblock { } else { break } - incr spancol + incr spancol incr i } @@ -2304,7 +2304,7 @@ tcl::namespace::eval textblock { set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] } else { - set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] } } else { @@ -2349,10 +2349,10 @@ tcl::namespace::eval textblock { set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] #POTENTIAL BUG (fixed with spans_to_rhs above) #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) - #we need to shift 1 to the left when doing our overtype with blockalign right + #we need to shift 1 to the left when doing our overtype with blockalign right #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge #(even though the column position may be left or inner) - + } else { @@ -2389,12 +2389,12 @@ tcl::namespace::eval textblock { set h_lines [lrepeat $padheight $bline] set hcell_blank [::join $h_lines \n] set header_frame $hcell_blank - } else { + } else { set bline [tcl::string::repeat $TSUB $padwidth] set h_lines [lrepeat $rowh $bline] set hcell_blank [::join $h_lines \n] # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi + #frame borders will never display - so use the simplest frametype and don't apply any ansi #puts "===>zerospan hlims: $hlims" set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ @@ -2424,13 +2424,13 @@ tcl::namespace::eval textblock { append part_header $header_frame\n } set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] + set adjusted_lines [list] foreach ln [split $part_header \n] { if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline + lappend adjusted_lines $padline } else { lappend adjusted_lines $ln } @@ -2496,7 +2496,7 @@ tcl::namespace::eval textblock { set cell_ansibase "" set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row + set ansiborder_final $ansiborder_body_col_row #$c will always have ansi resets due to overtype behaviour ? #todo - review overtype if {[punk::ansi::ta::detect $c]} { @@ -2514,7 +2514,7 @@ tcl::namespace::eval textblock { #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] #puts --->[ansistring VIEW $codes] - + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { #special case double reset at end of content @@ -2527,7 +2527,7 @@ tcl::namespace::eval textblock { set cell_ansibase $cell_ansi_tail } else { #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase } } else { if {$ftblock} { @@ -2555,7 +2555,7 @@ tcl::namespace::eval textblock { } else { set bmap $topmap if {$do_show_header} { - set blims $blims_top + set blims $blims_top } else { set blims $blims_top_headerless } @@ -2631,7 +2631,7 @@ tcl::namespace::eval textblock { } else { set output $part_body } - return $output + return $output } else { return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] } @@ -2652,15 +2652,15 @@ tcl::namespace::eval textblock { } error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" } - #assert cidx is integer >=0 - set num_header_rows [my header_count] - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] set ansibase_col [tcl::dict::get $cdef -ansibase] set textalign [tcl::dict::get $cdef -textalign] switch -- $textalign { left {set pad right} - right {set pad left} + right {set pad left} default { set pad "centre" ;#todo? } @@ -2684,7 +2684,7 @@ tcl::namespace::eval textblock { # lappend configured_widths [my column_width_configured $c] #} - set output [tcl::dict::create] + set output [tcl::dict::create] tcl::dict::set output headers [list] set showing_vseps [my Showing_vseps] @@ -2720,10 +2720,10 @@ tcl::namespace::eval textblock { set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerrow_colspans $cidx] + set this_span [lindex $headerrow_colspans $cidx] - #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] @@ -2734,7 +2734,7 @@ tcl::namespace::eval textblock { set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top set hval_block [::join $hval_lines \n] set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell + tcl::dict::lappend output headers $hcell } @@ -2758,7 +2758,7 @@ tcl::namespace::eval textblock { set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { set rowh $rowdefminh ;#an exact height is defined for the row } else { if {$rowdefminh eq ""} { @@ -2780,7 +2780,7 @@ tcl::namespace::eval textblock { } } } - + set cell_lines [lrepeat $rowh $cell_line_blank] #set cell_blank [join $cell_lines \n] @@ -2792,7 +2792,7 @@ tcl::namespace::eval textblock { set cval_lines [lrange $cval_lines 0 $rowh-1] set cval_block [::join $cval_lines \n] - #//JMN assert widest cval_line = datawidth = known_blockwidth + #//JMN assert widest cval_line = datawidth = known_blockwidth set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] tcl::dict::lappend output cells $cell @@ -2817,7 +2817,7 @@ tcl::namespace::eval textblock { #[call class::table [method debug]] #[para] display lots of debug information about how the table is constructed. - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) set defaults [tcl::dict::create\ -usetables 1\ ] @@ -2836,7 +2836,7 @@ tcl::namespace::eval textblock { puts stdout "rowstates: $o_rowstates" #puts stdout "columndefs: $o_columndefs" puts stdout "columndefs:" - if {!$opt_usetables} { + if {!$opt_usetables} { tcl::dict::for {k v} $o_columndefs { puts " $k $v" } @@ -2849,7 +2849,7 @@ tcl::namespace::eval textblock { continue } $t add_column -headers $property - } + } break } @@ -2858,15 +2858,15 @@ tcl::namespace::eval textblock { set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths tcl::dict::for {col coldef} $o_columndefs { set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] + set colheaders [tcl::dict::get $coldef -headers] #inner table probably overkill here ..but just as easy set htable [textblock::class::table new] $htable configure -show_header 1 -show_edge 0 -show_hseps 0 $htable add_column -headers row $htable add_column -headers text $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 + $htable add_column -headers span + set hnum 0 set spans [tcl::dict::get $o_columndefs $col -header_colspans] foreach h $colheaders s $spans { lassign [textblock::size $h] _w width _h height @@ -2881,7 +2881,7 @@ tcl::namespace::eval textblock { if {$w > [tcl::dict::get $max_widths $icol]} { tcl::dict::set max_widths $icol $w } - incr icol + incr icol } } @@ -2899,7 +2899,7 @@ tcl::namespace::eval textblock { tcl::dict::for {innercol maxw} $max_widths { $htable configure_column $innercol -minwidth $maxw -blockalign left } - lappend row [$htable print] + lappend row [$htable print] $htable destroy } default { @@ -2923,7 +2923,7 @@ tcl::namespace::eval textblock { tcl::dict::for {k coldef} $o_columndefs { if {[tcl::dict::exists $o_columndata $k]} { set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] + set coldata [tcl::dict::get $o_columndata $k] set colinfo "rowcount: [llength $coldata]" set allfields [concat $headerlist $coldata] if {[llength $allfields]} { @@ -2944,7 +2944,7 @@ tcl::namespace::eval textblock { if {$c == 0} { lappend cols [my get_column_by_index $c -position left] " " } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] + lappend cols [my get_column_by_index $c -position right] } else { lappend cols [my get_column_by_index $c -position inner] " " } @@ -3089,7 +3089,7 @@ tcl::namespace::eval textblock { lappend configured_widths [my column_width_configured $c] } set header_colspans [my header_colspans] - set width_max $colwidth + set width_max $colwidth set test_width $colwidth set showing_vseps [my Showing_vseps] set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] @@ -3125,7 +3125,7 @@ tcl::namespace::eval textblock { if {$showing_vseps} { incr others_width 1 } - } + } set total_spanned_width [expr {$width_max + $others_width}] if {$thiscol_widest_header > $total_spanned_width} { #this just allocates the extra space in the current column - which is not great. @@ -3172,9 +3172,9 @@ tcl::namespace::eval textblock { return true } } - return false + return false } - + method column_datawidth {index_expression args} { set opts [tcl::dict::create\ -headers 0\ @@ -3289,11 +3289,11 @@ tcl::namespace::eval textblock { set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] set widest [expr {max($valwidest,$hwidest)}] } else { - set widest $hwidest + set widest $hwidest } return $widest } - #print1 uses basic column joining - useful for testing/debug especially with colspans + #print1 uses basic column joining - useful for testing/debug especially with colspans method print1 {args} { if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3338,15 +3338,15 @@ tcl::namespace::eval textblock { incr colposn } if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] + return [textblock::join -- {*}$blocks] } else { return "No columns matched" } } method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr set colspace_added [tcl::dict::create] - + set ordered_spans [tcl::dict::create] tcl::dict::for {col spandata} [my spangroups] { set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] @@ -3363,7 +3363,7 @@ tcl::namespace::eval textblock { } } tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 + tcl::dict::set colspace_added $col 0 set spanlengths [tcl::dict::get $spandata spanlengths] foreach slen $spanlengths { @@ -3373,13 +3373,13 @@ tcl::namespace::eval textblock { set hwidth [tcl::dict::get $s headerwidth] set hrow [tcl::dict::get $s hrow] set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth } } } - #safe jumptable test + #safe jumptable test #dict for {spanid spandata} $ordered_spans {} tcl::dict::for {spanid spandata} $ordered_spans { lassign [split $spanid ,] startcol hrow @@ -3390,7 +3390,7 @@ tcl::namespace::eval textblock { if {$num_cols_spanned == 1} { set col [lindex $memcols 0] set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { + if {$space_to_alloc > 0} { set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] if {$maxwidth ne ""} { if {$maxwidth > [tcl::dict::get $colwidths $col]} { @@ -3400,7 +3400,7 @@ tcl::namespace::eval textblock { } set will_alloc [expr {min($space_to_alloc,$can_alloc)}] } else { - set will_alloc $space_to_alloc + set will_alloc $space_to_alloc } if {$will_alloc} { #tcl::dict::set colwidths $col $hwidth @@ -3422,12 +3422,12 @@ tcl::namespace::eval textblock { if {[my Showing_vseps]} { set sepcount [expr {$num_cols_spanned -1}] incr space_to_alloc -$sepcount - } + } #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added switch -- $allocmethod { least { #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3445,10 +3445,10 @@ tcl::namespace::eval textblock { } } least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth #(we should be able to collapse column width to zero and have header colspans gracefully respond) #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3485,7 +3485,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3521,7 +3521,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3533,10 +3533,10 @@ tcl::namespace::eval textblock { } - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] } - #spangroups keyed by column + #spangroups keyed by column method spangroups {} { #*** !doctools #[call class::table [method spangroups]] @@ -3550,8 +3550,8 @@ tcl::namespace::eval textblock { tcl::dict::set spangroups $c [list spanlengths {}] set spanlist [my column_get_spaninfo $c] set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist while {[llength $ungrouped]} { set spanlen [lindex $ungrouped 0 $index_spanlen_val] @@ -3569,14 +3569,14 @@ tcl::namespace::eval textblock { tcl::dict::set headerwidths $hcol,$hrow $hwidth } lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo + lappend sgroup $spaninfo } set spanlengths [tcl::dict::get $spangroups $c spanlengths] lappend spanlengths $spanlen tcl::dict::set spangroups $c spanlengths $spanlengths tcl::dict::set spangroups $c spangroups $spanlen $sgroup set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } + } } return $spangroups } @@ -3660,14 +3660,14 @@ tcl::namespace::eval textblock { basic { #basic column by column - This allocates extra space to first span/column as they're encountered. #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. + #The header values can extend over some of the spanned columns - but not optimally so. set o_calculated_column_widths [list] for {set c 0} {$c < $column_count} {incr c} { lappend o_calculated_column_widths [my basic_column_width $c] } } simplistic { - #just uses the widest column data or header element. + #just uses the widest column data or header element. #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column #This is a conservative option potentially useful in testing/debugging. set o_calculated_column_widths [list] @@ -3676,7 +3676,7 @@ tcl::namespace::eval textblock { } } span { - #widest of smallest spans first method + #widest of smallest spans first method #set calcresult [my columncalc_spans least] set calcresult [my columncalc_spans least_unmaxed] set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] @@ -3695,7 +3695,7 @@ tcl::namespace::eval textblock { return $o_calculated_column_widths } method print2 {args} { - variable full_column_cache + variable full_column_cache set full_column_cache [tcl::dict::create] if {![llength $args]} { @@ -3749,10 +3749,10 @@ tcl::namespace::eval textblock { tcl::dict::set full_column_cache $c $columninfo } set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] @@ -3762,12 +3762,12 @@ tcl::namespace::eval textblock { #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3787,7 +3787,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3839,7 +3839,7 @@ tcl::namespace::eval textblock { } set blocks [list] set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set table "" foreach c $cols { @@ -3855,20 +3855,20 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3888,7 +3888,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3916,7 +3916,7 @@ tcl::namespace::eval textblock { method print {args} { #*** !doctools #[call class::table [method print]] - #[para] Return the table as text suitable for console display + #[para] Return the table as text suitable for console display if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3944,7 +3944,7 @@ tcl::namespace::eval textblock { } } set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set header_build "" set body_blocks [list] @@ -3962,7 +3962,7 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] set headerheight [tcl::dict::get $columninfo headerheight] #set nextcol_lines [split $nextcol \n] #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] @@ -3971,7 +3971,7 @@ tcl::namespace::eval textblock { set nextcol_body [tcl::dict::get $columninfo body] if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header + set header_build $nextcol_header } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] @@ -3979,7 +3979,7 @@ tcl::namespace::eval textblock { #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } lappend body_blocks $nextcol_body - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {![llength $body_blocks]} { @@ -4014,7 +4014,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -4039,11 +4039,11 @@ tcl::namespace::eval textblock { method print_bodymatrix {} { #*** !doctools #[call class::table [method print_bodymatrix]] - #[para] output the matrix string corresponding to the body data using the matrix 2string format + #[para] output the matrix string corresponding to the body data using the matrix 2string format #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. # - + set m [my as_matrix] $m format 2string @@ -4098,7 +4098,7 @@ tcl::namespace::eval textblock { return $t } - #more complex colspans + #more complex colspans proc spantest2 {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} @@ -4137,7 +4137,7 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - @values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { @@ -4163,7 +4163,7 @@ tcl::namespace::eval textblock { " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] + ] set type_colours [list] @@ -4173,71 +4173,71 @@ tcl::namespace::eval textblock { set ansi [a+ {*}$fc web-black Web-gold] set val [list ansi $ansi cat alkaline_earth] foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val + tcl::dict::set ecat $e $val } set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val } set cat [list Li Na K Rb Cs Fr] - #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val } - set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] + set ansi [a+ {*}$fc web-black Web-lightskyblue] set val [list ansi $ansi cat post_transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list B Si Ge As Sb Te At] - #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] + set ansi [a+ {*}$fc web-black Web-orchid] set val [list ansi $ansi cat noble_gases] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] + set ansi [a+ {*}$fc web-black Web-plum] set val [list ansi $ansi cat actinoids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - #set ansi [a+ {*}$fc web-black Web-tan] - set ansi [a+ {*}$fc black Term-tan] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] set val [list ansi $ansi cat lanthanoids] foreach e $cat { tcl::dict::set ecat $e $val } - set ansi [a+ {*}$fc web-black Web-whitesmoke] + set ansi [a+ {*}$fc web-black Web-whitesmoke] set val [list ansi $ansi cat other] foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { tcl::dict::set ecat $e $val @@ -4264,7 +4264,7 @@ tcl::namespace::eval textblock { set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] set c 0 foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 + $t configure_column $c -headers [list $h] -minwidth 2 incr c } set ccount [$t column_count] @@ -4279,7 +4279,7 @@ tcl::namespace::eval textblock { } dict for {k v} $conf { if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] + dict set conf $k [dict get $opts $k] } } @@ -4310,14 +4310,14 @@ tcl::namespace::eval textblock { } proc bookend_lines {block start {end "\x1b\[m"}} { - set out "" + set out "" foreach ln [split $block \n] { append out $start $ln $end \n } return [string range $out 0 end-1] } proc ansibase_lines {block {newprefix ""}} { - set base "" + set base "" set out "" if {$newprefix eq ""} { if {![punk::ansi::ta::detect $block]} { @@ -4340,7 +4340,7 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + set parts [linsert $parts $code_idx+1 $base] } incr code_idx 2 } @@ -4373,7 +4373,7 @@ tcl::namespace::eval textblock { incr offset } incr code_idx 2 - } + } append out {*}$parts \n } return [string range $out 0 end-1] @@ -4398,29 +4398,29 @@ tcl::namespace::eval textblock { Will not be visible if -show_edge is false" -titlealign -type string -choices {left centre right} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ - -help "frame type or dict for custom frame" + -help "frame type or dict for custom frame" -show_edge -default "" -type boolean\ -help "show outer border of table" - -show_seps -default "" -type boolean + -show_seps -default "" -type boolean -show_vseps -default "" -type boolean\ - -help "Show vertical table separators" + -help "Show vertical table separators" -show_hseps -default "" -type boolean\ -help "Show horizontal table separators (default 0 if no existing -table supplied)" -colheaders -default "" -type list\ -help {list of lists. list of column header values. Outer list must match number of columns. - A table + A table e.g single header row: -colheaders {{column_a} {column_b} {column_c}} e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}} Note that each element of the outer list is itself a list so: - -colheaders {"column a" "column b" "column c"} + -colheaders {"column a" "column b" "column c"} Is likely not the right format if it was intended to have a single header row where the column titles contain spaces. The correct syntax for that would be: - -colheaders {{"column a"} {"column b"} {"column c"}} + -colheaders {{"column a"} {"column b"} {"column c"}} For spanning header cells - use 'set t [list_as_table -return tableobject ...]' and then something like: - $t configure_header 1 -colspans {3 0 0}; $t print + $t configure_header 1 -colspans {3 0 0}; $t print } -header -default "" -type list -multiple 1\ -help "Each supplied -header argument is a header row. @@ -4498,14 +4498,14 @@ tcl::namespace::eval textblock { if {[llength $colheaders] < $c+1} { lappend colheaders [lrepeat $r {}] } - set colinfo [lindex $colheaders $c] + set colinfo [lindex $colheaders $c] if {$r > [llength $colinfo]} { set diff [expr {$r - [llength $colinfo]}] lappend colinfo {*}[lrepeat $diff {}] } lappend colinfo $cell lset colheaders $c $colinfo - incr c + incr c } incr r } @@ -4516,15 +4516,15 @@ tcl::namespace::eval textblock { if {![tcl::dict::exists $opts received -show_header]} { set show_header 1 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } } else { if {![tcl::dict::exists $opts received -show_header]} { set show_header 0 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } - } + } if {[tcl::string::is integer -strict $opt_columns]} { set cols $opt_columns @@ -4536,7 +4536,7 @@ tcl::namespace::eval textblock { if {[llength $colheaders]} { set cols [llength $colheaders] } else { - set cols 2 ;#seems a reasonable default + set cols 2 ;#seems a reasonable default } } #defaults for new table only @@ -4605,13 +4605,13 @@ tcl::namespace::eval textblock { if {"-titlealign" in $received} { $t configure -titlealign [dict get $opts -titlealign] } - #puts stdout $rowdata + #puts stdout $rowdata if {[tcl::dict::get $opts -return] eq "table"} { set result [$t print] if {$is_new_table} { $t destroy } - return $result + return $result } else { return $t } @@ -4627,13 +4627,13 @@ tcl::namespace::eval textblock { error "textblock::block blockheight must be a positive integer" } if {$char eq ""} {return ""} - #using tcl::string::length is ok + #using tcl::string::length is ok if {[tcl::string::length $char] == 1} { set row [tcl::string::repeat $char $blockwidth] set mtrx [lrepeat $blockheight $row] return [::join $mtrx \n] } else { - set charblock [tcl::string::map [list \r\n \n] $char] + set charblock [tcl::string::map [list \r\n \n] $char] if {[tcl::string::last \n $charblock] >= 0} { if {$blockwidth > 1} { #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) @@ -4657,7 +4657,7 @@ tcl::namespace::eval textblock { columns wide and size rows tall. (which on a terminal will show as a vertically oriented rectangle due to - cells being taller than their width) + cells being taller than their width) The characters used are 123456789ABCDEF @@ -4681,7 +4681,7 @@ tcl::namespace::eval textblock { The additional pseudo-color 'rainbow' is available. - " + " } proc testblock {args} { @@ -4700,14 +4700,14 @@ tcl::namespace::eval textblock { lappend rainbow_list {37 40} ;#white Black lappend rainbow_list {black Yellow} lappend rainbow_list red - lappend rainbow_list green + lappend rainbow_list green lappend rainbow_list yellow lappend rainbow_list blue lappend rainbow_list purple - lappend rainbow_list cyan + lappend rainbow_list cyan lappend rainbow_list {white Red} - #set rainbow_direction "horizontal" + #set rainbow_direction "horizontal" #set vpos [lsearch $colour vertical] #if {$vpos >= 0} { # set rainbow_direction vertical @@ -4719,11 +4719,11 @@ tcl::namespace::eval textblock { # set colour [lremove $colour $hpos] #} set direction [dict get $argd opts -direction] - + set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + set charsubset [lrange $chars 0 $size-1] if {"noreset" in $colour} { set RST "" } else { @@ -4737,7 +4737,7 @@ tcl::namespace::eval textblock { for {set i 0} {$i <$size} {incr i} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] set ansi [a+ {*}$colour2] - + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } @@ -4748,7 +4748,7 @@ tcl::namespace::eval textblock { } } elseif {"rainbow" in $colour} { #direction must be horizontal - set block "" + set block "" for {set r 0} {$r < $size} {incr r} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] set ansi [a+ {*}$colour2] @@ -4763,7 +4763,7 @@ tcl::namespace::eval textblock { set block [tcl::string::trimright $block \n] return $block } else { - #row first - + #row first - set rows [list] foreach ch $charsubset { lappend rows [tcl::string::repeat $ch $size] @@ -4790,7 +4790,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4799,8 +4799,8 @@ tcl::namespace::eval textblock { if {[tcl::string::last \n $textblock] >= 0} { return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } - return [punk::char::ansifreestring_width $textblock] - } + return [punk::char::ansifreestring_width $textblock] + } #gather info about whether ragged (samewidth each line = false) and min width proc widthinfo {textblock} { #backspaces, vertical tabs ? @@ -4814,7 +4814,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4843,7 +4843,7 @@ tcl::namespace::eval textblock { if {[punk::ansi::ta::detect $tl]} { set tl [punk::ansi::ansistripraw $tl] } - return [punk::char::ansifreestring_width $tl] + return [punk::char::ansifreestring_width $tl] } #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. proc string_length_line_max {textblock} { @@ -4864,7 +4864,7 @@ tcl::namespace::eval textblock { proc height {textblock} { #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) + #empty string still has height 1 (at least for left-right/right-left languages) #vertical tab on a proper terminal should move directly down. #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) @@ -4894,7 +4894,7 @@ tcl::namespace::eval textblock { #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } else { - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -4933,7 +4933,7 @@ tcl::namespace::eval textblock { } } else { set num_le 0 - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -5010,14 +5010,14 @@ tcl::namespace::eval textblock { # -- --- --- --- --- --- --- --- --- --- set padchar [tcl::dict::get $opts -padchar] #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map #The caller may also use ansi within the padchar - although it's unlikely to be efficient. # -- --- --- --- --- --- --- --- --- --- set known_whiches [list l left r right c center centre] set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] switch -- $opt_which { center - centre - c { - set which c + set which c } left - l { set which l @@ -5055,7 +5055,7 @@ tcl::namespace::eval textblock { set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. set datawidth "" if {$width eq "auto"} { - #for auto - we + #for auto - we if {$known_blockwidth eq ""} { if {$known_samewidth ne "" && $known_samewidth} { set datawidth [textblock::widthtopline $block] @@ -5077,7 +5077,7 @@ tcl::namespace::eval textblock { set datawidth [textblock::widthtopline $block] } else { set datawidth $known_blockwidth - } + } } #assert datawidth may still be empty string } @@ -5096,7 +5096,7 @@ tcl::namespace::eval textblock { #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) #we should use overtype with suitable replacement char (space?) for chopped double-wides if {!$pad_has_ansi} { - return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] } else { set base [tcl::string::repeat " " $width] return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] @@ -5105,7 +5105,7 @@ tcl::namespace::eval textblock { #review - tcl format can only pad with zeros or spaces? #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - #review - surprisingly, this doesn't seem to be a performance win + #review - surprisingly, this doesn't seem to be a performance win #No detectable diff on small blocks - slightly worse on large blocks # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position @@ -5144,7 +5144,7 @@ tcl::namespace::eval textblock { set parts [list $block] } - set line_chunks [list] + set line_chunks [list] set line_len 0 set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad foreach {pt ansi} $parts { @@ -5179,7 +5179,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5237,7 +5237,7 @@ tcl::namespace::eval textblock { } #don't let trailing empty ansi affect the line_chunks length if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? } } #pad last line @@ -5251,7 +5251,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5321,7 +5321,7 @@ tcl::namespace::eval textblock { if {$i == $i_last_code} { return [lappend out $str {*}[lrange $ansisplits $i end]] } - #code being empty can only occur when we have reached last pt + #code being empty can only occur when we have reached last pt #we have returned by then. lappend out $code incr i 2 @@ -5338,7 +5338,7 @@ tcl::namespace::eval textblock { set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] + set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] set t [textblock::list_as_table -columns 3 -return tableobject $testlist] $t configure_column 0 -headers [list "ansi"] @@ -5397,20 +5397,20 @@ tcl::namespace::eval textblock { set r3 [list "column\ncolours"] #1 - #test without table padding + #test without table padding #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering #(basically a mechanism to add extra resets at start and end of each line) #dict for {b bdict} $blockinfo { # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] #} #2 - the more useful one? tcl::dict::for {b bdict} $blockinfo { lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] lappend r3 "" "" } @@ -5486,7 +5486,7 @@ tcl::namespace::eval textblock { # >} .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| # >} punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines } punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } + } proc example {args} { @@ -5930,7 +5930,7 @@ tcl::namespace::eval textblock { set RST [a] set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST + set pleft_greenb $greenb$pleft$RST set pright_redb $redb$pright$RST set prightair_cyanb $cyanb$prightair$RST set cpunks [textblock::join -- $pleft_greenb $pright_redb] @@ -6064,7 +6064,7 @@ tcl::namespace::eval textblock { } } } - } + } variable framedef_cache [tcl::dict::create] proc framedef {args} { #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. @@ -6072,7 +6072,7 @@ tcl::namespace::eval textblock { #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. #the arc set can't even join to itself e.g with curved equivalents of T-like shapes - #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. variable framedef_cache set cache_key $args if {[tcl::dict::exists $framedef_cache $cache_key]} { @@ -6115,10 +6115,10 @@ tcl::namespace::eval textblock { if {![llength $rawglobs] || "all" in $rawglobs || "*" in $rawglobs} { set globs * } else { - set globs [list] + set globs [list] foreach g $rawglobs { switch -- $g { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - hltj - hlbj - vllj - vlrj { lappend globs $g } @@ -6150,7 +6150,7 @@ tcl::namespace::eval textblock { } default { #must look like a glob search if not one of the above - if {[regexp {[*?\[\]]} $g]} { + if {[regexp {[*?\[\]]} $g]} { lappend globs $g } else { set bad_option 1 @@ -6174,7 +6174,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - @values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -6191,7 +6191,7 @@ tcl::namespace::eval textblock { set joins [tcl::dict::get $opts -joins] set boxonly [tcl::dict::get $opts -boxonly] - + #sorted order down left right up #1 x choose 4 #4 x choose 3 @@ -6204,7 +6204,7 @@ tcl::namespace::eval textblock { #e.g down-light, up-heavy set join_targets [tcl::dict::create left "" down "" right "" up ""] foreach jt $joins { - lassign [split $jt -] direction target + lassign [split $jt -] direction target if {$target ne ""} { tcl::dict::set join_targets $direction $target } @@ -6234,7 +6234,7 @@ tcl::namespace::eval textblock { #set brc [cd::brc] set brc [punk::ansi::g0 j] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6382,7 +6382,7 @@ tcl::namespace::eval textblock { set trc + set blc + set brc + - #horizontal and vertical bar joins + #horizontal and vertical bar joins #set hltj $hlt #set hlbj $hlb #set vllj $vll @@ -6392,7 +6392,7 @@ tcl::namespace::eval textblock { set hlbj + set vllj + set vlrj + - #our corners are all + already - so we won't do anything for directions or targets + #our corners are all + already - so we won't do anything for directions or targets } "light" { @@ -6408,7 +6408,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_lur] set brc [punk::char::charshort boxd_lul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6423,16 +6423,16 @@ tcl::namespace::eval textblock { #default empty targets to current box type 'light' foreach dir {down left right up} { set rawtarget [tcl::dict::get $join_targets $dir] - lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same + lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same switch -- $target { "" - light { - set target$dir light + set target$dir light } ascii - altg - arc { - set target$dir light + set target$dir light } heavy { - set target$dir $target + set target$dir $target } default { set target$dir other @@ -6504,7 +6504,7 @@ tcl::namespace::eval textblock { other-light { set blc \u2534 ;#(btj) set tlc \u252c ;#(ttj) - #brc - default corner + #brc - default corner set vllj \u2524 ;# (rtj) } other-other { @@ -6546,7 +6546,7 @@ tcl::namespace::eval textblock { light-other { set blc \u251c ;# (ltj) #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) + set brc \u2524 ;# boxd_lvl (rtj) set hlbj \u252c ;# (ttj) } light-heavy { @@ -6682,41 +6682,41 @@ tcl::namespace::eval textblock { light_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } light_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] tcl::dict::with arcframe {} ;#extract keys as vars } "heavy" { @@ -6731,7 +6731,7 @@ tcl::namespace::eval textblock { set trc [punk::char::charshort boxd_hdl] set blc [punk::char::charshort boxd_hur] set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6743,10 +6743,10 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - heavy { - set target$dir heavy + set target$dir heavy } light - ascii - altg - arc { - set target$dir light + set target$dir light } default { set target$dir other @@ -6773,12 +6773,12 @@ tcl::namespace::eval textblock { #2 switch -- $targetleft { light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) set vllj \u2528 ;# left light (rtj) } heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set blc [punk::char::charshort boxd_huhz] ;# (btj) set vllj \u252b ;#(rtj) } @@ -6833,7 +6833,7 @@ tcl::namespace::eval textblock { set vllj \u2528 ;# left light (rtj) } down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) set hlbj \u252F ;# down light (ttj) @@ -6954,41 +6954,41 @@ tcl::namespace::eval textblock { heavy_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } heavy_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] tcl::dict::with arcframe {} ;#extract keys as vars } "double" { @@ -7004,7 +7004,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7163,7 +7163,7 @@ tcl::namespace::eval textblock { } left_right { #8 - + #from 2 #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set tlc \U2566 ;# (ttj) @@ -7254,7 +7254,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7266,7 +7266,7 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - arc { - set target$dir self + set target$dir self } default { set target$dir other @@ -7282,7 +7282,7 @@ tcl::namespace::eval textblock { set blc \u251c ;# *light (ltj) #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal #set brc \u2524 ;# *light(rtj) #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) @@ -7354,41 +7354,41 @@ tcl::namespace::eval textblock { arc_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } arc_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] tcl::dict::with arcframe {} ;#extract keys as vars } block1 { @@ -7402,7 +7402,7 @@ tcl::namespace::eval textblock { set blc \u2594 ;# upper one eighth block set brc \u2594 ;# upper one eight block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7410,7 +7410,7 @@ tcl::namespace::eval textblock { } block2 { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7425,7 +7425,7 @@ tcl::namespace::eval textblock { set trc \U1fb7e ;#legacy block set blc \U1fb7c ;#legacy block set brc \U1fb7f ;#legacy block - + if {(![interp issafe])} { if {![catch {punk::console::check::has_bug_legacysymbolwidth} symbug] && $symbug} { #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems @@ -7437,7 +7437,7 @@ tcl::namespace::eval textblock { } } - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7445,7 +7445,7 @@ tcl::namespace::eval textblock { } block2hack { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7466,7 +7466,7 @@ tcl::namespace::eval textblock { # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs + #except that the punk overtype library does recognise PMs #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block @@ -7474,7 +7474,7 @@ tcl::namespace::eval textblock { set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7491,7 +7491,7 @@ tcl::namespace::eval textblock { set blc \u2599 set brc \u259f - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7526,9 +7526,9 @@ tcl::namespace::eval textblock { set $t [tcl::dict::get $custom_frame $t] } else { #set more explicit type to it's more general counterpart if it's missing - #e.g hlt -> hl - #e.g hltj -> hlt - set $t [set [string range $t 0 end-1]] + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] } } #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set @@ -7671,14 +7671,14 @@ tcl::namespace::eval textblock { tcl::dict::for {k v} $display_dict { lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? #set fwidth [textblock::width $frame] set frameinfo "$k used:$used " set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] if {$allinone_width >= $termwidth} { #split across 2 lines - append out "$frameinfo\n" + append out "$frameinfo\n" append out $frame \n } else { append out [textblock::join -- $frameinfo $frame]\n @@ -7707,7 +7707,7 @@ tcl::namespace::eval textblock { set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] return $FRAMETYPELABELS } - #proc EG {} "return {[a+ brightblack]}" + #proc EG {} "return {[a+ brightblack]}" #make EG fetch from SGR cache so as to abide by colour off/on proc EG {} { a+ brightblack @@ -7729,7 +7729,7 @@ tcl::namespace::eval textblock { -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and provide more comprehensive error info. - Set false for slight performance improvement." + Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ @@ -7741,10 +7741,10 @@ tcl::namespace::eval textblock { passing an empty string will result in no box, but title/subtitle will still appear if supplied. ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict - -joins -default {} -type list + -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. - May contain ANSI - no trailing reset required. + May contain ANSI - no trailing reset required. ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" -titlealign -default "centre" -choices {left centre right} @@ -7778,7 +7778,7 @@ tcl::namespace::eval textblock { -help "Show ANSI control characters within frame contents. (Control Representation Mode) Frame width doesn't adapt and content may be truncated - so -width may need to be manually set to display more." + so -width may need to be manually set to display more." @values -min 0 -max 1 contents -default "" -type string\ @@ -7793,7 +7793,7 @@ tcl::namespace::eval textblock { # #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it # - but we would need to maintain support for the rendered-string based operations too. proc frame {args} { @@ -7828,8 +7828,8 @@ tcl::namespace::eval textblock { # for ansi art - -pad 0 is likely to be preferable set has_contents 0 - set optlist $args ;#initial only - content will be removed - #no solo opts for frame + set optlist $args ;#initial only - content will be removed + #no solo opts for frame if {[llength $args] %2 == 0} { if {[lindex $args end-1] eq "--"} { set contents [lpop optlist end] @@ -7843,7 +7843,7 @@ tcl::namespace::eval textblock { set contents [lpop optlist end] set has_contents 1 } - + #todo args -justify left|centre|right (center) #todo -blockalignbias -textalignbias? #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache @@ -7852,12 +7852,12 @@ tcl::namespace::eval textblock { foreach {k v} $optlist { set k2 [tcl::prefix::match -error "" $optnames $k] switch -- $k2 { - -etabs - -type - -boxlimits - -boxmap - -joins + -etabs - -type - -boxlimits - -boxmap - -join - -title - -titlealign - -subtitle - -subtitlealign - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -crm_mode - - -usecache - -buildcache - -pad + - -usecache - -buildcache - -pad - -checkargs { tcl::dict::set opts $k2 $v } @@ -7878,21 +7878,21 @@ tcl::namespace::eval textblock { set contents [dict get $argd values contents] } - # -- --- --- --- --- --- + # -- --- --- --- --- --- # cache relevant set opt_usecache [tcl::dict::get $opts -usecache] set opt_buildcache [tcl::dict::get $opts -buildcache] set usecache $opt_usecache ;#may need to override set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination set opt_crm_mode [tcl::dict::get $opts -crm_mode] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_type [tcl::dict::get $opts -type] set opt_boxlimits [tcl::dict::get $opts -boxlimits] set opt_joins [tcl::dict::get $opts -joins] set opt_boxmap [tcl::dict::get $opts -boxmap] set buildcache $opt_buildcache set opt_pad [tcl::dict::get $opts -pad] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_title [tcl::dict::get $opts -title] set opt_subtitle [tcl::dict::get $opts -subtitle] set opt_width [tcl::dict::get $opts -width] @@ -7930,7 +7930,7 @@ tcl::namespace::eval textblock { ##e.g down-light, up-heavy #set join_targets [tcl::dict::create left "" down "" right "" up ""] #foreach jt $opt_joins { - # lassign [split $jt -] direction target + # lassign [split $jt -] direction target # if {$target ne ""} { # tcl::dict::set join_targets $direction $target # } @@ -8056,10 +8056,10 @@ tcl::namespace::eval textblock { set FSUB \uF2DD - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see + #set buildcache 0 ;#comment out for debug/analysis so we can see #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" set cache_key [a+ Web-red web-white]$cache_key[a] } @@ -8069,7 +8069,7 @@ tcl::namespace::eval textblock { #we can still substitute with right length set cache_key [a+ Web-steelblue web-black]$cache_key[a] } else { - #actual_contentwidth is narrower than frame - check template's patternwidth + #actual_contentwidth is narrower than frame - check template's patternwidth if {[tcl::dict::exists $frame_cache $cache_key]} { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] } else { @@ -8096,7 +8096,7 @@ tcl::namespace::eval textblock { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] set template [tcl::dict::get $frame_cache $cache_key frame] set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record set is_cached 1 } @@ -8107,7 +8107,7 @@ tcl::namespace::eval textblock { # -- --- --- --- --- set is_joins_ok 1 foreach v $opt_joins { - lassign [split $v -] direction target + lassign [split $v -] direction target switch -- $direction { left - right - up - down {} default { @@ -8126,7 +8126,7 @@ tcl::namespace::eval textblock { if {!$is_joins_ok} { error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set is_boxmap_ok 1 tcl::dict::for {boxelement subst} $opt_boxmap { switch -- $boxelement { @@ -8139,9 +8139,9 @@ tcl::namespace::eval textblock { } } if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" + error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #these are all valid commands for overtype:: switch -- $opt_textalign { left - right - centre - center {} @@ -8149,7 +8149,7 @@ tcl::namespace::eval textblock { error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" } } - # -- --- --- --- --- --- + # -- --- --- --- --- --- switch -- $opt_blockalign { left - right - centre - center {} default { @@ -8217,7 +8217,7 @@ tcl::namespace::eval textblock { switch -- $frameset { custom { #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely set vll_width [punk::ansi::printing_length $vll] set hlb_width [punk::ansi::printing_length $hlb] @@ -8235,8 +8235,8 @@ tcl::namespace::eval textblock { if {$opt_width eq ""} { #width wasn't specified - so user is expecting frame to adapt to title/contents #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] } else { @@ -8281,14 +8281,14 @@ tcl::namespace::eval textblock { set tbar [tcl::string::repeat $hlt $frame_inner_width] #set tbar [cd::groptim $tbar] set tbar [punk::ansi::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] + set bbar [tcl::string::repeat $hlb $frame_inner_width] #set bbar [cd::groptim $bbar] set bbar [punk::ansi::groptim $bbar] } default { set tbar [tcl::string::repeat $hlt $frame_inner_width] set bbar [tcl::string::repeat $hlb $frame_inner_width] - + } } @@ -8467,7 +8467,7 @@ tcl::namespace::eval textblock { #after overtype::block - our actual patternwidth may be less set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - if {$leftborder && $rightborder} { + if {$leftborder && $rightborder} { #set bodyparts [list $lhs $inner $rhs] set cache_bodyparts [list $lhs $cache_inner $rhs] } else { @@ -8522,12 +8522,12 @@ tcl::namespace::eval textblock { } set template $fscached ;#end !$is_cached - } + } - #use the same mechanism to build the final frame - whether from cache or template + #use the same mechanism to build the final frame - whether from cache or template if {$actual_contentwidth == 0} { set fs [tcl::string::map [list $FSUB " "] $template] } else { @@ -8549,7 +8549,7 @@ tcl::namespace::eval textblock { #set cwidth [textblock::width $contents] set cwidth $actual_contentwidth if {$opt_pad} { - set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) set paddedwidth [textblock::widthtopline $paddedcontents] #review - horizontal truncation if {$paddedwidth > $cache_patternwidth} { @@ -8590,7 +8590,7 @@ tcl::namespace::eval textblock { if {$is_cached} { - return $fs + return $fs } else { if {$buildcache} { tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] @@ -8621,9 +8621,9 @@ tcl::namespace::eval textblock { set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size + set fit_size $size if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size + set max_cross_size $fit_size } else { #todo - only allow divisors #set testsize [expr {min($fit_size,$opt_max_cross_size)}] @@ -8651,7 +8651,7 @@ tcl::namespace::eval textblock { set onecross "" set crossrows [list] set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] + set row [lrepeat $max_cross_size " "] #toparm for {set i 0} {$i < $armsize} {incr i} { set r $row @@ -8692,7 +8692,7 @@ tcl::namespace::eval textblock { return $out } - #Test we can join two coloured blocks + #Test we can join two coloured blocks proc test_colour {} { set b1 [a red]1\n2\n3[a] set b2 [a green]a\nb\nc[a] @@ -8716,10 +8716,10 @@ interp alias {} piper_blockjoin {} ::textblock::piper::join # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide textblock [tcl::namespace::eval textblock { variable version - set version 0.1.3 + set version 0.1.3 }] return diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.12.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.12.tm index 080e7da9..1983211c 100644 Binary files a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.12.tm and b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zipper-0.12.tm differ diff --git a/src/vfs/_vfscommon.vfs/modules/canaryspace-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/canaryspace-0.1.0.tm index 234f1e86..ffe7f1d9 100644 --- a/src/vfs/_vfscommon.vfs/modules/canaryspace-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/canaryspace-0.1.0.tm @@ -13,8 +13,8 @@ # Meta summary Diagnostic tool for namespace navigation/introspection to help avoid command conflicts. # Meta description canaryspace loads the ::canaryspace namespace with wrappers for the set of commands # Meta description that exist in the global namespace :: at the time the canaryspace package is loaded. -# Meta description These commands just emit info to stderr to assist in determining whether calls are -# Meta description unintentionally being run in the namespace. +# Meta description These commands just emit info to stderr to assist in determining whether calls are +# Meta description unintentionally being run in the namespace. # Meta description This is often the case with commands which use uplevel 1 or similar constructs to call # Meta description code in the callers namespace. If such commands need to run in arbitrary namespaces # Meta description which may have arbitrary commands then uplevelled commands may need to be prefixed with @@ -68,6 +68,6 @@ namespace eval canaryspace { ## Ready package provide canaryspace [namespace eval canaryspace { ::variable version - ::set version 0.1.0 + ::set version 0.1.0 }] return \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm index 42bd91e6..cf73c712 100644 --- a/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/patternpunk-1.1.tm @@ -117,7 +117,7 @@ punk::args::define { @cmd -name ">punk . poses" -help "Show or list the poses for the Punk mascot" -censored -default 1 -type boolean -help "Set true to include mild toilet humour poses" -return -default table -choices {list table} -} +} >punk .. Method poses {args} { set argd [punk::args::get_by_id ">punk . poses" $args] set censored [dict get $argd opts -censored] @@ -424,7 +424,7 @@ namespace eval patternpunk::lib { proc K {x y} {return $x} } package provide patternpunk [namespace eval patternpunk { - variable version + variable version set version 1.1 }] diff --git a/src/vfs/_vfscommon.vfs/modules/picalc-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/picalc-0.1.0.tm new file mode 100644 index 00000000..7b761812 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/picalc-0.1.0.tm @@ -0,0 +1,642 @@ +# -*- 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.3.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 picalc 0.1.0 +# Meta platform tcl +# Meta license MIT +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_picalc 0 0.1.0] +#[copyright "2025"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require picalc] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of picalc +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by picalc +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::lib +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::lib}] +#[item] [package {punk::args}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval picalc::class { + #*** !doctools + #[subsection {Namespace picalc::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +tcl::namespace::eval picalc { + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + # Base namespace + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + #*** !doctools + #[subsection {Namespace picalc}] + #[para] Core API functions for picalc + #[list_begin definitions] + + variable PUNKARGS + + + + + #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" + #} + + #a known value for the _test functions + variable pifrac [string map {" " ""} "1415926535 8979323846 2643383279 5028841971"] + + #10k approx 2s + #20k approx 18s + #100k approx 1519s (25+minutes) + proc fast {dp} { + package require math::bigfloat + #math::bigfloat calculates using 'precision' + # -------------- + #Faster for large values - but timing variable on same values!! + #After running on large values becomes - slower than calc and spigot for small values (somewhere around <1k) + catch {unset ::math::bigfloat::_pi0} + #this is due to the caching mechanism - for the purposes of comparison/testing and consistent results, we'll 'wreck' that caching here. + # -------------- + set answer [math::bigfloat::tostr [math::bigfloat::pi [expr {$dp+3}]]] ;#we need to calculate with +3 precision to avoid rounding at the tail of chosen number of dp in all cases + return [string range $answer 0 end-2] + } + proc fast_test {max} { + variable pifrac + set pi 3.$pifrac + set result "" + set k 0 + while {$k <= $max} { + set answer [fast $k] + set lcp [punk::lib::longestCommonPrefix [list $pi $answer]] + set lcplen [string length $lcp] + set tail [string range $answer $lcplen end] + set greenanswer [a+ green]$lcp[a]$tail + + package require overtype ;#can't use 'format' for ANSI coloured strings + set col1 [string repeat " " [expr {$max + 3}]] + append result "[format %3s $k]-> [overtype::left $col1 $greenanswer]" \n + incr k + } + return $result + } + + + lappend PUNKARGS [list { + @id -id ::picalc::spigot + @cmd -name picalc::spigot -help\ + "Return digits of pi to dp decimal places. + + 'classic' Rabinowitz and Wagon spigot algorithm. + https://www.cs.williams.edu/~heeringa/classes/cs135/s15/readings/spigot.pdf + relatively straight port from pascal algorithm + + This algorithm for generating digits of pi uses a long list relative to the number of required digits + Performance doesn't seem to be spectacular, + (seems to be around 7-8secs for 1000 digits + 93s for 10K digits) + + The 'fast' (math::bigfloat based) function is much faster, + but also becomes extremely slow at a few 10's of thousands of digits. + " + @leaders -min 0 -max 0 + @opts + -channel -choices {none stdout stderr} -default none -choicerestricted 0 -choicelabels { + none\ + " Return as result string" + } + @values -min 0 -max 1 + dp -type int -default 32 -help\ + "Number of decimal places + (final digit is not rounded)" + }] + # 5K approx 25s + #10K approx 93s + proc spigot_emit {c chan countvar dp} { + upvar $countvar count + incr count + if {$chan eq "none"} { + upvar result r + append r $c ;#leave chars beyond dp to be trimmed by caller + return + } else { + if {$count > 2} { + if {$count <= $dp + 2} { + puts -nonewline $chan $c + } + } else { + if {$count == 1} { + puts -nonewline $chan 3 + } else { + puts -nonewline $chan "." + } + } + } + } + proc spigot {args} { + set argd [punk::args::parse $args withid ::picalc::spigot] + lassign [dict values $argd] leaders opts values received + set dp [dict get $values dp] + set channel [dict get $opts -channel] + + if {$dp < 1} {return 3} + set n [expr {$dp +2}] ;#dp +1 can get rounding errors + set len [expr {(10 * $n) / 3}] + set a [lrepeat [expr {$len+1}] 2] + set nines 0 + set predigit 0 + set result "" + set countvar 0 + if {$channel eq "none"} { + set dpextra 2 + } else { + set dpextra 2 + } + for {set j 1} {$j <= $len} {incr j} { + set q 0 + for {set i $len} {$i > 0} {incr i -1} { + set ai [lindex $a $i] + set x [expr {(10 * $ai) + ($q * $i)}] + lset a $i [expr {$x % (2*$i-1)}] + set q [expr {$x / (2*$i-1)}] + } + lset a 1 [expr {$q % 10}] + set q [expr {$q / 10}] + if {$q == 9} { + incr nines + } else { + if {$q == 10} { + #append result [expr {$predigit + 1}] + spigot_emit [expr {$predigit + 1}] $channel countvar $dp + if {$countvar == $dp +$dpextra} { + break + } + for {set k 1} {$k <= $nines} {incr k} { + #append result 0 + spigot_emit 0 $channel countvar $dp + if {$countvar == $dp +$dpextra} { + break + } + } + if {$countvar == $dp +$dpextra} { + break + } + + set predigit 0 + set nines 0 + } else { + #append result $predigit + spigot_emit $predigit $channel countvar $dp + if {$countvar == $dp +$dpextra} { + #+2 for leading 03 + break + } + set predigit $q + if {$nines != 0} { + for {set k 1} {$k <= $nines} {incr k} { + #append result 9 + spigot_emit 9 $channel countvar $dp + if {$countvar == $dp +$dpextra} { + break + } + } + if {$countvar == $dp +$dpextra} { + break + } + set nines 0 + } + } + } + } + #append result $predigit + spigot_emit $predigit $channel countvar $dp + #eg result 0314159 + if {$channel eq "none"} { + set result 3.[string range $result 2 $dp+1] ;#always trim to dp+1 (= $dp+2-1) - longer answer can have erroneous digits + #set result 3.[string range $result 2 end] + return $result + } else { + flush $channel + #review + return "emitted $countvar chars to channel $channel" + } + } + + + proc spigot_test {max} { + variable pifrac + set pi 3.$pifrac + set result "" + set k 0 + while {$k <= $max} { + set answer [spigot $k] + set lcp [punk::lib::longestCommonPrefix [list $pi $answer]] + set lcplen [string length $lcp] + set tail [string range $answer $lcplen end] + set greenanswer [a+ green]$lcp[a]$tail + + package require overtype ;#can't use 'format' for ANSI coloured strings + set col1 [string repeat " " [expr {$max + 3}]] + append result "[format %3s $k]-> [overtype::left $col1 $greenanswer]" \n + incr k + } + return $result + } + + + #def f(n): + # numerator, denominator = 1, 1 + # # i/(2i + 1) = n/(2n + 1), ..., 3/7, 2/5, 1/3 + # for i in range(n, 0, -1): + # # multiply by i/(2i + 1) + # numerator *= i + # denominator *= 2 * i + 1 + # # add 1 (p/q -> (p + q)/q = p/q + q/q = p/q + 1) + # numerator += denominator + # return 2 * numerator, denominator + #for n in range(20): + # p, q = f(n) + # print(Fraction(p, q)) + + #an approx of pi that rapidly creates a fraction too big to calculate with standard Tcl doubles.. + proc fraction {dp} { + if {$dp < 1} {return 3} + #determine an n big enough to give dp valid digits + set n [expr {$dp +1}] + set n [expr {(10 * $n) / 3}] + return [fraction_iteration $n] + } + # 5k approx 27s + # 10k approx 127s + proc calc {dp} { + if {$dp < 1} {return 3} + set n [expr {$dp +1}] + set n [expr {(10 * $n) / 3}] + package require math::bigfloat + lassign [fraction_iteration $n] a b + set bigfloat [math::bigfloat::div [math::bigfloat::int2float $a] [math::bigfloat::int2float $b]] + set answer [math::bigfloat::tostr $bigfloat] + #10*$d/3 == $n + #set trustdigits [expr {(3*$n)/10}] ;#?? + return [string range $answer 0 $dp+1] ;#= +2-1 + return $answer + } + proc calc_test {max} { + variable pifrac + set pi 3.$pifrac + set k 0 + set result "" + set last_lcplen 0 + set got "" + while {$k <= $max} { + set answer [calc $k] + + set lcp [punk::lib::longestCommonPrefix [list $pi $answer]] + set lcplen [string length $lcp] + if {$lcplen > $last_lcplen} { + set last_lcplen $lcplen + set got [string index $lcp end] + set c red + } else { + set c yellow + } + set tail [string range $answer $lcplen end] + set greenanswer [a+ green]$lcp[a]$tail + + package require overtype + set col1 [string repeat " " [expr {$max + 3}]] + append result "[overtype::left " " [a+ $c $got]] [format %3s $k]-> [overtype::left $col1 $greenanswer]" \n + incr k + } + return $result + } + + proc fraction_iteration {n} { + set numerator 1; set denominator 1 + for {set i $n} {$i > 0} {incr i -1} { + set numerator [expr {$numerator * $i}] + set denominator [expr {$denominator * (2 * $i + 1)}] + incr numerator $denominator + } + return [list [expr {$numerator * 2}] $denominator] + } + proc fraction_iteration_test {max} { + variable pifrac + set pi 3.$pifrac + set k 0 + set result "" + set last_lcplen 0 + set got "" + package require math::bigfloat + while {$k <= $max} { + set s [fraction_iteration $k] + lassign $s a b + #set answer [expr {$a / double($b)}] ;limited range + set bigfloat [math::bigfloat::div [math::bigfloat::int2float $a] [math::bigfloat::int2float $b]] + set answer [math::bigfloat::tostr $bigfloat] + + + set lcp [punk::lib::longestCommonPrefix [list $pi $answer]] + set lcplen [string length $lcp] + if {$lcplen > $last_lcplen} { + set last_lcplen $lcplen + set got [string index $lcp end] + set c red + } else { + set c yellow + } + + set tail [string range $answer $lcplen end] + set greenanswer [a+ green]$lcp[a]$tail + #math::numtheory::gcd + #set gcd [punk::lib::gcd {*}$s] + #if {$gcd > 1} { + # set a [expr {$a/$gcd}] + # set b [expr {$b/$gcd}] + #} + + set ax [string map [list $got [a+ $c]$got[a]] $a] + set bx [string map [list $got [a+ $c]$got[a]] $b] + set m [expr {$a % $b}] + set mx [string map [list $got [a+ $c]$got[a]] $m] + + package require overtype + set sp40 [string repeat " " 40] + set sp60 [string repeat " " 60] + append result "[format %1s $got] [format %3s $k]-> [overtype::left $sp40 $greenanswer] [overtype::left $sp60 $ax] [overtype::left $sp60 $bx] [overtype::left $sp60 $mx]" \n + incr k + } + return $result + } + + #an experiment + proc slow_approx {{m 1000}} { + set pi 0 + set d [expr {1.0}] + for {set i 1} {$i <= $m} {incr i} { + set a [expr {2 * ($i % 2) - 1}] + set pi [expr {$pi + ($a * 4 / $d)}] + set d [expr {$d + 2.0}] + } + return $pi + } + + + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace picalc ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval picalc::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace picalc::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 picalc::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval picalc::system { + #*** !doctools + #[subsection {Namespace picalc::system}] + #[para] Internal functions that are not part of the API + + + +#} + + +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval picalc { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "(package)picalc" + @package -name "picalc" -help\ + "Package + Description" + }] + + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return picalc + } + 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 picalc + experiments in calculating pi in Tcl + } \n] + } + proc get_topic_License {} { + return "MIT" + } + proc get_topic_Version {} { + return "$::picalc::version" + } + proc get_topic_Contributors {} { + set authors {} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_notes {} { + punk::args::lib::tstr -return string { + A playground for evaluating performance and testing methods to calculate + the digits pi in Tcl. + + A precalculated value of enough precision for almost any + usecase is available at $::math::constants::pi after loading + the math::constants package. + + Note that this package is focused on calculating the digits of pi so + there is no rounding of the final digit. + + For large values of pi using the mathematical concept of 'precision' + rather than decimal places - consider math::bigfloat::pi + } + } + # ------------------------------------------------------------- + } + + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::picalc::about" + dict set overrides @cmd -name "picalc::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + Experiments in calculating the digits of pi + }] \n] + dict set overrides topic -choices [list {*}[picalc::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [picalc::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 ::picalc::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::picalc::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 ::picalc +} +# ----------------------------------------------------------------------------- + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide picalc [tcl::namespace::eval picalc { + variable pkg picalc + variable version + set version 0.1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index a53ea000..11d247a7 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -1,4 +1,4 @@ -#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. +#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. #Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into. @@ -6,8 +6,8 @@ namespace eval punk { proc lazyload {pkg} { package require zzzload if {[package provide $pkg] eq ""} { - zzzload::pkg_require $pkg - } + zzzload::pkg_require $pkg + } } #lazyload twapi ? @@ -50,9 +50,9 @@ namespace eval punk { } - proc ::punk::auto_execok_original name [info body ::auto_execok] + proc ::punk::auto_execok_original name [info body ::auto_execok] variable better_autoexec - + #set better_autoexec 0 ;#use this var via better_autoexec only #proc ::punk::auto_execok_windows name { # ::punk::auto_execok_original $name @@ -178,7 +178,7 @@ namespace eval punk { continue } set checked($dir) {} - + foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { set file [file join $dir $match] if {[file exists $file] && ![file isdirectory $file]} { @@ -209,7 +209,7 @@ namespace eval punk { #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed - + #winget is installed on all modern windows and is an example of the problem this addresses @@ -223,9 +223,9 @@ namespace eval punk { upvar ::punk::can_exec_windowsapp can_exec_windowsapp upvar ::punk::windowsappdir windowsappdir upvar ::punk::cmdexedir cmdexedir - + if {$windowsappdir eq ""} { - #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' #Tcl (2025) can't exec when given a path to these 0KB files #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps if {!([info exists ::env(LOCALAPPDATA)] && @@ -261,13 +261,13 @@ namespace eval punk { return [file join $windowsappdir $name] } if {$cmdexedir eq ""} { - #cmd.exe very unlikely to move + #cmd.exe very unlikely to move set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index - #anyway.. it has other side effects (affects auto_load) + #anyway.. it has other side effects (affects auto_load) } return "[file join $cmdexedir cmd.exe] /c $name" - } + } return $default_auto }] @@ -279,9 +279,9 @@ namespace eval punk { #repltelemetry cooperation with other packages such as shellrun -#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists +#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists namespace eval punk { - variable repltelemetry_emmitters + variable repltelemetry_emmitters #don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early if {![info exists repltelemetry_emitters]} { set repltelemetry_emmitters [list] @@ -376,7 +376,7 @@ if {![llength [info commands ::ansistring]]} { package require punk::aliascore ;#mostly punk::lib aliases punk::aliascore::init -force 1 -package require punk::repl::codethread +package require punk::repl::codethread package require punk::config #package require textblock package require punk::console ;#requires Thread @@ -385,7 +385,7 @@ package require punk::winpath ;# for windows paths - but has functions that can package require punk::repo package require punk::du package require punk::mix::base -package require base64 +package require base64 package require punk::pipe @@ -418,7 +418,7 @@ namespace eval punk { package require shellfilter package require punkapp package require funcl - + package require struct::list package require fileutil #package require punk::lib @@ -438,8 +438,8 @@ namespace eval punk { #----------------------------------- # todo - load initial debug state from config debug off punk.unknown - debug level punk.unknown 1 - debug off punk.pipe + debug level punk.unknown 1 + debug off punk.pipe debug level punk.pipe 4 debug off punk.pipe.var debug level punk.pipe.var 4 @@ -481,7 +481,7 @@ namespace eval punk { uplevel 1 [list set $varname $obj2] } - interp alias "" strlen "" ::punk::strlen + interp alias "" strlen "" ::punk::strlen interp alias "" str_len "" ::punk::strlen interp alias "" objclone "" ::punk::objclone #proc ::strlen {str} { @@ -571,8 +571,8 @@ namespace eval punk { @cmd -name "punk::get_runchunk" -help\ "experimental" @opts - -1 -optional 1 -type none - -2 -optional 1 -type none + -1 -optional 1 -type none + -2 -optional 1 -type none @values -min 0 -max 0 }] #todo - make this command run without truncating previous runchunks @@ -581,9 +581,9 @@ namespace eval punk { set sortlist [list] foreach cname $runchunks { set num [lindex [split $cname -] 1] - lappend sortlist [list $num $cname] + lappend sortlist [list $num $cname] } - set sorted [lsort -index 0 -integer $sortlist] + set sorted [lsort -index 0 -integer $sortlist] set chunkname [lindex $sorted end-1 1] set runlist [tsv::get repl $chunkname] #puts stderr "--$runlist" @@ -640,10 +640,10 @@ namespace eval punk { set inopts 1 } else { #leave loop at first nonoption - i should be index of file - break + break } } else { - #leave for next iteration to check + #leave for next iteration to check set inopts 0 } incr i @@ -659,7 +659,7 @@ namespace eval punk { set ::argc $argc return -code $code $return } - + @@ -672,9 +672,9 @@ namespace eval punk { error "can't read \"$vname\": no such variable" } set inf [shellfilter::list_element_info [list $v]] - set inf [dict get $inf 0] + set inf [dict get $inf 0] if {$flag eq "-v"} { - return $inf + return $inf } set output [dict create] @@ -750,7 +750,7 @@ namespace eval punk { } else { append token $c if {$c eq "("} { - set in_brackets 1 + set in_brackets 1 } } } @@ -779,7 +779,7 @@ namespace eval punk { set varlist [list] set var_terminals [list "@" "/" "#" "!"] #except when prefixed directly by pin classifier ^ - set protect_terminals [list "^"] ;# e.g sequence ^# + set protect_terminals [list "^"] ;# e.g sequence ^# #also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string #ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' set in_brackets 0 @@ -817,9 +817,9 @@ namespace eval punk { } else { append token $c if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { - set first_term $token_index + set first_term $token_index } elseif {$c eq "("} { - set in_brackets 1 + set in_brackets 1 } } } @@ -874,12 +874,12 @@ namespace eval punk { } else { if {$first_term == -1} { if {$c in $var_terminals} { - set first_term $token_index + set first_term $token_index } } append token $c if {$c eq "("} { - set in_brackets 1 + set in_brackets 1 } } } @@ -900,7 +900,7 @@ namespace eval punk { proc fp_restructure {selector data} { if {$selector eq ""} { fun=.= {val $input} 0 || abs($offset) >= $len)} { set action ?mismatch-list-index-out-of-range break @@ -1257,7 +1257,7 @@ namespace eval punk { } elseif {$start eq "end"} { #ok } elseif {$do_bounds_check} { - set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [string range $start 3 end] ;#include the - from end- set startoffset [expr $startoffset] ;#don't brace! if {$startoffset > 0 || abs($startoffset) >= $len} { set action ?mismatch-list-index-out-of-range @@ -1314,7 +1314,7 @@ namespace eval punk { } else { error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } - + } else { #keyword 'pipesyntax' at beginning of error message error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] @@ -1346,16 +1346,16 @@ namespace eval punk { return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] } - #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script + #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script proc destructure_func {selector data} { #puts stderr ".d." set selector [string trim $selector /] - #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position - #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position + #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position - #map some problematic things out of the way in a manner that maintains some transparency - #e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]} - #The selector forms part of the proc name + #map some problematic things out of the way in a manner that maintains some transparency + #e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]} + #The selector forms part of the proc name #review - compare with pipecmd_namemapping set selector_safe [string map [list\ ? \ @@ -1373,13 +1373,13 @@ namespace eval punk { \t \ \n \ \r \ - ] $selector] + ] $selector] set cmdname ::punk::pipecmds::destructure::_$selector_safe if {[info commands $cmdname] ne ""} { return [$cmdname $data] ;# note upvar 2 for stateful v_list_idx to be resolved in _multi_bind_result context } - + set leveldata $data set body [destructure_func_build_procbody $cmdname $selector $data] @@ -1403,8 +1403,8 @@ namespace eval punk { proc destructure_func_build_procbody {cmdname selector data} { set script "" #place selector in comment in script only - if there is an error in selector we pick it up when building the script. - #The script itself should only be returning errors in its action key of the result dictionary - append script \n [string map [list $selector] {# set selector {}}] + #The script itself should only be returning errors in its action key of the result dictionary + append script \n [string map [list $selector] {# set selector {}}] set subindices [split $selector /] append script \n [string map [list [list $subindices]] {# set subindices }] set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch- and always break @@ -1412,7 +1412,7 @@ namespace eval punk { #append script \n {set assigned ""} ;#review set active_key_type "" append script \n {# set active_key_type ""} - set lhs "" + set lhs "" #append script \n [tstr {set lhs ${{$lhs}}}] append script \n {set lhs ""} set rhs "" @@ -1432,9 +1432,9 @@ namespace eval punk { #dict 'index' when using stateful @@ etc to iterate over dict instead of by key set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} - - if {![string length $selector]} { + + if {![string length $selector]} { #just return $leveldata set script { dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata @@ -1448,7 +1448,7 @@ namespace eval punk { #pure numeric keylist - put straight to lindex # #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ - #We will leave this as a syntax for different (more performant) behaviour + #We will leave this as a syntax for different (more performant) behaviour #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. #TODO - review and/or document # @@ -1475,7 +1475,7 @@ namespace eval punk { # -- --- --- } if {[string match @@* $selector]} { - #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc + #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@' set keypath [string range $selector 2 end] set keylist [split $keypath /] @@ -1509,11 +1509,11 @@ namespace eval punk { foreach index $subindices { #set index_operation "unspecified" set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script - set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] + set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] append script \n "# ------- START index:$index subpath:$SUBPATH ------" set lhs $index append script \n "set lhs {$index}" - + set assigned "" append script \n {set assigned ""} @@ -1527,21 +1527,21 @@ namespace eval punk { # do_bounds_check shouldn't need to be in script set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. - #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. #append script \n {set do_boundscheck 0} switch -exact -- $index { # - @# { #list length set active_key_type "list" if {$get_not} { - lappend INDEX_OPERATIONS not-list + lappend INDEX_OPERATIONS not-list append script \n {# set active_key_type "list" index_operation: not-list} append script \n { if {[catch {llength $leveldata}]} { - #not a list - not-length is true + #not a list - not-length is true set assigned 1 } else { - #is a list - not-length is false + #is a list - not-length is false set assigned 0 } } @@ -1560,7 +1560,7 @@ namespace eval punk { #dict size set active_key_type "dict" if {$get_not} { - lappend INDEX_OPERATIONS not-dict + lappend INDEX_OPERATIONS not-dict append script \n {# set active_key_type "dict" index_operation: not-dict} append script \n { if {[catch {dict size $leveldata}]} { @@ -1583,10 +1583,10 @@ namespace eval punk { } %# { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%# not string length is not supported" } - #string length - REVIEW - + #string length - REVIEW - lappend INDEX_OPERATIONS string-length append script \n {# set active_key_type "" index_operation: string-length} append script \n {set assigned [string length $leveldata]} @@ -1595,10 +1595,10 @@ namespace eval punk { %%# { #experimental set active_key_type "string" - if $get_not { + if {$get_not} { error "!%%# not string length is not supported" } - #string length - REVIEW - + #string length - REVIEW - lappend INDEX_OPERATIONS ansistring-length append script \n {# set active_key_type "" index_operation: ansistring-length} append script \n {set assigned [ansistring length $leveldata]} @@ -1606,7 +1606,7 @@ namespace eval punk { } %str { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%str - not string-get is not supported" } lappend INDEX_OPERATIONS string-get @@ -1617,7 +1617,7 @@ namespace eval punk { %sp { #experimental set active_key_type "string" - if $get_not { + if {$get_not} { error "!%sp - not string-space is not supported" } lappend INDEX_OPERATIONS string-space @@ -1628,7 +1628,7 @@ namespace eval punk { %empty { #experimental set active_key_type "string" - if $get_not { + if {$get_not} { error "!%empty - not string-empty is not supported" } lappend INDEX_OPERATIONS string-empty @@ -1638,10 +1638,10 @@ namespace eval punk { } @words { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%words - not list-words-from-string is not supported" } - lappend INDEX_OPERATIONS list-words-from-string + lappend INDEX_OPERATIONS list-words-from-string append script \n {# set active_key_type "" index_operation: list-words-from-string} append script \n {set assigned [regexp -inline -all {\S+} $leveldata]} set level_script_complete 1 @@ -1650,10 +1650,10 @@ namespace eval punk { #experimental - leading character based on result not input(?) #input type is string - but output is list set active_key_type "list" - if $get_not { + if {$get_not} { error "!%chars - not list-chars-from-string is not supported" } - lappend INDEX_OPERATIONS list-from_chars + lappend INDEX_OPERATIONS list-from_chars append script \n {# set active_key_type "" index_operation: list-chars-from-string} append script \n {set assigned [split $leveldata ""]} set level_script_complete 1 @@ -1662,7 +1662,7 @@ namespace eval punk { #experimental - flatten one level of list #join without arg - output is list set active_key_type "string" - if $get_not { + if {$get_not} { error "!@join - not list-join-list is not supported" } lappend INDEX_OPERATIONS list-join-list @@ -1674,7 +1674,7 @@ namespace eval punk { #experimental #input type is list - but output is string set active_key_type "string" - if $get_not { + if {$get_not} { error "!%join - not string-join-list is not supported" } lappend INDEX_OPERATIONS string-join-list @@ -1684,7 +1684,7 @@ namespace eval punk { } %ansiview { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%# not string-ansiview is not supported" } lappend INDEX_OPERATIONS string-ansiview @@ -1694,7 +1694,7 @@ namespace eval punk { } %ansiviewstyle { set active_key_type "string" - if $get_not { + if {$get_not} { error "!%# not string-ansiviewstyle is not supported" } lappend INDEX_OPERATIONS string-ansiviewstyle @@ -1705,23 +1705,23 @@ namespace eval punk { @ { #as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next) #This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2 - + #append script \n {puts stderr [uplevel 1 [list info vars]]} #NOTE: #v_list_idx in context of _multi_bind_result - #we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run) + #we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run) append script \n {upvar 2 v_list_idx v_list_idx} set active_key_type "list" append script \n {# set active_key_type "list" index_operation: list-get-next} #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 - #while x@,y@.= is reasonably handy - especially for args e.g $listmsg] {set listmsg ""}] - + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against @@ -2395,7 +2395,7 @@ namespace eval punk { ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} } else { #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax - ${$assignment_script} + ${$assignment_script} } }] } @@ -2419,7 +2419,7 @@ namespace eval punk { #set action ?mismatch-list-index-out-of-range ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} } else { - ${$assignment_script} + ${$assignment_script} } }] } else { @@ -2428,13 +2428,13 @@ namespace eval punk { #set action ?mismatch-not-a-list ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } else { - ${$assignment_script} + ${$assignment_script} } }] } } tail { - #NOTE: /@tail and /tail both do bounds check. This is intentional. + #NOTE: /@tail and /tail both do bounds check. This is intentional. # #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. @@ -2447,7 +2447,7 @@ namespace eval punk { append script \n "# index_operation listindex-tail" \n lappend INDEX_OPERATIONS listindex-tail set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero} - } + } append script \n [tstr -return string -allowcommands { if {[catch {llength $leveldata} len]} { #set action ?mismatch-not-a-list @@ -2544,7 +2544,7 @@ namespace eval punk { } raw { #get_not - return nothing?? - #no list checking.. + #no list checking.. if {$get_not} { lappend INDEX_OPERATIONS getraw-not append script \n {set assigned {}} @@ -2599,7 +2599,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS list-getpairs } - append script \n [tstr -return string -allowcommands { + append script \n [tstr -return string -allowcommands { if {[catch {dict size $leveldata} dsize]} { #set action ?mismatch-not-a-dict ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} @@ -2627,7 +2627,7 @@ namespace eval punk { if {[catch {llength $leveldata} len]} { ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } else { - ${$assign_script} + ${$assign_script} } }] } elseif {[string is integer -strict $index]} { @@ -2667,7 +2667,7 @@ namespace eval punk { #set action ?mismatch-not-a-list ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } else { - ${$assign_script} + ${$assign_script} } }] } @@ -2698,7 +2698,7 @@ namespace eval punk { #set action ?mismatch-list-index-out-of-range ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} } else { - ${$assign_script} + ${$assign_script} } } }] @@ -2708,7 +2708,7 @@ namespace eval punk { #set action ?mismatch-not-a-list ${[tstr -ret string $tpl_return_mismatch_not_a_list]} } else { - ${$assign_script} + ${$assign_script} } }] } @@ -2747,15 +2747,15 @@ namespace eval punk { } elseif {$start eq "end"} { #noop } else { - set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [string range $start 3 end] ;#include the - from end- set startoffset [expr $startoffset] ;#don't brace! if {$startoffset > 0} { #e.g end+1 error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] } - append script \n [tstr -return string -allowcommands { - set startoffset ${$startoffset} + append script \n [tstr -return string -allowcommands { + set startoffset ${$startoffset} if {abs($startoffset) >= $len} { #set action ?mismatch-list-index-out-of-range ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} @@ -2767,7 +2767,7 @@ namespace eval punk { error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] } append script \n [tstr -return string -allowcommands { - set end ${$end} + set end ${$end} if {$end+1 > $len} { #set action ?mismatch-list-index-out-of-range ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} @@ -2783,7 +2783,7 @@ namespace eval punk { error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] } append script \n [tstr -return string -allowcommands { - set endoffset ${$endoffset} + set endoffset ${$endoffset} if {abs($endoffset) >= $len} { #set action ?mismatch-list-index-out-of-range ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} @@ -2865,13 +2865,13 @@ namespace eval punk { } else { error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] } - + append script \n [string map [list $assign_script] { if {![string match ?mismatch-* $action]} { } }] - + } else { #keyword 'pipesyntax' at beginning of error message #pipesyntax error - no need to even build script - can fail now @@ -2923,7 +2923,7 @@ namespace eval punk { #dict remove can accept non-existent keys.. review do we require not-@?@key to get silence? append script \n [tstr -return string { set assigned [dict remove $leveldata ${$index}] - }] + }] } else { append script \n [tstr -return string -allowcommands { # set active_key_type "dict" @@ -2947,7 +2947,7 @@ namespace eval punk { } incr i_keyindex append script \n "# ------- END index $index ------" - } ;# end foreach + } ;# end foreach @@ -2969,11 +2969,11 @@ namespace eval punk { #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) #e.g x,x@0 will only match a single element list - #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) + #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) # non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline proc _multi_bind_result {multivar data args} { #puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$args'" - #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 + #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 if {![string length $multivar]} { #treat the absence of a pattern as a match to anything #JMN2 - changed to list based destructuring @@ -3003,7 +3003,7 @@ namespace eval punk { set expected_values [list] #e.g {a = abc} {b set ""} foreach classinfo $var_class vname $var_names { - lassign [lindex $classinfo 0] v + lassign [lindex $classinfo 0] v lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default } @@ -3014,7 +3014,7 @@ namespace eval punk { #puts stdout "\n var_class: $var_class\n" # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} - + #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" @@ -3029,18 +3029,18 @@ namespace eval punk { #member lists of returndict which will be appended to in the initial value-retrieving loop set returndict_setvars [dict get $returndict setvars] - + set assigned_values [list] #varname action value - where value is value to be set if action is set - #actions: + #actions: # "" unconfigured - assert none remain unconfigured at end # noop no-change # matchvar-set name is a var to be matched # matchatom-set names is an atom to be matched # matchglob-set - # set + # set # question mark versions are temporary - awaiting a check of action vs var_class # e.g ?set may be changed to matchvar or matchatom or set @@ -3055,7 +3055,7 @@ namespace eval punk { # ^var means a pinned variable - compare value of $var to rhs - don't assign # # In this loop we don't set variables - but assign an action entry in var_actions - all with leading question mark. - # as well as adding the data values to the var_actions list + # as well as adding the data values to the var_actions list # # TODO! we may (commonly) encounter same vkey in the pattern - no need to reparse and re-fetch from data! set vkeys_seen [list] @@ -3096,8 +3096,8 @@ namespace eval punk { dict set returndict setvars $returndict_setvars #assigned_values is the ordered list of source elements in the data (rhs) as extracted by each position-spec - #For booleans the final val may later be normalised to 0 or 1 - + #For booleans the final val may later be normalised to 0 or 1 + #assertion all var_actions were set with leading question mark #perform assignments only if matched ok @@ -3124,7 +3124,7 @@ namespace eval punk { debug.punk.pipe.var {vars: [lsearch -all -inline -index 1 $var_class 6]} 5 debug.punk.pipe.var {globs: [lsearch -all -inline -index 1 $var_class 7]} 5 } - + set match_state [lrepeat [llength $var_names] ?] unset -nocomplain v unset -nocomplain nm @@ -3145,7 +3145,7 @@ namespace eval punk { set class_key [lindex $var_class $i 1] - lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan + lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan foreach ck $class_key { switch -- $ck { 1 {set isatom 1} @@ -3173,7 +3173,7 @@ namespace eval punk { ##marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? #set isgreaterthan [expr {9 in $class_key}] #set islessthan [expr {10 in $class_key}] - + if {$isatom} { @@ -3202,7 +3202,7 @@ namespace eval punk { # - setting expected_values when match_state is set to 0 is ok except for performance - #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or + #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or #ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling) if {$ispin} { #puts stdout "==>ispin $lhsspec" @@ -3212,7 +3212,7 @@ namespace eval punk { upvar $lvlup $varname the_var #if {![catch {uplevel $lvlup [list ::set $varname]} existingval]} {} if {![catch {set the_var} existingval]} { - + if {$isbool} { #isbool due to 2nd classifier i.e ^& lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val] @@ -3222,7 +3222,7 @@ namespace eval punk { #isglob due to 2nd classifier ^* lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val] } elseif {$isnumeric} { - #flagged as numeric by user using ^# classifiers + #flagged as numeric by user using ^# classifiers set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) if {[string is integer -strict $testexistingval]} { set isint 1 @@ -3233,10 +3233,10 @@ namespace eval punk { set isdouble 1 #doubles comparisons use float_almost_equal - so lhs can differ from rhs - for pins we always want to return the normalised lhs ie exactly what is in the var lset assigned_values $i $existingval - + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val] } else { - #user's variable doesn't seem to have a numeric value + #user's variable doesn't seem to have a numeric value lset match_state $i 0 lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val] break @@ -3261,7 +3261,7 @@ namespace eval punk { lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] break } - } + } } @@ -3283,7 +3283,7 @@ namespace eval punk { if {[string index $lhs 0] eq "."} { set testlhs $lhs } else { - set testlhs [join [scan $lhs %lld%s] ""] + set testlhs [join [scan $lhs %lld%s] ""] } if {[string index $val 0] eq "."} { set testval $val @@ -3348,10 +3348,10 @@ namespace eval punk { } } elseif {[string is digit -strict [string trim $val -]] } { #probably a wideint or bignum with no decimal point - #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . + #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . #if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end. - #2 values further apart can compare equal while int-like ones closer together can compare different. - #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. + #2 values further apart can compare equal while int-like ones closer together can compare different. + #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. #This is basically what we're doing here but with an arguably better (for some purposes!) float comparison. #string comparison can presumably always be used as an alternative. # @@ -3409,7 +3409,7 @@ namespace eval punk { } } } else { - #e.g rhs not a number.. + #e.g rhs not a number.. if {$testlhs == $testval} { lset match_state $i 1 } else { @@ -3421,7 +3421,7 @@ namespace eval punk { } elseif {$isdouble} { #dragons (and shimmering) # - # + # if {$ispin} { set existing_expected [lindex $expected_values $i] set lhs [dict get $existing_expected lhs] @@ -3489,7 +3489,7 @@ namespace eval punk { set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix if {![string length $lhs]} { - #empty varname - ok + #empty varname - ok if {[string is boolean -strict $val] || [string is double -strict $val]} { lset match_state $i 1 lset var_actions $i 1 "return-normalised-value" @@ -3513,7 +3513,7 @@ namespace eval punk { set tclvar $lhs if {[string is double $tclvar]} { error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar] - #proc _multi_bind_result {multivar data args} + #proc _multi_bind_result {multivar data args} } #treat as variable - need to check cross-binding within this pattern group set first_bound [lsearch -index 0 $var_actions $lhsspec] @@ -3580,11 +3580,11 @@ namespace eval punk { } } elseif {$ispin} { - #handled above.. leave case in place so we don't run else for pins + #handled above.. leave case in place so we don't run else for pins } else { #puts stdout "==> $lhsspec" - #NOTE - pinned var of same name is independent! + #NOTE - pinned var of same name is independent! #ie ^x shouldn't look at earlier x bindings in same pattern #unpinned non-atoms #cross-binding. Within this multivar pattern group only (use pin ^ for binding to result from a previous pattern) @@ -3604,7 +3604,7 @@ namespace eval punk { } default { set first_bound [lsearch -index 0 $var_actions $varname] - #assertion first_bound >=0, we will always find something - usually self + #assertion first_bound >=0, we will always find something - usually self if {$first_bound == $i} { lset match_state $i 1 lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set @@ -3664,7 +3664,7 @@ namespace eval punk { if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { #isvar if {[lindex $var_actions $i 1] eq "set"} { - upvar $lvlup $varname the_var + upvar $lvlup $varname the_var set the_var [lindex $var_actions $i 2] } } @@ -3676,7 +3676,7 @@ namespace eval punk { # if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { # #isvar # lassign $va lhsspec act val - # upvar $lvlup $varname the_var + # upvar $lvlup $varname the_var # if {$act eq "set"} { # set the_var $val # } @@ -3690,7 +3690,8 @@ namespace eval punk { #todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message #e.g for within pipeswitch block where mismatches are expected and the reasons are less important than moving on quickly set vidx 0 - set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] + #set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] + set mismatches [lmap m $match_state v $var_names {expr {$m == 0 ? [list mismatch $v] : [list match $v]}}] set var_display_names [list] foreach v $var_names { if {$v eq ""} { @@ -3699,7 +3700,9 @@ namespace eval punk { lappend var_display_names $v } } - set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}] + #REVIEW 2025 + #set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}] + set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0 ? $v : [expr {$m eq "?" ? "?[string repeat { } [expr {[string length $v] -1}]]" : [string repeat " " [string length $v]] }]}}] set msg "\n" append msg "Unmatched\n" append msg "Cannot match right hand side to pattern $multivar\n" @@ -3715,12 +3718,12 @@ namespace eval punk { #6 - var #7 - glob (no classifier and contains * or ?) foreach mismatchinfo $mismatches { - lassign $mismatchinfo status varname + lassign $mismatchinfo status varname if {$status eq "mismatch"} { # varname can be empty string set varclass [lindex $var_class $i 1] set val [lindex $var_actions $i 2] - set e [dict get [lindex $expected_values $i] lhs] + set e [dict get [lindex $expected_values $i] lhs] set type "" if {2 in $varclass} { append type "pinned " @@ -3798,7 +3801,7 @@ namespace eval punk { return [dict get $d result] } } - # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch + # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch proc _handle_bind_result_experimental1 {d} { #set match_caller [info level 2] #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 @@ -3822,34 +3825,34 @@ namespace eval punk { upvar $pipevarname the_pipe set the_pipe $args } - + #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::objclone $args] set nscaller [uplevel 1 [list namespace current]] - tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] + tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] } proc pipealias_extract {targetcmd} { set applybody [lindex [interp alias "" $targetcmd] 1 1] #strip off trailing " {*}$args" - return [lrange [string range $applybody 0 end-9] 0 end] + return [lrange [string range $applybody 0 end-9] 0 end] } #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::objclone $args] + set cmdcopy [punk::objclone $args] set nscaller [uplevel 1 [list namespace current]] tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] } #same as used in unknown func for initial launch - #variable re_assign {^([^\r\n=\{]*)=(.*)} - #variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} variable re_assign {^([^ \t\r\n=\{]*)=(.*)} variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} #match_assign is tailcalled from unknown - uplevel 1 gets to caller level proc match_assign {scopepattern equalsrhs args} { - #review - :: is legal in atoms! + #review - :: is legal in atoms! if {[string match "*::*" $scopepattern]} { error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid." } @@ -3858,7 +3861,7 @@ namespace eval punk { set cmdns ::punk::pipecmds set namemapping [punk::pipe::lib::pipecmd_namemapping $equalsrhs] - #we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW + #we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW #(we need for example x*= to be available as is via namespace path mechanism (from punk::pipecmds namespace)) set pipecmd ${cmdns}::$scopepattern=$namemapping @@ -3877,10 +3880,10 @@ namespace eval punk { #NOTE: #we need to ensure for case: - #= x=y + #= x=y #that the second arg is treated as a raw value - never a pipeline command - #equalsrhs is set if there is a segment-insertion-pattern *directly* after the = + #equalsrhs is set if there is a segment-insertion-pattern *directly* after the = #debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 #can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data. @@ -3890,7 +3893,7 @@ namespace eval punk { # in our script's handling of args: #avoid use of regexp match on each element - or we will unnecessarily force string reps on lists - #same with lsearch with a string pattern - + #same with lsearch with a string pattern - #wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps set script [string map [list $scopepattern $equalsrhs] { #script built by punk::match_assign @@ -3898,7 +3901,7 @@ namespace eval punk { #scan for existence of any pipe operator (|*> or <*|) only - we don't need position #all pipe operators must be a single element #we don't first check llength args == 1 because for example: - # x= <| + # x= <| # x= |> #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) foreach a $args { @@ -3931,10 +3934,10 @@ namespace eval punk { #we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok" # x='ok'>0/0 data # => {ok data} - # we won't examine for vars as there is no pipeline - ignore + # we won't examine for vars as there is no pipeline - ignore # also ignore trailing * (indicator for variable data to be expanded or not - ie {*}) # we will differentiate between / and @ in the same way that general pattern matching works. - # /x will simply call linsert without reference to length of list + # /x will simply call linsert without reference to length of list # @x will check for out of bounds # # !TODO - sort by position lowest to highest? or just require user to order the pattern correctly? @@ -3947,7 +3950,7 @@ namespace eval punk { #Here, we are not assigning to v1 - but matching the index spec /0 with the data from v1 #ie Y is inserted at position 0 to get A Y #(Note the difference from lhs) - #on lhs v1/1= {X Y} + #on lhs v1/1= {X Y} #would pattern match against the *data* A B and set v1 to B #in this point of an assign (= as opposed to .=) IF we have already determined there is no trailing pipeline @@ -3956,10 +3959,10 @@ namespace eval punk { #eg out= list a $callervar c #or alternatively use .= instead # - #HOWEVER - we need to build/compile a script that could then have further pipeline elements supplied as arguments + #HOWEVER - we need to build/compile a script that could then have further pipeline elements supplied as arguments #At the moment - this is handled in the script above by diverting to punk::pipeline to handle #The only vars/data we can possibly have to insert, come from the ] }] - set needs_insertion 0 + set needs_insertion 0 } if {$needs_insertion} { set script2 [punk::list_insertion_script $positionspec segmenttail ] set script2 [string map [list "\$insertion_data" ] $script2] append script $script2 - } + } + - } } - if {![string length $scopepattern]} { + if {![string length $scopepattern]} { append script { return $segmenttail } } else { append script [string map [list $scopepattern] { #we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail - set d [punk::_multi_bind_result {} $segmenttail] + set d [punk::_multi_bind_result {} $segmenttail] #return [punk::_handle_bind_result $d] - #maintenance: inlined + #maintenance: inlined if {![dict exists $d result]} { #uplevel 1 [list error [dict get $d mismatch]] #error [dict get $d mismatch] @@ -4044,7 +4047,7 @@ namespace eval punk { tailcall $pipecmd {*}$args } - #return a script for inserting data into listvar + #return a script for inserting data into listvar #review - needs updating for list-return semantics of patterns? proc list_insertion_script {keyspec listvar {data }} { set positionspec [string trimright $keyspec "*"] @@ -4072,15 +4075,15 @@ namespace eval punk { } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { if {$ptype eq "@"} { #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) - if {$isint} { + if {$isint} { append script [string map [list $listvar $index] { if {( > [llength $])} { - #not a pipesyntax error + #not a pipesyntax error error "pipedata insertionpattern index out of bounds. index: vs len: [llength $] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds] } }] } - #todo check end-x bounds? + #todo check end-x bounds? } if {$isint} { append script [string map [list $listvar $index $exp $data] { @@ -4143,10 +4146,10 @@ namespace eval punk { }] } - + } else { error "pipesyntax error in segment - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)4" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] - } + } return $script } @@ -4156,7 +4159,7 @@ namespace eval punk { proc _is_math_func_prefix {e1} { #also catch starting brackets.. e.g "(min(4,$x) " if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { - #possible math func + #possible math func if {$word in [info functions]} { return true } @@ -4193,8 +4196,8 @@ namespace eval punk { #puts "PERCENTS : $percents" set sequences [list] set in_sequence 0 - set start -1 - set end -1 + set start -1 + set end -1 set i 0 #todo - some more functional way of zipping/comparing these lists? set s_length 0 ;#sequence length including % symbols - minimum for tag therefore 2 @@ -4211,7 +4214,7 @@ namespace eval punk { } else { if {$n ^ $p} { incr s_length - incr end + incr end } else { if {$n & $p} { if {$s_length == 1} { @@ -4222,7 +4225,7 @@ namespace eval punk { set start $i set end $i } else { - incr end + incr end lappend sequences [list $start $end] set in_sequence 0 set s_length 0 @@ -4262,8 +4265,8 @@ namespace eval punk { # -- #consider possible tilde templating version ~= vs .= - #support ~ and ~* placeholders only. - #e.g x~= list aa b c |> lmap v ~ {string length $v} |> tcl::mathfunc::max ~* + #support ~ and ~* placeholders only. + #e.g x~= list aa b c |> lmap v ~ {string length $v} |> tcl::mathfunc::max ~* #The ~ being mapped to $data in the pipeline. #This is more readable and simpler for beginners - although it doesn't handle more advanced insertion requirements. #possibility to mix as we can already with .= and = @@ -4279,7 +4282,7 @@ namespace eval punk { #--------------------------------------------------------------------- # test if we have an initial x.=y.= or x.= y.= - + #nextail is tail for possible recursion based on first argument in the segment #set nexttail [lassign $fulltail next1] ;#tail head @@ -4315,9 +4318,9 @@ namespace eval punk { #The second element is always treated as a raw value - not a pipeline instruction. #whereas... for execution: #.= x=y the second element is a pipeline-significant symbol based on the '=' even if it was passed in as an argument. - #Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - + #Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - #- but if the pipeline is designed to put an argument in the zero position - then presumably it is intended as a pipeline-significant element anyway - #This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines + #This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines # if {$segment_op ne "="} { #handle for example: @@ -4337,7 +4340,7 @@ namespace eval punk { #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 #debug.punk.pipe {>>> results: $results} 1 return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] - } + } #puts "======> recurse assign based on next1:$next1 " #if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { #} @@ -4362,17 +4365,17 @@ namespace eval punk { set more_pipe_segments 1 ;#first loop #this contains the main %data% and %datalist% values going forward in the pipeline - #as well as any extra pipeline vars defined in each |> + #as well as any extra pipeline vars defined in each |> #It also contains any 'args' with names supplied in <| set dict_tagval [dict create] ;#cumulative %x% tag dict which operates on the whole length of the pipeline #determine if there are input args at the end of the pipeline indicated by reverse <| symbol possibly with argspecs e.g transform x y z 1} { error "pipedata = can only accept a single argument (got: '$segment_members')" "pipeline $segment_op $initial_returnvarspec $equalsrhs $fulltail" [list pipedata too_many_elements] - #proc pipeline {segment_op initial_returnvarspec equalsrhs args} + #proc pipeline {segment_op initial_returnvarspec equalsrhs args} } set segment_members $segment_first_word } - - #tailremaining includes x=y during the loop. + + #tailremaining includes x=y during the loop. set returnvarspec $initial_returnvarspec if {![llength $argslist]} { unset -nocomplain previous_result ;# we want it unset for first iteration - differentiate from empty string @@ -4475,8 +4478,8 @@ namespace eval punk { debug.punk.pipe {[a cyan bold] segment_first_is_script:$segment_first_is_script} 4 if {$segment_first_is_script} { debug.punk.pipe {[a cyan bold] script segment: [lindex $segment_members 0][a]} 4 - } - + } + #examine inpipespec early to give faster chance for mismatch. ie before scanning segment for argument position @@ -4488,12 +4491,12 @@ namespace eval punk { } set pipedvars [dict create] if {[string length $pipespec($i,in)]} { - #check the varspecs within the input piper + #check the varspecs within the input piper # - data and/or args may have been manipulated set d [apply {{mv res} { punk::_multi_bind_result $mv $res -levelup 1 }} $pipespec($i,in) $prevr] - #temp debug + #temp debug #if {[dict exists $d result]} { #set jjj [dict get $d result] #puts "!!!!! [rep $jjj]" @@ -4537,7 +4540,7 @@ namespace eval punk { foreach {vname val} $pipedvars { #add additionally specified vars and allow overriding of %args% and %data% by not setting them here if {$vname eq "data"} { - #already potentially overridden + #already potentially overridden continue } dict set dict_tagval $vname $val @@ -4553,7 +4556,7 @@ namespace eval punk { #add previous_result as data in end position by default, only if *no* insertions specified (data is just list-wrapped previous_result) #set segment_members_filled [concat $segment_members [dict get $dict_tagval %data%]] ;# data flows through by default as single element - not args - because some strings are not valid lists #insertion-specs with a trailing * can be used to insert data in args format - set segment_members_filled $segment_members + set segment_members_filled $segment_members if {[dict exists $dict_tagval data]} { lappend segment_members_filled [dict get $dict_tagval data] } @@ -4600,14 +4603,14 @@ namespace eval punk { } if {[dict exists $dict_tagval $v]} { set insertion_data [dict get $dict_tagval $v] - #todo - use destructure_func + #todo - use destructure_func set d [punk::_multi_bind_result $indexspec $insertion_data] set insertion_data [punk::_handle_bind_result $d] } else { #review - skip error if varname is 'data' ? #e.g we shouldn't really fail for: #.=>* list a b c <| - #??? Technically + #??? Technically #we need to be careful not to insert empty-list as an argument by default error "pipevariable - varname $v not present in pipeline context. pipecontext_vars: [dict keys $dict_tagval] (2)" " pipecontext_vars: [dict keys $dict_tagval]" [list pipevariable variable_not_in_pipeline_scope] } @@ -4642,9 +4645,9 @@ namespace eval punk { #set segment_members_filled $segmenttail #note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns) - + } - set rhs [string map $dict_tagval $rhs] ;#obsolete? + set rhs [string map $dict_tagval $rhs] ;#obsolete? debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 @@ -4653,8 +4656,8 @@ namespace eval punk { #we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) if {(!$segment_first_is_script ) && $segment_op eq ".="} { - #no scriptiness detected - + #no scriptiness detected + #debug.punk.pipe.rep {[a yellow bold][rep_listname segment_members_filled][a]} 4 set cmdlist_result [uplevel 1 $segment_members_filled] @@ -4663,25 +4666,25 @@ namespace eval punk { #set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result ]] 0]] - + set segment_result [_handle_bind_result $d] #puts stderr ">>forward_result: $forward_result segment_result $segment_result" } elseif {$segment_op eq "="} { - #slightly different semantics for assigment! - #We index into the DATA - not the position within the segment! + #slightly different semantics for assigment! + #We index into the DATA - not the position within the segment! #(an = segment must take a single argument, as opposed to a .= segment) #(This was a deliberate design choice for consistency with set, and to reduce errors.) #(we could have allowed multiple args to = e.g to form a list, but it was tried, and the edge-cases were unintuitive and prone to user error) #(The choice to restrict to single argument, but allow insertion and appending via insertion-specs is more explicit and reliable even though the insertion-specs operate differently to those of .=) # - #we have to ensure that for an empty segment - we don't append to the empty list, thus listifying the data - #v= {a b c} |> = + #we have to ensure that for an empty segment - we don't append to the empty list, thus listifying the data + #v= {a b c} |> = # must return: {a b c} not a b c # if {!$segment_has_insertions} { - set segment_members_filled $segment_members + set segment_members_filled $segment_members if {[dict exists $dict_tagval data]} { if {![llength $segment_members_filled]} { set segment_members_filled [dict get $dict_tagval data] @@ -4712,7 +4715,7 @@ namespace eval punk { lappend segmentargnames $k lappend segmentargvals $val } - + set argsdatalist $prevr ;#default is raw result as a list. May be overridden by an argspec within |> e.g |args@@key> or stripped if not a tcl list #puts "------> rep prevr argsdatalist: [rep $argsdatalist]" set add_argsdata 0 @@ -4799,7 +4802,7 @@ namespace eval punk { #It makes more sense and is ultimately more useful (and more easy to reason about) for the result of each assignment to be related only to the pre-pipe section #It may however make a good debug point #puts stderr "segment $i segment_result:$segment_result" - + debug.punk.pipe.rep {[rep_listname segment_result]} 3 @@ -4809,17 +4812,17 @@ namespace eval punk { #examine tailremaining. # either x x x |?> y y y ... # or just y y y - #we want the x side for next loop - + #we want the x side for next loop + #set up the conditions for the next loop - #|> x=y args + #|> x=y args # inpipespec - contents of previous piper |xxx> # outpipespec - empty or content of subsequent piper |xxx> - # previous_result + # previous_result # assignment (x=y) - set pipespec($j,in) $pipespec($i,out) + set pipespec($j,in) $pipespec($i,out) set outpipespec "" set tailmap "" set next_pipe_posn -1 @@ -4839,7 +4842,7 @@ namespace eval punk { if {[llength $tailremaining] || $next_pipe_posn >= 0} { if {$next_pipe_posn >=0} { - set next_all_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> for + set next_all_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> for set tailremaining [lrange $tailremaining $next_pipe_posn+1 end] } else { @@ -4874,7 +4877,7 @@ namespace eval punk { } elseif {[regexp {^([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { set segment_op "=" #never scripts - #must be at most a single element after the = ! + #must be at most a single element after the = ! if {[llength $next_all_members] > 2} { #raise this as pipesyntax as opposed to pipedata? error "pipesyntax - at most one element can follow = (got [lrange $next_all_members 1 end])" "pipeline $segment_op $returnvarspec $rhs [lrange $next_all_members 1 end]" [list pipesyntax too_many_elements] @@ -4885,7 +4888,7 @@ namespace eval punk { } else { set segment_is_list 1 ;#only used for segment_op = } - + set segment_members $segment_first_word } else { #no assignment operator and not script shaped @@ -4901,7 +4904,7 @@ namespace eval punk { } else { #?? two pipes in a row ? - debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 + debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 set segment_members return set segment_first_word return } @@ -4913,7 +4916,7 @@ namespace eval punk { } else { debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a]} 4 #output pipe spec at tail of pipeline - + set pipedvars [dict create] if {[string length $pipespec($i,out)]} { set d [apply {{mv res} { @@ -4926,7 +4929,7 @@ namespace eval punk { set more_pipe_segments 0 } - #the segment_result is based on the leftmost var on the lhs of the .= + #the segment_result is based on the leftmost var on the lhs of the .= #whereas forward_result is always the entire output of the segment #JMN2 #lappend segment_result_list [join $segment_result] @@ -4958,7 +4961,7 @@ namespace eval punk { } set s $posn } else { - #int + #int if {($start < 0) || ($start > ($datalen -1))} { return 0 } @@ -4974,7 +4977,7 @@ namespace eval punk { } set e $posn } else { - #int + #int if {($end < 0)} { return 0 } @@ -4992,7 +4995,7 @@ namespace eval punk { if {$e < $s} { return 0 } - + return [expr {$e - $s + 1}] } @@ -5145,11 +5148,11 @@ namespace eval punk { #windows experiment todo - use twapi and named pipes - #twapi::namedpipe_server {\\.\pipe\something} + #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 { @@ -5163,7 +5166,7 @@ namespace eval punk { #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 {[dict get $::punk::config::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 @@ -5172,16 +5175,16 @@ namespace eval punk { #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 + 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 + 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. + #no point returning "exitcode 0" if that's the only non-error return. #It is misleading. Better to return empty string. set ::tcl::UnknownResult "" } @@ -5191,10 +5194,10 @@ namespace eval punk { 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 + #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 + #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} { @@ -5291,7 +5294,7 @@ namespace eval punk { } } - + } return -code error -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name $name" @@ -5300,10 +5303,12 @@ namespace eval punk { proc know {cond body} { set existing [info body ::unknown] #assuming we can't test on cond being present in existing unknown script - because it may be fairly simple and prone to false positives (?) - ##This means we can't have 2 different conds with same body if we test for body in unknown. + ##This means we can't have 2 different conds with same body if we test for body in unknown. ##if {$body ni $existing} { set scr [base64::encode -maxlen 0 $cond] ;#will only be decoded if the debug is triggered #tcllib has some double-substitution going on.. base64 seems easiest and will not impact the speed of normal execution when debug off. + + #tclint-disable-next-line proc ::unknown {args} [string map [list @c@ $cond @b@ $body @scr@ $scr] { #--------------------------------------- if {![catch {expr {@c@}} res] && $res} { @@ -5359,7 +5364,7 @@ namespace eval punk { if {[info commands ::tsv::set] eq ""} { puts stderr "set_repl_last_unknown - tsv unavailable!" return - } + } tsv::set repl last_unknown {*}$args } # --------------------------- @@ -5368,26 +5373,27 @@ namespace eval punk { #for var="val {a b c}" #proc ::punk::val {{v {}}} {tailcall lindex $v} #proc ::punk::val {{v {}}} {return $v} ;#2023 - approx 2x faster than the tailcall lindex version + proc ::punk::val [list [list v [purelist]]] {return $v} #---------------- proc configure_unknown {} { #----------------------------- #these are critical e.g core behaviour or important for repl displaying output correctly - + #can't use know - because we don't want to return before original unknown body is called. proc ::unknown {args} [string cat { #set ::punk::last_run_display [list] #set ::repl::last_unknown [lindex $args 0] ;#jn #tsv::set repl last_unknown [lindex $args 0] ;#REVIEW - punk::set_repl_last_unknown [lindex $args 0] + punk::set_repl_last_unknown [lindex $args 0] }][info body ::unknown] #handle process return dict of form {exitcode num etc blah} #ie when the return result as a whole is treated as a command - #exitcode must be the first key + #exitcode must be the first key know {[lindex $args 0 0] eq "exitcode"} { uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] } @@ -5395,13 +5401,13 @@ namespace eval punk { #----------------------------- # - # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. - + # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + #todo - repl output info that it was evaluated as an expression #know {[expr $args] || 1} {expr $args} know {[expr $args] || 1} {tailcall expr $args} - #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc + #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) know {[regexp {^([+-]*[0-9_]+)\.\.([+-]*[0-9_]+)$} [lindex $args 0 0] -> from to]} {punk::lib::range $from $to} @@ -5420,14 +5426,14 @@ namespace eval punk { error "unknown_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $tail" } #regexp $punk::re_assign $hd _ pattern equalsrhs - #we assume the whole pipeline has been provided as the head + #we assume the whole pipeline has been provided as the head #regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail regexp {^([^\t\r\n=]*)\=([^\r\n]*)} $hd _ pattern fullrhs lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs tail } #NOTE: - it doesn't make sense to call 'namespace' qualifiers or 'namespace tail' on a compound hd such as v,::etc= blah # we only look at leftmost namespace-like thing and need to take account of the pattern syntax - # e.g for ::etc,'::x'= + # e.g for ::etc,'::x'= # the ns is :: and the tail is etc,'::x'= # (Tcl's namespace qualifiers/tail won't help here) if {[string match ::* $hd]} { @@ -5452,20 +5458,20 @@ namespace eval punk { puts stderr "unknown_assign_dispatch>> '$pattern=$equalsrhs' $commands nscaller: '$nscaller'" #we call the namespaced function - we don't evaluate it *in* the namespace. #REVIEW - #warn for now...? + #warn for now...? #tailcall $pattern=$equalsrhs {*}$args tailcall $pattern=$rhsmapped {*}$tail } } #puts "--->nscurrent [uplevel 1 [list ::namespace current]]" - #ignore the namespace.. + #ignore the namespace.. #We could interpret the fact that the nonexistant pipe was called with a namespace to indicate that's where the pipecommand should be created.. #But.. we would need to ensure 1st (compiling) invocation runs the same way as subsequent invocations. #namespace evaling match_assign here probably wouldn't accomplish that and may create surprises with regards to where lhs vars(if any) are created tailcall ::punk::match_assign $patterntail $equalsrhs {*}$tail #return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] } - #variable re_assign {^([^\r\n=\{]*)=(.*)} + #variable re_assign {^([^\r\n=\{]*)=(.*)} #characters directly following = need to be assigned to the var even if they are escaped whitespace (e.g \t \r \n) #unescaped whitespace causes the remaining elements to be part of the tail -ie are appended to the var as a list #e.g x=a\nb c @@ -5533,7 +5539,7 @@ namespace eval punk { error "unknown_dot_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $argstail" } #regexp $punk::re_assign $hd _ pattern equalsrhs - #we assume the whole pipeline has been provided as the head + #we assume the whole pipeline has been provided as the head #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail @@ -5559,8 +5565,8 @@ namespace eval punk { know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} #add escaping backslashes to a value - #matching odd keys in dicts using pipeline syntax can be tricky - as - #e.g + #matching odd keys in dicts using pipeline syntax can be tricky - as + #e.g #set ktest {a"b} #@@[escv $ktest].= list a"b val #without escv: @@ -5574,14 +5580,14 @@ namespace eval punk { #https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically #thanks to DKF regsub -all {\W} $v {\\&} - } + } interp alias {} escv {} punk::escv #review #set v "\u2767" # #escv $v #\ - #the + #the #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { @@ -5589,17 +5595,17 @@ namespace eval punk { # #set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! # #avoid using the return from expr and it works: # expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } - # + # # tailcall ::punk::match_exec $varspecs $rhs {*}$tail # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] #} } - configure_unknown + configure_unknown #if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwards. # - #main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc + #main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc #Should theoretically be slightly faster.. but pipelines are relatively slow until we can get pipeline compiling and optimisation. proc % {args} { set arglist [lassign $args assign] ;#tail, head @@ -5614,7 +5620,7 @@ namespace eval punk { if {!$is_script && [string index $assign end] eq "="} { #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} #set dumbeditor {\}} - #set re_equals {^([^ \t\r\n=\{]*)=$} + #set re_equals {^([^ \t\r\n=\{]*)=$} #set dumbeditor {\}} if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] @@ -5633,7 +5639,7 @@ namespace eval punk { tailcall {*}$cmdlist - #result-based mismatch detection can probably never work nicely.. + #result-based mismatch detection can probably never work nicely.. #we need out-of-band method to detect mismatch. Otherwise we can't match on mismatch results! # set result [uplevel 1 $cmdlist] @@ -5672,7 +5678,7 @@ namespace eval punk { } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} # set dumbeditor {\}} - #set re_equals {^([^ \t\r\n=\{]*)=$} + #set re_equals {^([^ \t\r\n=\{]*)=$} # set dumbeditor {\}} if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] @@ -5684,10 +5690,10 @@ namespace eval punk { } } else { set cmdlist $args - #script? + #script? #set cmdlist [list ::punk::pipeline .= "" "" {*}$args] } - + if {[catch {uplevel 1 $cmdlist} result erroptions]} { #puts stderr "pipematch erroptions:$erroptions" #debug.punk.pipe {pipematch error $result} 4 @@ -5777,7 +5783,7 @@ namespace eval punk { } } - #should only raise an error for pipe syntax errors - all other errors should be wrapped + #should only raise an error for pipe syntax errors - all other errors should be wrapped proc pipecase {args} { #debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 set arglist [lassign $args assign] @@ -5789,7 +5795,7 @@ namespace eval punk { } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} #set dumbeditor {\}} - #set re_equals {^([^ \t\r\n=\{]*)=$} + #set re_equals {^([^ \t\r\n=\{]*)=$} #set dumbeditor {\}} if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { @@ -5798,15 +5804,15 @@ namespace eval punk { set cmdlist [list $assign {*}$arglist] #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] } else { - error "pipesyntax pipecase unable to interpret pipeline '$args'" + error "pipesyntax pipecase unable to interpret pipeline '$args'" } #todo - account for insertion-specs e.g x=* x.=/0* } else { - #script? + #script? set cmdlist [list ::punk::pipeline .= "" "" {*}$args] } - + if {[catch {uplevel 1 [list ::if 1 $cmdlist]} result erroptions]} { #puts stderr "====>>> result: $result erroptions" set ecode [dict get $erroptions -errorcode] @@ -5849,14 +5855,14 @@ namespace eval punk { return [dict create error [dict create suppressed $result]] } default { - #normal tcl error + #normal tcl error #return [dict create error [dict create reason $result]] tailcall error $result "pipecase $args" [list caseerror] } } } } else { - tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] + tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] } } @@ -5870,7 +5876,7 @@ namespace eval punk { #unset args #upvar args upargs #set upargs $nextargs - upvar switchargs switchargs + upvar switchargs switchargs set switchargs $args uplevel 1 [::list ::if 1 $pipescript] } @@ -5880,7 +5886,7 @@ namespace eval punk { proc pipeswitchc {pipescript args} { set binding {} if {[info level] == 1} { - #up 1 is global + #up 1 is global set get_vars [list info vars] } else { set get_vars [list info locals] @@ -5918,13 +5924,13 @@ namespace eval punk { % - pipematch - ispipematch { incr i set e2 [lindex $args $i] - #set body [list $e {*}$e2] + #set body [list $e {*}$e2] #append body { $data} - - set body [list $e {*}$e2] + + set body [list $e {*}$e2] append body { {*}$data} - - + + set applylist [list {data} $body] #puts stderr $applylist set r [apply $applylist $r] @@ -5934,7 +5940,7 @@ namespace eval punk { incr i set e2 [lindex $args $i] set body [list $e $e2] - #pipeswitch takes 'args' - so expand $data when in pipedata context + #pipeswitch takes 'args' - so expand $data when in pipedata context append body { {*}$data} #use applylist instead of uplevel when in pipedata context! #can use either switchdata/data but not vars in calling context of 'pipedata' command. @@ -5993,7 +5999,7 @@ namespace eval punk { if {$::tcl_platform(platform) eq "windows"} { set sep ";" } else { - # : ok for linux/bsd ... mac? + # : ok for linux/bsd ... mac? set sep ":" } set cond [string map [list $glob] {expr {[string length $item] && [string match $item]}}] @@ -6006,7 +6012,7 @@ namespace eval punk { } proc path {{glob *}} { set pipe [punk::path_list_pipe $glob] - {*}$pipe |> list_as_lines + {*}$pipe |> list_as_lines } #------------------------------------------------------------------- @@ -6049,7 +6055,7 @@ namespace eval punk { #e.g unix files such as /dev/null vs windows devices such as CON,PRN #e.g COM1 is mapped as /dev/ttyS1 in wsl (?) #Note also - tcl can have vfs mounted file which will appear as a directory to Tcl - but a file to external commands! - #We will stick with the Tcl view of the file system. + #We will stick with the Tcl view of the file system. #User can use their own direct calls to external utils if #Note we can't support $? directly in Tcl - script would have to test ${?} or use [set ?] proc sh_TEST {args} { @@ -6067,7 +6073,7 @@ namespace eval punk { if {$::tcl_platform(platform) eq "windows"} { #e.g trailing dot or trailing space if {[punk::winpath::illegalname_test $a2]} { - #protect with \\?\ to stop windows api from parsing + #protect with \\?\ to stop windows api from parsing #will do nothing if already prefixed with \\?\ set a2 [punk::winpath::illegalname_fix $a2] @@ -6077,7 +6083,7 @@ namespace eval punk { switch -- $a1 { -b { #dubious utility on FreeBSD, windows? - #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' + #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' #Linux apparently uses them though if{[file exists $a2]} { set boolresult [expr {[file type $a2] eq "blockSpecial"}] @@ -6086,7 +6092,7 @@ namespace eval punk { } } -c { - #e.g on windows CON,NUL + #e.g on windows CON,NUL if {[file exists $a2]} { set boolresult [expr {[file type $a2] eq "characterSpecial"}] } else { @@ -6100,9 +6106,9 @@ namespace eval punk { set boolresult [file exists $a2] } -f { - #e.g on windows CON,NUL + #e.g on windows CON,NUL if {[file exists $a2]} { - set boolresult [expr {[file type $a2] eq "file"}] + set boolresult [expr {[file type $a2] eq "file"}] } else { set boolresult false } @@ -6162,7 +6168,7 @@ namespace eval punk { } "-eq" { #test expects a possibly-large integer-like thing - #shell scripts will + #shell scripts will if {![is_sh_test_integer $a1]} { puts stderr "sh_TEST: invalid integer '$a1'" set lasterr 2 @@ -6266,7 +6272,7 @@ namespace eval punk { set exitcode [dict get $callinfo exitcode] if {[string length $errinfo]} { puts stderr "sh_TEST error in external call to 'test $args': $errinfo" - set lasterr $exitcode + set lasterr $exitcode } if {$exitcode == 0} { set boolresult true @@ -6302,7 +6308,7 @@ namespace eval punk { set c [lindex $args 0] if {[string is integer -strict $c]} { #return [expr {$c == 0}] - #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true + #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true if {$c == 0} { return true } else { @@ -6342,7 +6348,7 @@ namespace eval punk { #maint - punk::args has similar #this is largely obsolete - uses dict for argspecs (defaults) instead of textblock as in punk::args #textblock has more flexibility in some ways - but not as easy to manipulate especially with regards to substitutions - #todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default? + #todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default? #JMN #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. @@ -6398,7 +6404,7 @@ namespace eval punk { foreach {k v} $rawargs { if {![string match -* $k]} { break - } + } if {$i+1 >= [llength $rawargs]} { #no value for last flag error "bad options for $caller. No value supplied for last option $k" @@ -6498,7 +6504,7 @@ namespace eval punk { #NOT attempting to match haskell other than in overall concept. # - #magic var-names are a bit of a code-smell. But submitting only an expr argument is more Tcl-like than requiring an 'apply' specification. + #magic var-names are a bit of a code-smell. But submitting only an expr argument is more Tcl-like than requiring an 'apply' specification. #Haskell seems to take an entire lambda so varnames can be user-specified - but the 'magic' there is in it's choice of submitting 2 elements at a time #We could do similar .. but we'll focus on comprehensibility for the basic cases - especially as begginning and end of list issues could be confusing. # @@ -6587,7 +6593,7 @@ namespace eval punk { } #group_numlist ? preserve representation of numbers rather than use string comparison? - + # - group_string #.= punk::group_string "aabcccdefff" @@ -6672,7 +6678,7 @@ namespace eval punk { #review #how do we stop matrix pipelines from leaving commands around? i.e how do we call destroy on the matrixchain wrapper if not explicitly? #Perhaps will be solved by: Tip 550: Garbage collection for TclOO - #Theoretically this should allow tidy up of objects created within the pipeline automatically + #Theoretically this should allow tidy up of objects created within the pipeline automatically #If the object name is placed in the pipeline variable dict then it should survive across segment apply scripts and only go out of scope at the end. proc matrix_command_from_rows {matrix_rows} { set mcmd [struct::matrix] @@ -6688,7 +6694,7 @@ namespace eval punk { set filtered_list [list] set binding {} if {[info level] == 1} { - #up 1 is global + #up 1 is global set get_vars [list ::info vars] } else { set get_vars [list ::info locals] @@ -6792,22 +6798,22 @@ namespace eval punk { lassign [dict values $argd] leaders opts values received set searchspecs [dict values $values] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_dir [dict get $opts -dir] if {$opt_dir eq "\uFFFF"} { set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_exclude_dupfiles [dict get $opts -exclude_dupfiles] set opt_exclude_punctlines [dict get $opts -exclude_punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars set opt_punctchars [dict get $opts -punctchars] set opt_largest [dict get $opts -show_largest] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set filepaths [punk::path::treefilenames -dir $opt_dir {*}$searchspecs] set loc 0 - set dupfileloc 0 + set dupfileloc 0 set seentails [dict create] set seencksums [dict create] ;#key is cksum value is list of paths set largestloc [dict create] @@ -6843,7 +6849,7 @@ namespace eval punk { set lines [linelist -line {trimright} -block {trimall} $contents] if {!$opt_exclude_punctlines} { set floc [llength $lines] - set comparedlines $lines + set comparedlines $lines } else { set mapawaypunctuation [list] foreach p $opt_punctchars empty {} { @@ -6856,7 +6862,7 @@ namespace eval punk { lappend comparedlines $ln } else { incr fpurepunctlines - } + } } } if {$opt_largest > 0} { @@ -6929,8 +6935,8 @@ namespace eval punk { set sorted [lsort -stride 2 -index 1 -decreasing -integer $largestloc] set kidx 0 for {set i 0} {$i < $opt_largest} {incr i} { - if {$kidx+1 > [llength $sorted]} {break} - dict set largest_n [lindex $sorted $kidx] [lindex $sorted $kidx+1] + if {$kidx+1 > [llength $sorted]} {break} + dict set largest_n [lindex $sorted $kidx] [lindex $sorted $kidx+1] incr kidx 2 } dict set result largest $largest_n @@ -6940,11 +6946,11 @@ namespace eval punk { - #!!!todo fix - linedict is unfinished and non-functioning - #linedict based on indents + #!!!todo fix - linedict is unfinished and non-functioning + #linedict based on indents proc linedict {args} { set data [lindex $args 0] - set opts [lrange $args 1 end] ;#todo + set opts [lrange $args 1 end] ;#todo set nlsplit [split $data \n] set rootindent -1 set stepindent -1 @@ -6969,7 +6975,7 @@ namespace eval punk { set rootindent $this_indent } if {$this_indent == $rootindent} { - set is_rootkey 1 + set is_rootkey 1 } if {$this_indent < $rootindent} { error "bad root indentation ($this_indent) at line: $i smallest indent was set by first key line: $firstkeyline" @@ -6983,7 +6989,7 @@ namespace eval punk { set firststepline $ln } if {$this_indent == $stepindent} { - dict set d [lindex $keys end] $ln + dict set d [lindex $keys end] $ln } else { if {($this_indent % $stepindent) != 0} { error "bad indentation ($this_indent) at line: $i not a multiple of the first key indent $step_indent seen on $firststepline" @@ -7008,7 +7014,7 @@ namespace eval punk { proc dictline {d} { puts stderr "unimplemented" set lines [list] - + return $lines } @@ -7056,9 +7062,9 @@ namespace eval punk { (pipeline data inserted at end of each |...> segment is passed as single item unless inserted with an expanding insertion specifier such as .=>* ) e.g1: - .= list a b c |v1,/1-end,/0>\\ - .=>* inspect -label i1 -- |>\\ - .=v1> inspect -label i2 -- |>\\ + .= list a b c |v1,/1-end,/0>\\ + .=>* inspect -label i1 -- |>\\ + .=v1> inspect -label i2 -- |>\\ string toupper (3) i1: {a b c} {b c} a (1) i2: a b c @@ -7072,7 +7078,7 @@ namespace eval punk { e.g (2) MYLABEL: val1 val2 The label can include ANSI codes. e.g - inspect -label [a+ red]mylabel -- val1 val2 val3 + inspect -label [a+ red]mylabel -- val1 val2 val3 " -limit -type int -default 20 -help\ "When multiple values are passed to inspect - limit the number @@ -7090,14 +7096,14 @@ namespace eval punk { "An existing open channel to write to. If value is any of nul, null, /dev/nul the channel output is disabled. This effectively disables inspect as the args are simply passed through in the return to continue the pipeline. - " + " -showcount -type boolean -default 1 -help\ "Display a leading indicator in brackets showing the number of arg values present." -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { 0 "Strip ANSI codes from display - of values. The disply output will + of values. The disply output will still be colourised if -ansibase has - not been set to empty string or + not been set to empty string or [a+ normal]. The stderr or stdout channels may also have an ansi colour. (see 'colour off' or punk::config)" @@ -7107,14 +7113,14 @@ namespace eval punk { with replacement indicators. e.g esc, newline, space, tab" VIEW "Alias for 2" - 3 "Display as per 2 but with + 3 "Display as per 2 but with colourised ANSI replacement codes." VIEWCODES "Alias for 3" 4 "Display ANSI and control chars in default colour, but apply the contained ansi to the text portions so they display - as they would for -ansi 1" + as they would for -ansi 1" VIEWSTYLE "Alias for 4" } -ansibase -type ansistring -default {${[a+ brightgreen]}} -help\ @@ -7137,7 +7143,7 @@ namespace eval punk { set flags [list] set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect -- if {$endoptsposn >= 0} { - set flags [lrange $args 0 $endoptsposn-1] + set flags [lrange $args 0 $endoptsposn-1] set pipeargs [lrange $args $endoptsposn+1 end] } else { #no explicit end of opts marker @@ -7188,7 +7194,7 @@ namespace eval punk { set val [lindex $pipeargs 0] set count 1 } else { - #but the pipeline segment could have an insertion-pattern ending in * + #but the pipeline segment could have an insertion-pattern ending in * set val $pipeargs set count [llength $pipeargs] } @@ -7234,7 +7240,7 @@ namespace eval punk { set ansibase [dict get $opts -ansibase] if {$ansibase ne ""} { - #-ansibase default is hardcoded into punk::args definition + #-ansibase default is hardcoded into punk::args definition #run a test using any ansi code to see if colour is still enabled if {[a+ red] eq ""} { set ansibase "" ;#colour seems to be disabled @@ -7246,7 +7252,7 @@ namespace eval punk { set displayval $ansibase[punk::ansi::ansistrip $displayval] } 1 { - #val may have ansi - including resets. Pass through ansibase_lines to + #val may have ansi - including resets. Pass through ansibase_lines to if {$ansibase ne ""} { set displayval [::textblock::ansibase_lines $displayval $ansibase] } @@ -7329,9 +7335,9 @@ namespace eval punk { $t configure_column 1 -minwidth [expr {$width_1 + 1}] $t configure -title $title - set text "" + set text "" append text [$t print] - + set warningblock "" set introblock $mascotblock @@ -7380,14 +7386,14 @@ namespace eval punk { upvar ::punk::config::other_env_vars_config otherenv_config set known_punk [dict keys $punkenv_config] - set known_other [dict keys $otherenv_config] + set known_other [dict keys $otherenv_config] append text \n set usetable 1 if {$usetable} { set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] if {"windows" eq $::tcl_platform(platform)} { #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. - #The Tcl ::env array is linked to the underlying process view of the environment + #The Tcl ::env array is linked to the underlying process view of the environment #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. #an 'array get' will resynchronise. #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. @@ -7396,7 +7402,7 @@ namespace eval punk { #do an array read on ::env foreach {v vinfo} $punkenv_config { if {[info exists ::env($v)]} { - set c2 [set ::env($v)] + set c2 [set ::env($v)] } else { set c2 "(NOT SET)" } @@ -7415,7 +7421,7 @@ namespace eval punk { set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] foreach {v vinfo} $otherenv_config { if {[info exists ::env($v)]} { - set c2 [set ::env($v)] + set c2 [set ::env($v)] } else { set c2 "(NOT SET)" } @@ -7432,12 +7438,12 @@ namespace eval punk { append text $linesep\n append text "punk environment vars:\n" append text $linesep\n - set col1 [string repeat " " 25] + set col1 [string repeat " " 25] set col2 [string repeat " " 50] foreach v $known_punk { set c1 [overtype::left $col1 $v] if {[info exists ::env($v)]} { - set c2 [overtype::left $col2 [set ::env($v)] + set c2 [overtype::left $col2 [set ::env($v)]] } else { set c2 [overtype::right $col2 "(NOT SET)"] } @@ -7560,7 +7566,7 @@ namespace eval punk { } set widest0 [$t column_datawidth 0] $t configure_column 0 -minwidth [expr {$widest0 + 4}] - append text \n[$t print] + append text \n[$t print] lappend chunks [list stdout $text] } @@ -7570,7 +7576,7 @@ namespace eval punk { proc help {args} { set chunks [help_chunks {*}$args] foreach chunk $chunks { - lassign $chunk chan text + lassign $chunk chan text puts -nonewline $chan $text } } @@ -7615,7 +7621,7 @@ namespace eval punk { - + #friendly sh aliases (which user may wish to disable e.g if conflicts) interp alias {} test {} punk::sh_test ;#not much reason to run 'test' directly in punk shell (or tclsh shell) as returncode not obvious anyway due to use of exec interp alias {} TEST {} punk::sh_TEST; #double-evaluation to return tcl true/false from exitcode @@ -7652,7 +7658,7 @@ namespace eval punk { #---------------------------------------------- interp alias {} linelistraw {} punk::linelistraw - + # 'path' collides with kettle path in kettle::doc function - todo - patch kettle? interp alias {} PATH {} punk::path @@ -7702,13 +7708,13 @@ namespace eval punk { # ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion interp alias {} l {} sh_runout -n ls -A ;#plain text listing - #interp alias {} ls {} sh_runout -n ls -AF --color=always + #interp alias {} ls {} sh_runout -n ls -AF --color=always interp alias {} ls {} shellrun::runconsole ls -AF --color=always ;#use unknown to use terminal and allow | more | less #note that shell globbing with * won't work on unix systems when using unknown/exec interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. # -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? - #interp alias {} lw {} ls -aFv --color=always + #interp alias {} lw {} ls -aFv --color=always interp alias {} dir {} shellrun::runconsole dir @@ -7729,7 +7735,7 @@ namespace eval punk { interp alias {} ./~ {} punk::nav::fs::d/~ interp alias {} d/~ {} punk::nav::fs::d/~ interp alias "" x/ "" punk::nav::fs::x/ - + if {$::tcl_platform(platform) eq "windows"} { set has_powershell 1 @@ -7737,10 +7743,10 @@ namespace eval punk { interp alias {} dw {} dir /W/D } else { #todo - natsorted equivalent - #interp alias {} dl {} + #interp alias {} dl {} interp alias {} dl {} puts stderr "not implemented" interp alias {} dw {} puts stderr "not implemented" - #todo - powershell detection on other platforms + #todo - powershell detection on other platforms set has_powershell 0 } if {$has_powershell} { @@ -7778,7 +7784,7 @@ namespace eval punk { 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]} { @@ -7803,8 +7809,8 @@ punk::mod::cli set_alias app #todo - change to punk::dev package require punk::mix -punk::mix::cli set_alias dev -punk::mix::cli set_alias deck ;#deprecate! +punk::mix::cli set_alias dev +punk::mix::cli set_alias deck ;#deprecate! #todo - add punk::deck for managing cli modules and commandsets diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm.txt b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm.txt new file mode 100644 index 00000000..db0f494a --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm.txt @@ -0,0 +1,7672 @@ +#Punk - where radical modification is a craft and anti-patterns are another exploratory tool for the Pattern Punk. +#Built on Tcl of course - because it's the most powerful piece of under-appreciated and alternate-thinking engineering you can plug into. + + +namespace eval punk { + proc lazyload {pkg} { + package require zzzload + if {[package provide $pkg] eq ""} { + zzzload::pkg_require $pkg + } + } + #lazyload twapi ? + + catch {package require vfs} ;#attempt load now so we can use faster 'package provide' to test existence later + + variable can_exec_windowsapp + set can_exec_windowsapp unknown ;#don't spend a potential X00ms testing until needed + variable windowsappdir + set windowsappdir "" + variable cmdexedir + set cmdexedir "" + + proc sync_package_paths_script {} { + #the tcl::tm namespace doesn't exist until one of the tcl::tm commands + #is run. (they are loaded via ::auto_index triggering load of tm.tcl) + #we call tcl::tm::list to trigger the initial set of tm paths before + #we can override it, otherwise our changes will be lost + #REVIEW - won't work on safebase interp where paths are mapped to {$p(:x:)} etc + return "\ + apply {{ap tmlist} { + set ::auto_path \$ap + tcl::tm::list + set ::tcl::tm::paths \$tmlist + }} {$::auto_path} {[tcl::tm::list]} + " + } + + proc rehash {{refresh 0}} { + global auto_execs + if {!$refresh} { + unset -nocomplain auto_execs + } else { + set names [array names auto_execs] + unset -nocomplain auto_execs + foreach nm $names { + auto_execok_windows $nm + } + } + return + } + + + proc ::punk::auto_execok_original name [info body ::auto_execok] + variable better_autoexec + + #set better_autoexec 0 ;#use this var via better_autoexec only + #proc ::punk::auto_execok_windows name { + # ::punk::auto_execok_original $name + #} + + set better_autoexec 1 + proc ::punk::auto_execok_windows {name} { + ::punk::auto_execok_better $name + } + + set has_commandstack [expr {![catch {package require commandstack}]}] + if {$has_commandstack} { + if { + [catch { + package require punk::packagepreference + } errM] + } { + catch {puts stderr "Failed to load punk::packagepreference"} + } + catch {punk::packagepreference::install} + } else { + # + } + + if {![interp issafe] && $has_commandstack && $::tcl_platform(platform) eq "windows"} { + #still a caching version of auto_execok - but with proper(fixed) search order + + #set b [info body ::auto_execok] + #proc ::auto_execok_original name $b + + proc better_autoexec {{onoff ""}} { + variable better_autoexec + if {$onoff eq ""} { + return $better_autoexec + } + if {![string is boolean -strict $onoff]} { + error "better_autoexec argument 'onoff' must be a boolean, received: $onoff" + } + if {$onoff && ($onoff != $better_autoexec)} { + puts "Turning on better_autoexec - search PATH first then extension" + set better_autoexec 1 + proc ::punk::auto_execok_windows {name} { + ::punk::auto_execok_better $name + } + punk::rehash + } elseif {!$onoff && ($onoff != $better_autoexec)} { + puts "Turning off better_autoexec - search extension then PATH" + set better_autoexec 0 + proc ::punk::auto_execok_windows {name} { + ::punk::auto_execok_original $name + } + punk::rehash + } else { + puts "no change" + } + } + #better_autoexec $better_autoexec ;#init to default + + + proc auto_execok_better {name} { + global auto_execs env tcl_platform + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + #puts stdout "[a+ red]...[a]" + set auto_execs($name) "" + + set shellBuiltins [list assoc cls copy date del dir echo erase exit ftype \ + md mkdir mklink move rd ren rename rmdir start time type ver vol] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext $execExtensions { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + #change1 + #set path "[file dirname [info nameofexecutable]];.;" + set path "[file dirname [info nameofexecutable]];" + + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + append path "$windir/system32;$windir/system;$windir;" + } + + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } + } + + #change2 + set lookfor [lmap ext $execExtensions {string cat ${name} ${ext}}] + foreach dir [split $path {;}] { + #set dir [file normalize $dir] + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + + foreach match [glob -nocomplain -dir $dir -tail {*}$lookfor] { + set file [file join $dir $match] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + + #foreach ext $execExtensions { + #unset -nocomplain checked + #foreach dir [split $path {;}] { + # # Skip already checked directories + # if {[info exists checked($dir)] || ($dir eq "")} { + # continue + # } + # set checked($dir) {} + # set file [file join $dir ${name}${ext}] + # if {[file exists $file] && ![file isdirectory $file]} { + # return [set auto_execs($name) [list $file]] + # } + #} + #} + return "" + } + + + #review - what if punk package reloaded - but ::auto_execs has updated path for winget.exe? + #what if we create another interp and use the same ::auto_execs? The appdir won't be detected. + #TODO - see if there is a proper windows way to determine where the 'reparse point' apps are installed + + + #winget is installed on all modern windows and is an example of the problem this addresses + #we target apps with same location + + #the main purpose of this override is to support windows app executables (installed as 'reparse points') + #for Tcl versions prior to the 2025-01 fix by APN https://core.tcl-lang.org/tcl/tktview/4f0b5767ac + #versions prior to this will use cmd.exe to resolve the links + set stackrecord [commandstack::rename_command -renamer ::punk auto_execok name { + #set windowsappdir "%appdir%" + upvar ::punk::can_exec_windowsapp can_exec_windowsapp + upvar ::punk::windowsappdir windowsappdir + upvar ::punk::cmdexedir cmdexedir + + if {$windowsappdir eq ""} { + #we are targeting the winget location under the presumption this is where microsoft store apps are stored as 'reparse points' + #Tcl (2025) can't exec when given a path to these 0KB files + #This path is probably something like C:/Users/username/AppData/Local/Microsoft/WindowsApps + if {!([info exists ::env(LOCALAPPDATA)] && + [file exists [set testapp [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]])} { + #should be unlikely to get here - unless LOCALAPPDATA missing + set windowsappdir [file dirname [lindex [::punk::auto_execok_windows winget.exe] 0]] + catch {puts stderr "(resolved winget by search)"} + } else { + set windowsappdir [file dirname $testapp] + } + } + + #set default_auto [$COMMANDSTACKNEXT $name] + set default_auto [::punk::auto_execok_windows $name] + #if {$name ni {cmd cmd.exe}} { + # unset -nocomplain ::auto_execs + #} + + if {$default_auto eq ""} { + return + } + set namedir [file dirname [lindex $default_auto 0]] + + if {$namedir eq $windowsappdir} { + if {$can_exec_windowsapp eq "unknown"} { + if {[catch {exec [file join $windowsappdir winget.exe] --version}]} { + set can_exec_windowsapp 0 + } else { + set can_exec_windowsapp 1 + } + } + if {$can_exec_windowsapp} { + return [file join $windowsappdir $name] + } + if {$cmdexedir eq ""} { + #cmd.exe very unlikely to move + set cmdexedir [file dirname [lindex [::punk::auto_execok_windows cmd.exe] 0]] + #auto_reset never seems to exist as a command - because auto_reset deletes all commands in the ::auto_index + #anyway.. it has other side effects (affects auto_load) + } + return "[file join $cmdexedir cmd.exe] /c $name" + } + return $default_auto + }] + } +} + + +#repltelemetry cooperation with other packages such as shellrun +#Maintenance warning: shellrun expects repltelemetry_emmitters to exist if punk namespace exists +namespace eval punk { + variable repltelemetry_emmitters + #don't stomp.. even if something created this namespace in advance and is 'cooperating' a bit early + if {![info exists repltelemetry_emitters]} { + set repltelemetry_emmitters [list] + } +} + +namespace eval punk::pipecmds { + #where to install proc/compilation artifacts for pieplines + namespace export * +} +namespace eval punk::pipecmds::split_patterns {} +namespace eval punk::pipecmds::split_rhs {} +namespace eval punk::pipecmds::var_classify {} +namespace eval punk::pipecmds::destructure {} +namespace eval punk::pipecmds::insertion {} + + +#globals... some minimal global var pollution +#punk's official silly test dictionary +set punk_testd [dict create \ + a0 a0val \ + b0 [dict create \ + a1 b0a1val \ + b1 b0b1val \ + c1 b0c1val \ + d1 b0d1val] \ + c0 [dict create] \ + d0 [dict create \ + a1 [dict create \ + a2 d0a1a2val \ + b2 d0a1b2val \ + c2 d0a1c2val] \ + b1 [dict create \ + a2 [dict create \ + a3 d0b1a2a3val \ + b3 d0b1a2b3val] \ + b2 [dict create \ + a3 d0b1b2a3val \ + bananas "in pyjamas" \ + c3 [dict create \ + po "in { }" \ + b4 "" \ + c4 "can go boom"] \ + d3 [dict create \ + a4 "-paper -cuts"] \ + e3 [dict create]]]] \ + e0 "multi\nline"] +#test dict 2 - uniform structure and some keys with common prefixes for glob matching +set punk_testd2 [dict create \ + a0 [dict create \ + b1 {a b c} \ + b2 {a b c d} \ + x1 {x y z 1 2} \ + y2 {X Y Z 1 2} \ + z1 {k1 v1 k2 v2 k3 v3}] \ + a1 [dict create \ + b1 {a b c} \ + b2 {a b c d} \ + x1 {x y z 1 2} \ + y2 {X Y Z 1 2} \ + z1 {k1 v1 k2 v2 k3 v3}] \ + b1 [dict create \ + b1 {a b c} \ + b2 {a b c d} \ + x1 {x y z 1 2} \ + y2 {X Y Z 1 2} \ + z1 {k1 v1 k2 v2 k3 v3}]] + +#impolitely cooperative with punk repl - todo - tone it down. +#namespace eval ::punk::repl::codethread { +# variable running 0 +#} +package require punk::lib ;# subdependency punk::args +package require punk::ansi +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::repl::codethread +package require punk::config +#package require textblock +package require punk::console ;#requires Thread +package require punk::ns +package require punk::winpath ;# for windows paths - but has functions that can be called on unix systems +package require punk::repo +package require punk::du +package require punk::mix::base +package require base64 + +package require punk::pipe + +namespace eval punk { + # -- --- --- + #namespace import ::control::assert ;#according to tcllib doc - assert can be enabled/disabled per namespace + # using control::control assert enabled within a namespace for which ::control::assert wasn't imported can produce surprising results. + #e.g setting to zero may keep asserts enabled - (e.g if the assert command is still available due to namespace path etc) - but.. querying the enabled status may show zero even in the parent namespace where asserts also still work. + #package require control + #control::control assert enabled 1 + + #We will use punk::assertion instead + + package require punk::assertion + if {[catch {namespace import ::punk::assertion::assert} errM]} { + catch { + puts stderr "punk error importing punk::assertion::assert\n$errM" + puts stderr "punk::a* commands:[info commands ::punk::a*]" + } + } + punk::assertion::active on + # -- --- --- + + interp alias {} purelist {} lreplace x 0 0 ;#required by pipe system + if { + [catch { + package require pattern + } errpkg] + } { + catch {puts stderr "Failed to load package pattern error: $errpkg"} + } + package require shellfilter + package require punkapp + package require funcl + + package require struct::list + package require fileutil + #package require punk::lib + + #NOTE - always call debug.xxx with braced message instead of double-quoted (unless specifically intending to do double-subtition) + #(or $ within values will be substituted, causing an extra error message if the var doesn't exist - which it quite possibly doesn't) + package require debug + + debug define punk.unknown + debug define punk.pipe + debug define punk.pipe.var + debug define punk.pipe.args + debug define punk.pipe.rep ;#string/list representation with tcl::unsupported::representation + debug define punk.pipe.compile ;#info about when we compile pipeline components into procs etc + + + #----------------------------------- + # todo - load initial debug state from config + debug off punk.unknown + debug level punk.unknown 1 + debug off punk.pipe + debug level punk.pipe 4 + debug off punk.pipe.var + debug level punk.pipe.var 4 + debug off punk.pipe.args + debug level punk.pipe.args 3 + debug off punk.pipe.rep 2 + debug off punk.pipe.compile + debug level punk.pipe.compile 2 + + + debug header "dbg> " + + + variable last_run_display [list] + + + #variable re_headvar1 {([a-zA-Z:@.(),]+?)(?![^(]*\))(,.*)*$} + + + #----------------------------------------------------------------------------------- + #strlen is important for testing issues with string representationa and shimmering. + #This specific implementation with append (as at 2023-09) is designed to ensure the original str representation isn't changed + #It may need to be reviewed with different Tcl versions in case the append empty string is 'optimised/tuned' in some way that affects the behaviour + proc strlen {str} { + append str2 $str {} + string length $str2 + } + #----------------------------------------------------------------------------------- + + #get a copy of the item without affecting internal rep + proc objclone {obj} { + append obj2 $obj {} + } + proc set_clone {varname obj} { + #maintenance: also punk::lib::set_clone + #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + + interp alias "" strlen "" ::punk::strlen + interp alias "" str_len "" ::punk::strlen + interp alias "" objclone "" ::punk::objclone + #proc ::strlen {str} { + # string length [append str2 $str {}] + #} + #proc ::objclone {obj} { + # append obj2 $obj {} + #} + #----------------------------------------------------------------------------------- + #order of arguments designed for pipelining + #review - 'piper_' prefix is a naming convention for functions that are ordered for tail-argument pipelining + #piper_ function names should read intuitively when used in a pipeline with tail argument supplied by the pipeline - but may seem reversed when using standalone. + proc piper_append {new base} { + append base $new + } + interp alias "" piper_append "" ::punk::piper_append + proc piper_prepend {new base} { + append new $base + } + interp alias "" piper_prepend "" ::punk::piper_prepend + + proc ::punk::K {x y} {return $x} + + proc stacktrace {} { + set stack "Stack trace:\n" + for {set i 1} {$i < [info level]} {incr i} { + set lvl [info level -$i] + set pname [lindex $lvl 0] + append stack [string repeat " " $i]$pname + + if {![catch {info args $pname} pargs]} { + foreach value [lrange $lvl 1 end] arg $pargs { + if {$value eq ""} { + if {$arg != 0} { + info default $pname $arg value + } + } + append stack " $arg='$value'" + } + } else { + append stack " !unknown vars for $pname" + } + + append stack \n + } + 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] + } + } + + #get last command result that was run through the repl + proc ::punk::get_runchunk {args} { + set argd [punk::args::parse $args withdef { + @id -id ::punk::get_runchunk + @cmd -name "punk::get_runchunk" -help\ + "experimental" + @opts + -1 -optional 1 -type none + -2 -optional 1 -type none + @values -min 0 -max 0 + }] + #todo - make this command run without truncating previous runchunks + set runchunks [tsv::array names repl runchunks-*] + + set sortlist [list] + foreach cname $runchunks { + set num [lindex [split $cname -] 1] + lappend sortlist [list $num $cname] + } + set sorted [lsort -index 0 -integer $sortlist] + set chunkname [lindex $sorted end-1 1] + set runlist [tsv::get repl $chunkname] + #puts stderr "--$runlist" + if {![llength $runlist]} { + return "" + } else { + return [lindex [lsearch -inline -index 0 $runlist result] 1] + } + } + interp alias {} _ {} ::punk::get_runchunk + + + proc ::punk::var {varname {= _=.=_} args} { + upvar $varname the_var + switch -exact -- ${=} { + = { + if {[llength $args] > 1} { + set the_var $args + } else { + set the_var [lindex $args 0] + } + } + .= { + if {[llength $args] > 1} { + set the_var [uplevel 1 $args] + } else { + set the_var [uplevel 1 [lindex $args 0]] + } + } + _=.=_ { + set the_var + } + default { + set the_var [list ${=} {*}$args] + } + } + } + proc src {args} { + #based on wiki.. https://wiki.tcl-lang.org/page/source+with+args + #added support for ?-encoding name? and other options of Tcl source command under assumption they come pairs before the filename + # review? seems unlikely source command will ever accept solo options. It would make complete disambiguation impossible when passing additional args as we are doing here. + set cmdargs [list] + set scriptargs [list] + set inopts 0 + set i 0 + foreach a $args { + if {$i eq [llength $args] - 1} { + #reached end without finding end of opts + #must be file - even if it does match -* ? + break + } + if {!$inopts} { + if {[string match -* $a]} { + set inopts 1 + } else { + #leave loop at first nonoption - i should be index of file + break + } + } else { + #leave for next iteration to check + set inopts 0 + } + incr i + } + set cmdargs [lrange $args 0 $i] + set scriptargs [lrange $args $i+1 end] + set argv $::argv + set argc $::argc + set ::argv $scriptargs + set ::argc [llength $scriptargs] + set code [catch {uplevel [list source {*}$cmdargs]} return] + set ::argv $argv + set ::argc $argc + return -code $code $return + } + + + proc varinfo {vname {flag ""}} { + upvar $vname v + if {[array exists $vname]} { + error "can't read \"$vname\": variable is array" + } + if {[catch {set v} err]} { + error "can't read \"$vname\": no such variable" + } + set inf [shellfilter::list_element_info [list $v]] + set inf [dict get $inf 0] + if {$flag eq "-v"} { + return $inf + } + + set output [dict create] + dict set output wouldbrace [dict get $inf wouldbrace] + dict set output wouldescape [dict get $inf wouldescape] + dict set output head_tail_names [dict get $inf head_tail_names] + dict set output len [dict get $inf len] + return $output + } + + #review - extending core commands could be a bit intrusive...although it can make sense in a pipeline. + #e.g contrived pipeline example to only allow setting existing keys + ## .= @head.= list {a aaa b bbb c ccc} |d,dkeys@keys> |> &true.= {is_list_all_in_list $nkeys $dkeys} |> {dict modify d {*}$new} |> &true.= {is_list_all_ni_list $nkeys $dkeys} |> {dict modify d {*}$new} 0} { + lassign [scan $token %${first_term}s%s] var spec + } else { + if {$first_term == 0} { + set var "" + set spec $token + } + } + lappend varlist [list $var $spec] + set token "" + set token_index -1 ;#reduce by 1 because , not included in next token + set first_term -1 + } else { + append token $c + if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { + set first_term $token_index + } elseif {$c eq "("} { + set in_brackets 1 + } + } + } + set prevc $c + incr token_index + } + if {[string length $token]} { + #lappend varlist [splitstrposn $token $first_term] + set var $token + set spec "" + if {$first_term > 0} { + lassign [scan $token %${first_term}s%s] var spec + } else { + if {$first_term == 0} { + set var "" + set spec $token + } + } + lappend varlist [list $var $spec] + } + return $varlist + } + proc _split_var_key_at_unbracketed_comma1 {varspecs} { + set varlist [list] + set var_terminals [list "@" "/" "#" "!"] + set in_brackets 0 + #set varspecs [string trimleft $varspecs ,] + set token "" + #if {[string first "," $varspecs] <0} { + # return $varspecs + #} + set first_term -1 + set token_index 0 ;#index of terminal char within each token + foreach c [split $varspecs ""] { + if {$in_brackets} { + if {$c eq ")"} { + set in_brackets 0 + } + append token $c + } else { + if {$c eq ","} { + if {$first_term > -1} { + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + set token "" + set token_index -1 ;#reduce by 1 because , not included in next token + set first_term -1 + } else { + if {$first_term == -1} { + if {$c in $var_terminals} { + set first_term $token_index + } + } + append token $c + if {$c eq "("} { + set in_brackets 1 + } + } + } + incr token_index + } + if {[string length $token]} { + if {$first_term > -1} { + set v [string range $token 0 $first_term-1] + set k [string range $token $first_term end] ;#key section includes the terminal char + lappend varlist [list $v $k] + } else { + lappend varlist [list $token ""] + } + } + return $varlist + } + + proc fp_restructure {selector data} { + if {$selector eq ""} { + fun=.= {val $input} and always break + set lhs "" + set rhs "" + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + set subpath [join [lrange $subindices 0 $i_keyindex] /] + set lhs $subpath + set assigned "" + set get_not 0 + set already_assigned 0 + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #todo - see if 'string is list' improved in tcl9 vs catch {llength $list} + switch -exact -- $index { + # { + set active_key_type "list" + if {![catch {llength $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-list + break + } + } + ## { + set active_key_type "dict" + if {![catch {dict size $leveldata} assigned]} { + set already_assigned 1 + } else { + set action ?mismatch-not-a-dict + break + } + } + #? { + #review - compare to %# ????? + #seems to be unimplemented ? + set assigned [string length $leveldata] + set already_assigned 1 + } + @ { + upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + set active_key_type "list" + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lindex $leveldata $index] + set already_assigned 1 + } + @@ {-} @?@ {-} @??@ { + set active_key_type "dict" + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that ?@ forms a different subpath - so can be used to test match prior to @@ without affecting the index) + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + # + #set subpath [join [lrange $subindices 0 $i_keyindex] /] + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set next_this_level [incr v_dict_idx($subpath)] + set keyindex [expr {$next_this_level - 1}] + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + if {$index eq "@?@"} { + set assigned [dict get $leveldata $k] + } else { + set assigned [list $k [dict get $leveldata $k]] + } + } else { + if {$index eq "@@"} { + set action ?mismatch-dict-index-out-of-range + break + } else { + set assigned [list] + } + } + set already_assigned 1 + } + default { + switch -glob -- $index { + @@* { + set active_key_type "dict" + set key [string range $index 2 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set action ?mismatch-dict-key-not-found + break + } + set already_assigned 1 + } + {@\?@*} { + set active_key_type "dict" + set key [string range $index 3 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [dict get $leveldata $key] + } else { + set assigned [list] + } + set already_assigned 1 + } + {@\?\?@*} { + set active_key_type "dict" + set key [string range $index 4 end] + #dict exists test is safe - no need for catch + if {[dict exists $leveldata $key]} { + set assigned [list $key [dict get $leveldata $key]] + } else { + set assigned [list] + } + set already_assigned 1 + } + @* { + set active_key_type "list" + set do_bounds_check 1 + set index [string trimleft $index @] + } + default { + # + } + } + + if {!$already_assigned} { + if {[string match "not-*" $index] && $active_key_type in [list "" "list"]} { + #e.g not-0-end-1 not-end-4-end-2 + set get_not 1 + #cherry-pick some easy cases, and either assign, or re-map to corresponding index + switch -- $index { + not-tail { + set active_key_type "list" + set assigned [lindex $leveldata 0]; set already_assigned 1 + } + not-head { + set active_key_type "list" + #set selector "tail"; set get_not 0 + set assigned [lrange $leveldata 1 end]; set already_assigned 1 + } + not-end { + set active_key_type "list" + set assigned [lrange $leveldata 0 end-1]; set already_assigned 1 + } + default { + #trim off the not- and let the remaining index handle based on get_not being 1 + set index [string range $index 4 end] + } + } + } + } + } + } + + if {!$already_assigned} { + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + if {$index eq "0"} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "head"} { + #NOTE: /@head and /head both do bounds check. This is intentional + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$len == 0} { + set action ?mismatch-list-index-out-of-range-empty + break + } + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + set assigned [lindex $leveldata 0] + } elseif {$index eq "end"} { + # @end /end + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && $len < 1} { + set action ?mismatch-list-index-out-of-range + } + set assigned [lindex $leveldata end] + } elseif {$index eq "tail"} { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$len == 0} { + set action ?mismatch-list-index-out-of-range + break + } + set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero. + } elseif {$index eq "anyhead"} { + # @anyhead + #allow returning of head or nothing if empty list + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lindex $leveldata 0] + } elseif {$index eq "anytail"} { + # @anytail + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 1 end] + } elseif {$index eq "init"} { + # @init + #all but last element - same as haskell 'init' + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned [lrange $leveldata 0 end-1] + } elseif {$index eq "list"} { + # @list + #allow returning of entire list even if empty + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + set assigned $leveldata + } elseif {$index eq "raw"} { + #no list checking.. + set assigned $leveldata + } elseif {$index eq "keys"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict keys $leveldata] + } elseif {$index eq "values"} { + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + set assigned [dict values $leveldata] + } elseif {$index eq "pairs"} { + if {[catch {dict size $leveldata} dsize]} { + set action ?mismatch-not-a-dict + break + } + #set assigned [dict values $leveldata] + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } elseif {[string is integer -strict $index]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + # only check if @ was directly in original index section + if {$do_bounds_check && ($index + 1 > $len || $index < 0)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + #already handled not-0 + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[string first "end" $index] >= 0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #leave the - from the end- as part of the offset + set offset [expr $endspec] ;#don't brace! + if {$do_bounds_check && ($offset > 0 || abs($offset) >= $len)} { + set action ?mismatch-list-index-out-of-range + break + } + if {$get_not} { + set assigned [lreplace $leveldata $index $index] + } else { + set assigned [lindex $leveldata $index] + } + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + if {$do_bounds_check && [string is integer -strict $start]} { + if {$start + 1 > $len || $start < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$start eq "end"} { + #ok + } elseif {$do_bounds_check} { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0 || abs($startoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$do_bounds_check && [string is integer -strict $end]} { + if {$end + 1 > $len || $end < 0} { + set action ?mismatch-list-index-out-of-range + break + } + } elseif {$end eq "end"} { + #ok + } elseif {$do_bounds_check} { + set endoffset [string range $end 3 end] ;#include the - from end- + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0 || abs($endoffset) >= $len} { + set action ?mismatch-list-index-out-of-range + break + } + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + puts "====> index:$index leveldata:$leveldata" + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + break + } + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + if {$start + 1 > $len || $end + 1 > $len} { + set action ?mismatch-not-a-list + break + } + if {$get_not} { + set assigned [lreplace $leveldata $start $end] + } else { + set assigned [lrange $leveldata $start $end] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } else { + #keyword 'pipesyntax' at beginning of error message + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } else { + #treat as dict key + set active_key_type "dict" + if {[dict exists $leveldata $index]} { + set assigned [dict get $leveldata $index] + } else { + set action ?mismatch-dict-key-not-found + break + } + } + } + set leveldata $assigned + set rhs $leveldata + #don't break on empty data - operations such as # and ## can return 0 + #if {![llength $leveldata]} { + # break + #} + incr i_keyindex + } + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + } + #todo - fp_destructure - return a function-pipeline that can then be transformed to a funcl and finally a more efficient tcl script + proc destructure_func {selector data} { + #puts stderr ".d." + set selector [string trim $selector /] + #upvar v_list_idx v_list_idx ;#positional tracker for /@ - list position + #upvar v_dict_idx v_dict_idx ;#positional tracker for /@@ - dict position + + #map some problematic things out of the way in a manner that maintains some transparency + #e.g glob chars ? * in a command name can make testing using {[info commands $cmd] ne ""} produce spurious results - requiring a stricter (and slower) test such as {$cmd in [info commands $cmd]} + #The selector forms part of the proc name + #review - compare with pipecmd_namemapping + set selector_safe [string map [list \ + ? \ + * \ + \\ \ + {"} \ + {$} \ + "\x1b\[" \ + "\x1b\]" \ + {[} \ + {]} \ + :: \ + {;} \ + " " \ + \t \ + \n \ + \r ] $selector] + + set cmdname ::punk::pipecmds::destructure::_$selector_safe + if {[info commands $cmdname] ne ""} { + return [$cmdname $data] ;# note upvar 2 for stateful v_list_idx to be resolved in _multi_bind_result context + } + + set leveldata $data + set body [destructure_func_build_procbody $cmdname $selector $data] + + puts stdout ---- + puts stderr "proc $cmdname {leveldata} {" + puts stderr $body + puts stderr "}" + puts stdout --- + proc $cmdname {leveldata} $body + #eval $script ;#create the proc + debug.punk.pipe.compile {proc $cmdname} 4 + #return [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs] + #use return - script has upvar 2 for v_list_idx to be resolved in _multi_bind_result context + return [$cmdname $data] + } + + #Builds a *basic* function to do the destructuring. + #This is simply a set of steps to destructure each level of the data based on the hierarchical selector. + #It just uses intermediate variables and adds some comments to the code to show the indices used at each point. + #This may be useful in the long run as a debug/fallback mechanism - but ideally we should be building a more efficient script. + proc destructure_func_build_procbody {cmdname selector data} { + set script "" + #place selector in comment in script only - if there is an error in selector we pick it up when building the script. + #The script itself should only be returning errors in its action key of the result dictionary + append script \n [string map [list $selector] {# set selector {}}] + set subindices [split $selector /] + append script \n [string map [list [list $subindices]] {# set subindices }] + set action ?match ;#default assumption. Alternatively set to ?mismatch or ?mismatch- and always break + append script \n {set action ?match} + #append script \n {set assigned ""} ;#review + set active_key_type "" + append script \n {# set active_key_type ""} + set lhs "" + #append script \n [tstr {set lhs ${{$lhs}}}] + append script \n {set lhs ""} + set rhs "" + append script \n {set rhs ""} + + set INDEX_OPERATIONS {} ;#caps to make clear in templates that this is substituted from script building scope + + #maintain key order - caller unpacks using lassign + set returnline {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + set return_template {return [tcl::dict::create -assigned $leveldata -action $action -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs $rhs -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch {return [dict create -assigned $leveldata -action ${$MISMATCH} -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_list {return [dict create -assigned $leveldata -action ?mismatch-not-a-list -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_list_index_out_of_range_empty {return [dict create -assigned $leveldata -action ?mismatch-list-index-out-of-range-empty -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_not_a_dict {return [dict create -assigned $leveldata -action ?mismatch-not-a-dict -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + #dict 'index' when using stateful @@ etc to iterate over dict instead of by key + set tpl_return_mismatch_dict_index_out_of_range {return [dict create -assigned $leveldata -action ?mismatch-dict-index-out-of-range -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + set tpl_return_mismatch_dict_key_not_found {return [dict create -assigned $leveldata -action ?mismatch-dict-key-not-found -lhs $lhs -rhs xxx -index_operations {${$INDEX_OPERATIONS}}]} + + + if {![string length $selector]} { + #just return $leveldata + set script { + dict create -assigned $leveldata -action ?match -lhs "" -rhs $leveldata + } + return $script + } + + if {[string is digit -strict [join $subindices ""]]} { + #review tip 551 (tcl9+?) + #puts stderr ">>>>>>>>>>>>>>>> data: $leveldata selector: $selector subindices: $subindices" + #pure numeric keylist - put straight to lindex + # + #NOTE: this direct access e.g v/0/1/2 doesn't check out of bounds which is at odds with list access containing @ + #We will leave this as a syntax for different (more performant) behaviour + #- it's potentially a little confusing - but it would be a shame not to have the possibility to take advantage of the lindex deep indexing capability in pattern matching. + #TODO - review and/or document + # + #Todo - add a handler for v/n/n/n/n/# to allow unchecked counting at depth too. + #(or more generally - loop until we hit another type of subindex) + + #set assigned [lindex $leveldata {*}$subindices] + if {[llength $subindices] == 1} { + append script \n "# index_operation listindex" \n + lappend INDEX_OPERATIONS listindex + } else { + append script \n "# index_operation listindex-nested" \n + lappend INDEX_OPERATIONS listindex-nested + } + append script \n [tstr -return string -allowcommands { + if {[catch {lindex $leveldata ${$subindices}} leveldata]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + # -- --- --- + #append script \n $returnline \n + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + if {[string match @@* $selector]} { + #part following a double @ is dict key possibly with forward-slash separators for subpath access e.g @@key/subkey/etc + set rawkeylist [split $selector /] ;#first key retains @@ - may be just '@@' + set keypath [string range $selector 2 end] + set keylist [split $keypath /] + lappend INDEX_OPERATIONS dict_path + if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} { + #pure keylist for dict - process in one go + #dict exists will return 0 if not a valid dict. + # is equivalent to {*}keylist when substituted + append script \n [tstr -return string -allowcommands { + if {[dict exists $leveldata ${$keylist}]} { + set leveldata [dict get $leveldata ${$keylist}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + append script [tstr -return string $return_template] + return $script + # -- --- --- + } + #else + #compound keylist e.g x@@data/@0/1 or x@@/a (combined dict/list access) + #process level by level + } + + + set i_keyindex 0 + append script \n {set i_keyindex 0} + #todo - check performance impact of catches around list and dict operations - consider single catch around destructure and less specific match error info? + foreach index $subindices { + #set index_operation "unspecified" + set level_script_complete 0 ;#instead of break - as we can't use data to determine break when building script + set SUBPATH [join [lrange $subindices 0 $i_keyindex] /] + append script \n "# ------- START index:$index subpath:$SUBPATH ------" + set lhs $index + append script \n "set lhs {$index}" + + set assigned "" + append script \n {set assigned ""} + + #got_not shouldn't need to be in script + set get_not 0 + if {[tcl::string::index $index 0] eq "!"} { + append script \n {#get_not is true e.g !0-end-1 !end-4-end-2 !0 !@0 !@@key} + set index [tcl::string::range $index 1 end] + set get_not 1 + } + + # do_bounds_check shouldn't need to be in script + set do_bounds_check 0 ;#modified by leading single @ for list operations - doesn't apply to certain items like 'head','tail' which have specifically defined bounds-checks implicit in their normal meaning. + #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. + #append script \n {set do_boundscheck 0} + switch -exact -- $index { + # {-} @# { + #list length + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS not-list + append script \n {# set active_key_type "list" index_operation: not-list} + append script \n { + if {[catch {llength $leveldata}]} { + #not a list - not-length is true + set assigned 1 + } else { + #is a list - not-length is false + set assigned 0 + } + } + } else { + lappend INDEX_OPERATIONS list-length + append script \n {# set active_key_type "list" index_operation: list-length} + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} assigned]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + } + set level_script_complete 1 + } + ## { + #dict size + set active_key_type "dict" + if {$get_not} { + lappend INDEX_OPERATIONS not-dict + append script \n {# set active_key_type "dict" index_operation: not-dict} + append script \n { + if {[catch {dict size $leveldata}]} { + set assigned 1 ;#not a dict - not-size is true + } else { + set assigned 0 ;#is a dict - not-size is false + } + } + } else { + lappend INDEX_OPERATIONS dict-size + append script \n {# set active_key_type "dict" index_operation: dict-size} + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} assigned]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + } + set level_script_complete 1 + } + %# { + set active_key_type "string" + if $get_not { + error "!%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS string-length + append script \n {# set active_key_type "" index_operation: string-length} + append script \n {set assigned [string length $leveldata]} + set level_script_complete 1 + } + %%# { + #experimental + set active_key_type "string" + if $get_not { + error "!%%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS ansistring-length + append script \n {# set active_key_type "" index_operation: ansistring-length} + append script \n {set assigned [ansistring length $leveldata]} + set level_script_complete 1 + } + %str { + set active_key_type "string" + if $get_not { + error "!%str - not string-get is not supported" + } + lappend INDEX_OPERATIONS string-get + append script \n {# set active_key_type "" index_operation: string-get} + append script \n {set assigned $leveldata} + set level_script_complete 1 + } + %sp { + #experimental + set active_key_type "string" + if $get_not { + error "!%sp - not string-space is not supported" + } + lappend INDEX_OPERATIONS string-space + append script \n {# set active_key_type "" index_operation: string-space} + append script \n {set assigned " "} + set level_script_complete 1 + } + %empty { + #experimental + set active_key_type "string" + if $get_not { + error "!%empty - not string-empty is not supported" + } + lappend INDEX_OPERATIONS string-empty + append script \n {# set active_key_type "" index_operation: string-empty} + append script \n {set assigned ""} + set level_script_complete 1 + } + @words { + set active_key_type "string" + if $get_not { + error "!%words - not list-words-from-string is not supported" + } + lappend INDEX_OPERATIONS list-words-from-string + append script \n {# set active_key_type "" index_operation: list-words-from-string} + append script \n {set assigned [regexp -inline -all {\S+} $leveldata]} + set level_script_complete 1 + } + @chars { + #experimental - leading character based on result not input(?) + #input type is string - but output is list + set active_key_type "list" + if $get_not { + error "!%chars - not list-chars-from-string is not supported" + } + lappend INDEX_OPERATIONS list-from_chars + append script \n {# set active_key_type "" index_operation: list-chars-from-string} + append script \n {set assigned [split $leveldata ""]} + set level_script_complete 1 + } + @join { + #experimental - flatten one level of list + #join without arg - output is list + set active_key_type "string" + if $get_not { + error "!@join - not list-join-list is not supported" + } + lappend INDEX_OPERATIONS list-join-list + append script \n {# set active_key_type "" index_operation: list-join-list} + append script \n {set assigned [join $leveldata]} + set level_script_complete 1 + } + %join { + #experimental + #input type is list - but output is string + set active_key_type "string" + if $get_not { + error "!%join - not string-join-list is not supported" + } + lappend INDEX_OPERATIONS string-join-list + append script \n {# set active_key_type "" index_operation: string-join-list} + append script \n {set assigned [join $leveldata ""]} + set level_script_complete 1 + } + %ansiview { + set active_key_type "string" + if $get_not { + error "!%# not string-ansiview is not supported" + } + lappend INDEX_OPERATIONS string-ansiview + append script \n {# set active_key_type "" index_operation: string-ansiview} + append script \n {set assigned [ansistring VIEW $leveldata]} + set level_script_complete 1 + } + %ansiviewstyle { + set active_key_type "string" + if $get_not { + error "!%# not string-ansiviewstyle is not supported" + } + lappend INDEX_OPERATIONS string-ansiviewstyle + append script \n {# set active_key_type "" index_operation: string-ansiviewstyle} + append script \n {set assigned [ansistring VIEWSTYLE $leveldata]} + set level_script_complete 1 + } + @ { + #as this is a stateful list next index operation - we use not (!@) to mean there is no element at the next index (instead of returning the complement ie all elements except next) + #This is in contrast to other not operations on indices e.g /!2 which returns all elements except that at index 2 + + + #append script \n {puts stderr [uplevel 1 [list info vars]]} + + #NOTE: + #v_list_idx in context of _multi_bind_result + #we call destructure_func from _mult_bind_result which in turn calls the proc (or the script on first run) + append script \n {upvar 2 v_list_idx v_list_idx} + + set active_key_type "list" + append script \n {# set active_key_type "list" index_operation: list-get-next} + #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey + #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 + #while x@,y@.= is reasonably handy - especially for args e.g $len} { + set assigned 1 + } else { + set assigned 0 + } + }] + } else { + lappend INDEX_OPERATIONS get-next + append script \n [tstr -return string -allowcommands { + set index [expr {[incr v_list_idx(@)]-1}] + + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$index+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + set assigned [lindex $leveldata $index] + } + }] + } + set level_script_complete 1 + } + @* { + set active_key_type "list" + if {$get_not} { + lappend INDEX_OPERATIONS list-is-empty + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + set assigned 1 ;#list is empty + } else { + set assigned 0 + } + }] + } else { + lappend INDEX_OPERATIONS list-get-all + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + set assigned [lrange $leveldata 0 end] + } + }] + } + set level_script_complete 1 + } + @@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get-next-value + append script \n {# set active_key_type "dict" index_operation: get-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + + #NOTE: it may at first seem pointless to use @@/key, since we have to know the key - but this can be used to match 'key' only at the first position in .= list key {x y} key2 etc + #x@@ = a {x y} + #x@@/@0 = a + #x@@/@1 = x y + #x@@/a = a {x y} + # but.. as the @@ is stateful - it generally isn't very useful for multiple operations on the same pair within the pattern group. + # (note that @@ @?@ @??@ form different subpaths - so the ? & ?? versions can be used to test match prior to @@ without affecting the index) + #review - might be more useful if they shared an index ? + # It is analogous to v1@,v2@ for lists. + # @pairs is more useful for repeated operations + + + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent"] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_index_out_of_range]} + } + }] + + set assignment_script [tstr -ret string -allowcommands $assignment_script] + + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @?@ { + #stateful: tracking of index using v_dict_idx + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-value + append script \n {# set active_key_type "dict" index_operation: get?-next-value} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent"] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [dict get $leveldata $k] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @??@ { + set active_key_type "dict" + lappend INDEX_OPERATIONS get?-next-pair + append script \n {# set active_key_type "dict" index_operation: get?-next-pair} + append script \n {upvar v_dict_idx v_dict_idx} ;#review! + set indent " " + set assignment_script [string map [list \r\n "\r\n$indent" \n "\n$indent"] { + if {($keyindex + 1) <= $dsize} { + set k [lindex [dict keys $leveldata] $keyindex] + set assigned [list $k [dict get $leveldata $k]] + } else { + set assigned [list] + } + }] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set next_this_level [incr v_dict_idx(${$SUBPATH})] + set keyindex [expr {$next_this_level -1}] + ${$assignment_script} + } + }] + set level_script_complete 1 + } + @vv@ {-} @VV@ {-} @kk@ {-} @KK@ { + error "unsupported index $index" + } + default { + #assert rules for values within @@ + #glob search is done only if there is at least one * within @@ + #if there is at least one ? within @@ - then a non match will not raise an error (quiet) + + #single or no char between @@: + #lookup/search is based on key - return is values + + #double char within @@: + #anything with a dot returns k v pairs e.g @k.@ @v.@ @..@ + #anything that is a duplicate returns k v pairs e.g @kk@ @vv@ @**@ + #anything with a letter and a star returns the type of the letter, and the search is based on the position of the star where posn 1 is for key, posn 2 is for value + #e.g @k*@ returns keys - search on values + #e.g @*k@ returns keys - search on keys + #e.g @v*@ returns values - search on values + #e.g @*v@ returns values - search on keys + + switch -glob -- $index { + @@* { + #exact key match - return value + #noisy get value - complain if key non-existent + #doesn't complain if not a dict - because we use 'tcl::dict::exists' which will return false without error even if the value isn't dict-shaped + set active_key_type "dict" + set key [string range $index 2 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-value-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-value-not + if {[dict exists $leveldata ${$key}]} { + set assigned [dict values [dict remove $leveldata ${$key}]] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } else { + lappend INDEX_OPERATIONS exactkey-get-value + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-value" + if {[dict exists $leveldata ${$key}]} { + set assigned [dict get $leveldata ${$key}] + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + } + {@\?@*} { + #exact key match - quiet get value + #silent empty result if non-existent key - silence when non-existent key also if using not-@?@badkey which will just return whole dict + #note - dict remove will raise error on non-dict-shaped value whilst dict exists will not + set active_key_type "dict" + set key [string range $index 3 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-value-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-value-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict values [dict remove $leveldata ${$key}]] + }] + } else { + lappend INDEX_OPERATIONS exactkey?-get-value + #dict exists test is safe - no need for catch + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-value + if {[dict exists $leveldata ]} { + set assigned [dict get $leveldata ] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + {@\?\?@*} { + #quiet get pairs + #this is silent too.. so how do we do a checked return of dict key+val? + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey?-get-pair-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey?-get-pair-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set assigned [dict remove $leveldata ${$key}] + }] + } else { + lappend INDEX_OPERATIONS exactkey?-get-pair + append script \n [string map [list $key] { + # set active_key_type "dict" index_operation: exactkey?-get-pair + if {[dict exists $leveldata ]} { + set assigned [dict create [dict get $leveldata ]] + } else { + set assigned [dict create] + } + }] + } + set level_script_complete 1 + } + @..@* {-} @kk@* {-} @KK@* { + #noisy get pairs by key + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + lappend INDEX_OPERATIONS exactkey-get-pairs-not + #review - dict remove allows silent call if key doesn't exist - but we are enforcing existence here + #this seems reasonable given we have an explicit @?@ syntax (nocomplain equivalent) and there could be a legitimate case for wanting a non-match if trying to return the complement of a non-existent key + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactkey-get-pairs-not + if {[dict exists $leveldata ${$key}]} { + set assigned [tcl::dict::remove $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } else { + lappend INDEX_OPERATIONS exactkey-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactkey-get-pairs" + if {[dict exists $leveldata ${$key}]} { + tcl::dict::set assigned ${$key} [tcl::dict::get $leveldata ${$key}] + } else { + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + } + @vv@* {-} @VV@* { + #noisy(?) get pairs by exact value + #return mismatch on non-match even when not- specified + set active_key_type "dict" + set keyglob [string range $index 4 end] + set active_key_type "dict" + set key [string range $index 4 end] + if {$get_not} { + #review - for consistency we are reporting a mismatch when the antikey being looked up doesn't exist + #The utility of this is debatable + lappend INDEX_OPERATIONS exactvalue-get-pairs-not + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: exactvalue-get-pairs-not + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set nonmatches [dict create] + tcl::dict::for {k v} $leveldata { + if {![string equal ${$key} $v]} { + dict set nonmatches $k $v + } + } + + if {[dict size $nonmatches] < [dict size $leveldata]} { + #our key matched something + set assigned $nonmatches + } else { + #our key didn't match anything - don't return the nonmatches + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } else { + lappend INDEX_OPERATIONS exactvalue-get-pairs + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict index_operation: exactvalue-get-pairs-not" + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matches [list] + tcl::dict::for {k v} $leveldata { + if {[string equal ${$key} $v]} { + lappend matches $k $v + } + } + if {[llength $matches]} { + set assigned $matches + } else { + #set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + set level_script_complete 1 + } + {@\*@*} {-} {@\*v@*} {-} {@\*V@*} { + #dict key glob - return values only + set active_key_type "dict" + if {[string match {@\*@*} $index]} { + set keyglob [string range $index 3 end] + } else { + #vV + set keyglob [string range $index 4 end] + } + #if $keyglob eq "" - needs to query for dict key that is empty string. + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-values-not + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + # set active_key_type "dict" index_operation: globkey-get-values-not + set matched [dict keys $leveldata {${$keyglob}}] + set assigned [dict values [dict remove $leveldata {*}$matched]] + }] + } else { + lappend INDEX_OPERATIONS globkey-get-values + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" index_operation: globkey-get-values + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + set matched [dict keys $leveldata {${$keyglob}}] + set assigned [list] + foreach m $matched { + lappend assigned [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + } + {@\*.@*} { + #dict key glob - return pairs + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-pairs-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-pairs-not + set matched [dict keys $leveldata {}] + set assigned [dict remove $leveldata {*}$matched] + }] + } else { + lappend INDEX_OPERATIONS globkey-get-pairs + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operations: globkey-get-pairs + set matched [dict keys $leveldata {}] + set assigned [dict create] + foreach m $matched { + dict set assigned $m [dict get $leveldata $m] + } + }] + } + set level_script_complete 1 + } + {@\*k@*} {-} {@\*K@*} { + #dict key glob - return keys + set active_key_type "dict" + set keyglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkey-get-keys-not + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys-not + set matched [dict keys $leveldata {}] + set assigned [dict keys [dict remove $leveldata {*}$matched]] + }] + } else { + lappend INDEX_OPERATIONS globkey-get-keys + append script \n [string map [list $keyglob] { + # set active_key_type "dict" index_operation: globkey-get-keys + set assigned [dict keys $leveldata {}] + }] + } + set level_script_complete 1 + } + {@k\*@*} {-} {@K\*@*} { + #dict value glob - return keys + set active_key_type "dict" + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-keys-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + lappend assigned $k + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-keys + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-keys + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {[string match {} $v]} { + lappend assigned $k + } + } + }] + } + set level_script_complete 1 + } + {@.\*@*} { + #dict value glob - return pairs + set active_key_type "dict" + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-pairs-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs-not + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + dict set assigned $k $v + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-pairs + append script \n [string map [list $valglob] { + # set active_key_type "dict" index_operation: globvalue-get-pairs + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match {} $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + } + {@V\*@*} {-} {@v\*@*} { + #dict value glob - return values + set active_key_type dict + set valglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globvalue-get-values-not + append script \n [string map [list $valglob] { + # set active_key_type "dict" ;# index_operation: globvalue-get-values-not + set assigned [list] + tcl::dict::for {k v} $leveldata { + if {![string match {} $v]} { + lappend assigned $v + } + } + }] + } else { + lappend INDEX_OPERATIONS globvalue-get-values + append script \n [string map [list $valglob] { + # set active_key_type "dict" ;#index_operation: globvalue-get-value + set assigned [dict values $leveldata ] + }] + } + set level_script_complete 1 + } + {@\*\*@*} { + #dict val/key glob return pairs) + set active_key_type "dict" + set keyvalglob [string range $index 4 end] + append script [tstr -return string -allowcommands { + if {[catch {dict size $leveldata}]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } + }] + if {$get_not} { + lappend INDEX_OPERATIONS globkeyvalue-get-pairs-not + error "globkeyvalue-get-pairs-not todo" + } else { + lappend INDEX_OPERATIONS globkeyvalue-get-pairs + append script \n [string map [list $keyvalglob] { + # set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not + set assigned [dict create] + tcl::dict::for {k v} $leveldata { + if {[string match {} $k] || [string match {} $v]} { + dict set assigned $k $v + } + } + }] + } + set level_script_complete 1 + puts stderr "globkeyvalue-get-pairs review" + } + @* { + set active_key_type "list" + set do_bounds_check 1 + + set index [string trimleft $index @] + append script \n [string map [list $index] { + # set active_key_type "list" index_operation: ? + set index + }] + } + %* { + set active_key_type "string" + set do_bounds_check 0 + set index [string range $index 1 end] + append script \n [string map [list $index] { + # set active_key_type "string" index_operation: ? + set index + }] + } + default { + puts "destructure_func_build_body unmatched index $index" + } + } + } + } + + if {!$level_script_complete} { + #keyword 'pipesyntax' at beginning of error message + set listmsg "pipesyntax Unable to interpret subindex $index\n" + append listmsg "selector: '$selector'\n" + append listmsg "@ must be followed by a selector (possibly compound separated by forward slashes) suitable for lindex or lrange commands, or a not-x expression\n" + append listmsg "Additional accepted keywords include: head tail\n" + append listmsg "Use var@@key to treat value as a dict and retrieve element at key" + + #append script \n [string map [list $listmsg] {set listmsg ""}] + + + #we can't just set 'assigned' for a position spec for in/ni (not-in) because we don't have the value here to test against + #need to set a corresponding action + if {$active_key_type in [list "" "list"]} { + set active_key_type "list" + append script \n {# set active_key_type "list"} + #for pattern matching purposes - head/tail not valid on empty lists (similar to elixir) + switch -exact -- $index { + 0 { + if {$get_not} { + append script \n "# index_operation listindex-int-not" \n + lappend INDEX_OPERATIONS listindex-zero-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + lappend INDEX_OPERATIONS listindex-zero + set assignment_script {set assigned [lindex $leveldata 0]} + if {$do_bounds_check} { + append script \n "# index_operation listindex-int (bounds checked)" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {[llength $leveldata] == 0} { + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n "# index_operation listindex-int" \n + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + } + head { + #NOTE: /@head and /head both do bounds check. This is intentional + if {$get_not} { + append script \n "# index_operation listindex-head-not" \n + lappend INDEX_OPERATIONS listindex-head-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-head" \n + lappend INDEX_OPERATIONS listindex-head + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range-empty + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + #alias for 0 - for h@head,t@tail= similar to erlang/elixir hd() tl() or [head | tail] = list syntax + ${$assignment_script} + } + }] + } + end { + if {$get_not} { + append script \n "# index_operation listindex-end-not" \n + lappend INDEX_OPERATIONS listindex-end-not + #on single element list Tcl's lrange will do what we want here and return nothing + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } else { + append script \n "# index_operation listindex-end" \n + lappend INDEX_OPERATIONS listindex-end + set assignment_script {set assigned [lindex $leveldata end]} + } + if {$do_bounds_check} { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + } + tail { + #NOTE: /@tail and /tail both do bounds check. This is intentional. + # + #tail is a little different in that we allow tail on a single element list - returning an empty result - but it can't be called on an empty list + #arguably tail could be considered as an index-out-of-range for less than 2 elements - but this would be less useful, and surprising to those coming from other pattern-matching systems. + #In this way tail is different to @1-end + if {$get_not} { + append script \n "# index_operation listindex-tail-not" \n + lappend INDEX_OPERATIONS listindex-tail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-tail" \n + lappend INDEX_OPERATIONS listindex-tail + set assignment_script {set assigned [lrange $leveldata 1 end] ;#return zero or more elements - but only if there is something (a head) at position zero} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } elseif {$len == 0} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range_empty]} + } else { + ${$assignment_script} + } + }] + } + anyhead { + #allow returning of head or nothing if empty list + if {$get_not} { + append script \n "# index_operation listindex-anyhead-not" \n + lappend INDEX_OPERATIONS listindex-anyhead-not + set assignment_script {set assigned [lrange $leveldata 1 end]} + } else { + append script \n "# index_operation listindex-anyhead" \n + lappend INDEX_OPERATIONS listindex-anyhead + set assignment_script {set assigned [lindex $leveldata 0]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + anytail { + #allow returning of tail or nothing if empty list + #anytail will return empty both for empty list, or single element list - but potentially useful in combination with anyhead. + if {$get_not} { + append script \n "# index_operation listindex-anytail-not" \n + lappend INDEX_OPERATIONS listindex-anytail-not + set assignment_script {set assigned [lindex $leveldata 0]} + } else { + append script \n "# index_operation listindex-anytail" \n + lappend INDEX_OPERATIONS listindex-anytail + set assignment_script {set assigned [lrange $leveldata 1 end]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + init { + #all but last element - same as haskell 'init' + #counterintuitively, get-notinit can therefore return first element if it is a single element list + #does bounds_check for get-not@init make sense here? maybe - review + if {$get_not} { + append script \n "# index_operation listindex-init-not" \n + lappend INDEX_OPERATIONS listindex-init-not + set assignment_script {set assigned [lindex $leveldata end]} + } else { + append script \n "# index_operation listindex-init" \n + lappend INDEX_OPERATIONS listindex-init + set assignment_script {set assigned [lrange $leveldata 0 end-1]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + list { + #get_not? + #allow returning of entire list even if empty + if {$get_not} { + lappend INDEX_OPERATIONS list-getall-not + set assignment_script {set assigned {}} + } else { + lappend INDEX_OPERATIONS list-getall + set assignment_script {set assigned $leveldata} + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assignment_script} + } + }] + } + raw { + #get_not - return nothing?? + #no list checking.. + if {$get_not} { + lappend INDEX_OPERATIONS getraw-not + append script \n {set assigned {}} + } else { + lappend INDEX_OPERATIONS getraw + append script \n {set assigned $leveldata} + } + } + keys { + #@get_not?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getkeys-not + set assignment_script {set assigned [dict values $leveldata]} ;#not-keys is equivalent to values + } else { + lappend INDEX_OPERATIONS list-getkeys + set assignment_script {set assigned [dict keys $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + values { + #get_not ?? + #need active_key_type of 'list' for 'keys' and 'values' keywords which act on either dict or a list with even number of elements + if {$get_not} { + lappend INDEX_OPERATIONS list-getvalues-not + set assignment_script {set assigned [dict keys $leveldata]} ;#not-values is equivalent to keys + } else { + lappend INDEX_OPERATIONS list-getvalues + set assignment_script {set assigned [dict values $leveldata]} + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + ${$assignment_script} + } + }] + } + pairs { + #get_not ?? + if {$get_not} { + #review - return empty list instead like not-list and not-raw? + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector not-pairs_not_supported] + } else { + lappend INDEX_OPERATIONS list-getpairs + } + append script \n [tstr -return string -allowcommands { + if {[catch {dict size $leveldata} dsize]} { + #set action ?mismatch-not-a-dict + ${[tstr -ret string $tpl_return_mismatch_not_a_dict]} + } else { + set pairs [list] + tcl::dict::for {k v} $leveldata {lappend pairs [list $k $v]} + set assigned [lindex [list $pairs [unset pairs]] 0] + } + }] + } + default { + if {[regexp {[?*]} $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listsearch-not + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline -not $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listsearch + set assign_script [string map [list $index] { + set assigned [lsearch -all -inline $leveldata ] + }] + } + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } elseif {[string is integer -strict $index]} { + if {$get_not} { + lappend INDEX_OPERATIONS listindex-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex + set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + if {$index < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector index_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + set max [expr {$index + 1}] + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + # bounds_check due to @ directly specified in original index section + if {${$max} > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + } elseif {[string first "end" $index] >= 0} { + if {[regexp {^end([-+]{1,2}[0-9]+)$} $index _match endspec]} { + if {$get_not} { + lappend INDEX_OPERATIONS listindex-endoffset-not + set assign_script [string map [list $index] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS listindex-endoffset + set assign_script [string map [list $index] {set assigned [lindex $leveldata ]}] + } + + if {$do_bounds_check} { + #tstr won't add braces - so the ${$endspec} value inserted in the expr will remain unbraced as required in this case. + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + set action ?mismatch-not-a-list + } else { + #bounds-check is true + #leave the - from the end- as part of the offset + set offset [expr ${$endspec}] ;#don't brace! + if {($offset > 0 || abs($offset) >= $len)} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } else { + ${$assign_script} + } + } + }] + } else { + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } else { + ${$assign_script} + } + }] + } + } elseif {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + set assign_script [string map [list $start $end] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + lappend INDEX_OPERATIONS list-range + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + + append script \n [tstr -ret string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + if {$do_bounds_check} { + if {[string is integer -strict $start]} { + if {$start < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector start_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set start ${$start} + if {$start+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$start eq "end"} { + #noop + } else { + set startoffset [string range $start 3 end] ;#include the - from end- + set startoffset [expr $startoffset] ;#don't brace! + if {$startoffset > 0} { + #e.g end+1 + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set startoffset ${$startoffset} + if {abs($startoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + if {[string is integer -strict $end]} { + if {$end < 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end_lessthanzero_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set end ${$end} + if {$end+1 > $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } elseif {$end eq "end"} { + #noop + } else { + set endoffset [string range $end 3 end] ;#include the - from end- + + set endoffset [expr $endoffset] ;#don't brace! + if {$endoffset > 0} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector end+x_out_of_bounds_for_all_data_while_bounds_check_on] + } + append script \n [tstr -return string -allowcommands { + set endoffset ${$endoffset} + if {abs($endoffset) >= $len} { + #set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + } else { + #fail now - no need for script + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } elseif {[string first - $index] > 0} { + #e.g @1-3 gets here + #JMN + if {$get_not} { + lappend INDEX_OPERATIONS list-range-not + } else { + lappend INDEX_OPERATIONS list-range + } + + append script \n [tstr -return string -allowcommands { + if {[catch {llength $leveldata} len]} { + #set action ?mismatch-not-a-list + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } + }] + + #handle pure int-int ranges separately + set testindex [string map [list - "" + ""] $index] + if {[string is digit -strict $testindex]} { + #don't worry about leading - negative value for indices not valid anyway + set parts [split $index -] + if {[llength $parts] != 2} { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + lassign $parts start end + + #review - Tcl lrange just returns nothing silently. + #if we don't intend to implement reverse indexing - we should probably not emit an error + if {$start > $end} { + puts stderr "pipesyntax for selector $selector error - reverse index unimplemented" + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + if {$do_bounds_check} { + #append script [string map [list $start $end] { + # set start + # set end + # if {$start+1 > $len || $end+1 > $len} { + # set action ?mismatch-list-index-out-of-range + # } + #}] + #set eplusone [expr {$end+1}] + append script [tstr -return string -allowcommands { + if {$len < ${[expr {$end+1}]}} { + set action ?mismatch-list-index-out-of-range + ${[tstr -ret string $tpl_return_mismatch_list_index_out_of_range]} + } + }] + } + + + if {$get_not} { + set assign_script [string map [list $start $end] { + #not- was specified (already handled not-0) + set assigned [lreplace $leveldata ] + }] + } else { + set assign_script [string map [list $start $end] {set assigned [lrange $leveldata ]}] + } + } else { + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + + append script \n [string map [list $assign_script] { + if {![string match ?mismatch-* $action]} { + + } + }] + } else { + #keyword 'pipesyntax' at beginning of error message + #pipesyntax error - no need to even build script - can fail now + error $listmsg "destructure $selector" [list pipesyntax destructure selector $selector] + } + } + } + } elseif {$active_key_type eq "string"} { + if {[string match *-* $index]} { + lappend INDEX_OPERATIONS string-range + set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + #todo - support more complex indices: 0-end-1 etc + + lassign [split $index -] a b + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned [string range $leveldata ${$a} ${$b}] + }] + } else { + if {$index eq "*"} { + lappend INDEX_OPERATIONS string-all + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned $leveldata + }] + } elseif {[regexp {[?*]} $index]} { + lappend INDEX_OPERATIONS string-globmatch + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + if {[string match $index $leveldata]} { + set assigned $leveldata + } else { + set assigned "" + } + }] + } else { + lappend INDEX_OPERATIONS string-index + append script \n [tstr -return string -allowcommands { + # set active_key_type "string" + set assigned [string index $leveldata ${$index}] + }] + } + } + } else { + #treat as dict key + if {$get_not} { + #dict remove can accept non-existent keys.. review do we require not-@?@key to get silence? + append script \n [tstr -return string { + set assigned [dict remove $leveldata ${$index}] + }] + } else { + append script \n [tstr -return string -allowcommands { + # set active_key_type "dict" + if {[dict exists $leveldata {${$index}}]} { + set assigned [dict get $leveldata {${$index}}] + } else { + set action ?mismatch-dict-key-not-found + ${[tstr -ret string $tpl_return_mismatch_dict_key_not_found]} + } + }] + } + } + } ;# end if $level_script_complete + + + append script \n { + set leveldata $assigned + } + incr i_keyindex + append script \n "# ------- END index $index ------" + } ;# end foreach + + + #puts stdout "----> destructure rep leveldata: [rep $leveldata]" + #puts stdout ">> destructure returning: [dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs]" + + #maintain key order - caller unpacks using lassign + #append script \n {dict create -assigned $leveldata -action $action -lhs $lhs -rhs $rhs} + append script \n [tstr -return string $return_template] \n + return $script + } + + + #called from match_assign/know_dot_assign for lhs of assignment - uplevel 2 to caller's level + #called from match_assign/know_dot_assign for rhs pipelined vars - uplevel 1 to write vars only in 'apply' scope + #return a dict with keys result, setvars, unsetvars + #TODO - implement cross-binding (as opposed to overwrite/reassignment) when a var appears multiple times in a pattern/multivar + #e.g x@0,x@1 will only match if value at positions 0 & 1 is the same (a form of auto-pinning?) + #e.g x,x@0 will only match a single element list + #todo blocking or - p1|p2 if p1 matches - return p1 and continue pipeline - immediately return p2 if p1 didn't match. (ie p2 not forwarded in pipeline) + # non-blocking or - p1||p2 if p1 matches - return p1 and continue pipeline - else match p2 and continue pipeline + proc _multi_bind_result {multivar data args} { + #puts stdout "---- _multi_bind_result multivar:'$multivar' data:'$data' options:'$args'" + #'ismatch' must always be first element of dict - as we dispatch on ismatch 0 or ismatch 1 + if {![string length $multivar]} { + #treat the absence of a pattern as a match to anything + #JMN2 - changed to list based destructuring + return [dict create ismatch 1 result $data setvars {} script {}] + #return [dict create ismatch 1 result [list $data] setvars {} script {}] + } + set returndict [dict create ismatch 0 result "" setvars {}] + set script "" + + set defaults [list -unset 0 -levelup 2 -mismatchinfo 1 -script 0] + set opts [dict merge $defaults $args] + set unset [dict get $opts -unset] + set lvlup [dict get $opts -levelup] + set get_mismatchinfo [dict get $opts -mismatchinfo] + + + #first classify into var_returntype of either "pipeline" or "segment" + #segment returntype is indicated by leading % + + set varinfo [punk::pipe::lib::_var_classify $multivar] + set var_names [dict get $varinfo var_names] + set var_class [dict get $varinfo var_class] + set varspecs_trimmed [dict get $varinfo varspecs_trimmed] + + set var_actions [list] + set expected_values [list] + #e.g {a = abc} {b set ""} + foreach classinfo $var_class vname $var_names { + lassign [lindex $classinfo 0] v + lappend var_actions [list $v "" ""] ;#varactions keeps original lhs - not trimmed version + lappend expected_values [list var $vname spec $v info - lhs - rhs -] ;#code looks for 'info -' to see if changed from default + } + + #puts stdout "var_actions: $var_actions" + #puts stdout "expected_values: $expected_values" + + + #puts stdout "\n var_class: $var_class\n" + # e.g {{x {}} 0} {{y @0} 0} {{'ok @0} 1} {{^v @@key} 2} + + #set varspecs_trimmed [lmap varinfo $var_class {expr {([lindex $varinfo 1] > 0) ? [list [string range [lindex $varinfo 0 0] 1 end] [lindex $varinfo 0 1]] : [lindex $varinfo 0]}}] + #puts stdout "\n varspecs_trimmed: $varspecs_trimmed\n" + + + #var names (possibly empty portion to the left of ) + #debug.punk.pipe.var "varnames: $var_names" 4 + + set v_list_idx(@) 0 ;#for spec with single @ only + set v_dict_idx(@@) 0 ;#for spec with @@ only + + #jn + + #member lists of returndict which will be appended to in the initial value-retrieving loop + set returndict_setvars [dict get $returndict setvars] + + set assigned_values [list] + + + #varname action value - where value is value to be set if action is set + #actions: + # "" unconfigured - assert none remain unconfigured at end + # noop no-change + # matchvar-set name is a var to be matched + # matchatom-set names is an atom to be matched + # matchglob-set + # set + # question mark versions are temporary - awaiting a check of action vs var_class + # e.g ?set may be changed to matchvar or matchatom or set + + + debug.punk.pipe.var {initial map expected_values: $expected_values} 5 + + set returnval "" + set i 0 + #assertion i incremented at each continue and at each end of loop - at end i == list length + 1 + #always use 'assigned' var in each loop + # (for consistency and to assist with returnval) + # ^var means a pinned variable - compare value of $var to rhs - don't assign + # + # In this loop we don't set variables - but assign an action entry in var_actions - all with leading question mark. + # as well as adding the data values to the var_actions list + # + # TODO! we may (commonly) encounter same vkey in the pattern - no need to reparse and re-fetch from data! + set vkeys_seen [list] + foreach v_and_key $varspecs_trimmed { + set vspec [join $v_and_key ""] + lassign $v_and_key v vkey + + set assigned "" + #The binding spec begins at first @ or # or / + + #set firstq [string first "'" $vspec] + #set v [lindex $var_names $i] + #if v contains any * and/or ? - then it is a glob match - not a varname + + lassign [destructure_func $vkey $data] _assigned assigned _action matchaction _lhs lhs _rhs rhs + if {$matchaction eq "?match"} { + set matchaction "?set" + } + lset var_actions $i 1 $matchaction + lset var_actions $i 2 $assigned + + #update the setvars/unsetvars elements + if {[string length $v]} { + dict set returndict_setvars $v $assigned + } + + #JMN2 + #special case expansion for empty varspec (e.g , or ,,) + #if {$vspec eq ""} { + # lappend assigned_values {*}$assigned + #} else { + lappend assigned_values $assigned + #} + incr i + } + + #todo - fix! this isn't the actual tclvars that were set! + dict set returndict setvars $returndict_setvars + + #assigned_values is the ordered list of source elements in the data (rhs) as extracted by each position-spec + #For booleans the final val may later be normalised to 0 or 1 + + + #assertion all var_actions were set with leading question mark + #perform assignments only if matched ok + + + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + if 0 { + debug.punk.pipe.var {VAR_CLASS: $var_class} 5 + debug.punk.pipe.var {VARACTIONS: $var_actions} 5 + debug.punk.pipe.var {VARSPECS_TRIMMED: $varspecs_trimmed} 5 + + debug.punk.pipe.var {atoms: [lsearch -all -inline -index 1 $var_class 1]} 5 + debug.punk.pipe.var {pins: [lsearch -all -inline -index 1 $var_class 2]} 5 + debug.punk.pipe.var {bools: [lsearch -all -inline -index 1 $var_class 3]} 5 + debug.punk.pipe.var {ints: [lsearch -all -inline -index 1 $var_class 4]} 5 + debug.punk.pipe.var {doubles: [lsearch -all -inline -index 1 $var_class 5]} 5 + debug.punk.pipe.var {vars: [lsearch -all -inline -index 1 $var_class 6]} 5 + debug.punk.pipe.var {globs: [lsearch -all -inline -index 1 $var_class 7]} 5 + } + + set match_state [lrepeat [llength $var_names] ?] + unset -nocomplain v + unset -nocomplain nm + set mismatched [list] + set i 0 + #todo - stop at first mismatch - for pattern matching (especially pipecase - we don't want to waste time reading vars if we already have a mismatch earlier in the pattern) + foreach va $var_actions { + #val comes from -assigned + lassign $va lhsspec act val ;#lhsspec is the full value source for LHS ie the full atom/number/varspec e.g for pattern ^var@@key/@0 it is "^var" + set varname [lindex $var_names $i] + + if {[string match "?mismatch*" $act]} { + #already determined a mismatch - e.g list or dict key not present + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch lhs ? rhs $val] + break + } + + + set class_key [lindex $var_class $i 1] + lassign {0 0 0 0 0 0 0 0 0 0} isatom ispin isbool isint isdouble isvar isglob isnumeric isgreaterthan islessthan + foreach ck $class_key { + switch -- $ck { + 1 {set isatom 1} + 2 {set ispin 1} + 3 {set isbool 1} + 4 {set isint 1} + 5 {set isdouble 1} + 6 {set isvar 1} + 7 {set isglob 1} + 8 {set isnumeric 1} + 9 {set isgreaterthan 1} + 10 {set islessthan 1} + } + } + + + #set isatom [expr {$class_key == 1}] + #set ispin [expr {2 in $class_key}] + #set isbool [expr {3 in $class_key}] + #set isint [expr {4 in $class_key}] + #set isdouble [expr {5 in $class_key}] + #set isvar [expr {$class_key == 6}] + #set isglob [expr {7 in $class_key}] + #set isnumeric [expr {8 in $class_key}] ;#force numeric comparison (only if # classifier present) + ##marking numbers with pin ^ has undetermined meaning. Perhaps force expr matching only? + #set isgreaterthan [expr {9 in $class_key}] + #set islessthan [expr {10 in $class_key}] + + + if {$isatom} { + #puts stdout "==>isatom $lhsspec" + set lhs [string range $lhsspec 1 end] + if {[string index $lhs end] eq "'"} { + set lhs [string range $lhs 0 end-1] + } + lset var_actions $i 1 matchatom-set + if {$lhs eq $val} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match lhs $lhs rhs $val] + incr i + continue + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info strings-not-equal lhs $lhs rhs $val] + break + } + } + + + # - should set expected_values in each branch where match_state is not set to 1 + # - setting expected_values when match_state is set to 0 is ok except for performance + + + #todo - pinned booleans? we would need to disambiguate from a direct value match.. ie double tag as something like: ^&var or + #ispin may reclassify as isint,isdouble based on contained value (as they don't have their own classifier char and are unambiguous and require special handling) + if {$ispin} { + #puts stdout "==>ispin $lhsspec" + if {$act in [list "?set" "?matchvar-set"]} { + lset var_actions $i 1 matchvar-set + #attempt to read + upvar $lvlup $varname the_var + #if {![catch {uplevel $lvlup [list ::set $varname]} existingval]} {} + if {![catch {set the_var} existingval]} { + if {$isbool} { + #isbool due to 2nd classifier i.e ^& + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-bool lhs $existingval rhs $val] + #normalise to LHS! + lset assigned_values $i $existingval + } elseif {$isglob} { + #isglob due to 2nd classifier ^* + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-glob lhs $existingval rhs $val] + } elseif {$isnumeric} { + #flagged as numeric by user using ^# classifiers + set testexistingval [join [scan $existingval %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + if {[string is integer -strict $testexistingval]} { + set isint 1 + lset assigned_values $i $existingval + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-int lhs $existingval rhs $val] + } elseif {[string is double $existingval] || [string is double -strict $testexistingval]} { + #test existingval in case something like .5 (which scan will have missed - producing empty testexistingval) + set isdouble 1 + #doubles comparisons use float_almost_equal - so lhs can differ from rhs - for pins we always want to return the normalised lhs ie exactly what is in the var + lset assigned_values $i $existingval + + lset expected_values $i [list var $varname spec $lhsspec info test-lhs-double lhs $existingval rhs $val] + } else { + #user's variable doesn't seem to have a numeric value + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-lhs-not-numeric lhs $existingval rhs $val] + break + } + } else { + #standard pin - single classifier ^var + lset match_state $i [expr {$existingval eq $val}] + if {![lindex $match_state $i]} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-not-equal" lhs $existingval rhs $val] + break + } else { + lset expected_values $i [list var $varname spec $lhsspec info "string-compare-equal" lhs $existingval rhs $val] + } + } + } else { + #puts stdout "pinned var $varname result:$result vs val:$val" + #failure is *probably* because var is unset - but could be a read-only var due to read-trace or it could be nonexistant namespace + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info failread-$varname lhs ? rhs $val] + break + } + } + } + + + if {$isint} { + #note - we can have classified (above) a value such as 08 on lhs as integer - even though expr and string is integer don't do so. + #expected_values $i [list var $varname spec $lhsspec info match-lhs-int lhs $existingval rhs $val] + + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $lhs 0] eq "."} { + set testlhs $lhs + } else { + set testlhs [join [scan $lhs %lld%s] ""] + } + if {[string index $val 0] eq "."} { + set testval $val + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros) and bignums (not leading .) + } + if {[string is integer -strict $testval]} { + if {$isgreaterthan} { + #puts "lhsspec: $lhsspec testlhs: $testlhs testval: $testval" + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-int" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-int" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-int" lhs $lhs rhs $val] + break + } + } + } elseif {[string is double -strict $testval]} { + #dragons. (and shimmering) + if {[string first "e" $val] != -1} { + #scientific notation - let expr compare + if {$isgreaterhthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-sci" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-sci" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-sci" lhs $lhs rhs $val] + break + } + } + } elseif {[string is digit -strict [string trim $val -]]} { + #probably a wideint or bignum with no decimal point + #It seems odd that bignums which just look like large integers should ever compare equal if you do a +1 to one side . + #if we use float_almost_equal they may compare equal. on the other hand expr also does apparently inconsistent thins with comparing integer-like bignums vs similar sized nums with .x at the end. + #2 values further apart can compare equal while int-like ones closer together can compare different. + #The rule seems to be for bignums that if it *looks* like a whole int the comparison is exact - but otherwise the float behaviours kick in. + #This is basically what we're doing here but with an arguably better (for some purposes!) float comparison. + #string comparison can presumably always be used as an alternative. + # + #let expr compare + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-puredigits" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-puredigits" lhs $lhs rhs $val] + break + } + } else { + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-int-puredigits" lhs $lhs rhs $val] + break + } + } + } else { + if {[punk::pipe::float_almost_equal $testlhs $testval]} { + lset match_state $i 1 + } else { + if {$isgreaterthan} { + if {$testlhs <= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-greater-than-int-float" lhs $lhs rhs $val] + break + } + } elseif {$islessthan} { + if {$testlhs >= $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-not-less-than-int-float" lhs $lhs rhs $val] + break + } + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "float_almost_equal-mismatch-int-float" lhs $lhs rhs $val] + break + } + } + } + } else { + #e.g rhs not a number.. + if {$testlhs == $testval} { + lset match_state $i 1 + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "expr-mismatch-unknown-rhstestval-$testval" lhs $lhs rhs $val] + break + } + } + } elseif {$isdouble} { + #dragons (and shimmering) + # + # + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal integer in the pattern + } + if {$isgreaterthan || $islessthan} { + error "+/- not yet supported for lhs float" + set lhs [string range $lhsspec 0 end-1] + set testlhs $lhs + } + if {[string index $val 0] eq "."} { + set testval $val ;#not something with some number of leading zeros + } else { + set testval [join [scan $val %lld%s] ""] ;# handles octals (leading zeros), ok for use with bignums, internal decimal points and sci notation (but not leading .) + } + #expr handles leading 08.1 0009.1 etc without triggering octal + #so we don't need to scan lhs + if {[string first "e" $lhs] >= 0 || [string first "e" $testval] >= 0} { + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-sci lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-sci lhs $lhs rhs $val] + break + } + } elseif {[string is digit -strict [string trim $lhs -]] && [string is digit -strict [string trim $val -]]} { + #both look like big whole numbers.. let expr compare using it's bignum capability + if {$lhs == $testval} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-expr-pure-digits lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-expr-pure-digits lhs $lhs rhs $val] + break + } + } else { + #float_almost_equal will disagree with expr based on scale.. just enough to allow for example [expr 0.2 + 0.1] to equal 0.3 - whereas expr will declare a mismatch + if {[punk::pipe::float_almost_equal $lhs $testval]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-float-almost-equal lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-float-almost-equal lhs $lhs rhs $val] + break + } + } + } elseif {$isbool} { + #Note - cross binding of booleans deliberately doesn't compare actual underlying values - only that truthiness or falsiness matches. + #e.g &x/0,&x/1,&x/2= {1 2 yes} + # all resolve to true so the cross-binding is ok. + # Also - the setting of the variable x is normalized to 1 or 0 only. (true & false would perhaps be nicer - but 1 & 0 are theoretically more efficient for later comparisons as they can have a pure int rep?.) + # todo - consider the booleanString rep. Can/should we return true & false instead and maintain efficiency w.r.t shimmering? + # + #punk::pipe::boolean_equal $a $b + set extra_match_info "" ;# possible crossbind indication + set is_literal_boolean 0 + if {$ispin} { + #for a pinned boolean - the most useful return is the value in the pinned var rather than the rhs. This is not entirely consistent .. e.g pinned numbers will return rhs !review! + #As an additional pattern can always retrieve the raw value - pinned vars returning themselves (normalisation use-case ) seems the most consistent overall, and the most useful + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs [string range $lhsspec 1 end] ;# - strip off & classifier prefix + + if {![string length $lhs]} { + #empty varname - ok + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 "return-normalised-value" + lset assigned_values $i [expr {bool($val)}] + lset expected_values $i [list var $varname spec $lhsspec info "return-boolean-rhs-normalised" lhs - rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs" lhs - rhs $val] + break + } + } elseif {$lhs in [list 0 1]} { + #0 & 1 are the only literal numbers that satisfy Tcl's 'string is boolean' test. + set is_literal_boolean 1 + } elseif {[string index $lhs 0] eq "'" && [string index $lhs end] eq "'"} { + #literal boolean (&'yes',&'false',&'1',&'0' etc) in the pattern + #we won't waste any cycles doing an extra validity test here - it will fail in the comparison below if not a string understood by Tcl to represent a boolean. + set is_literal_boolean 1 + set lhs [string range $lhs 1 end-1] ;#strip off squotes + } else { + #todo - a standard variable name checking function for consistency.. for now we'll rule out numbers here to help avoid mistakes. + set tclvar $lhs + if {[string is double $tclvar]} { + error "pipesyntax invalid variable name '$tclvar' for boolean in pattern. (subset of legal tcl vars allowed in pattern context)" "_multi_bind_result $multivar $data $args" [list pipesyntax patternvariable invalid_boolean $tclvar] + #proc _multi_bind_result {multivar data args} + } + #treat as variable - need to check cross-binding within this pattern group + set first_bound [lsearch -index 0 $var_actions $lhsspec] + if {$first_bound == $i} { + #test only rhs (val) for boolean-ness - but boolean-ness as boolean_almost_equal understands it. (e.g floats allowed) + if {[string is boolean -strict $val] || [string is double -strict $val]} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# should now be the value "set". We only need this on the first_bound + #review - consider what happens if boolean is leftmost pattern - underlying value vs normalised value to continue in pipeline + #Passing underlying value is inconsistent with what goes in the tclvar - so we need to update the returnval + #puts stderr "==========[lindex $assigned_values $i]" + lset var_actions $i 2 [expr {bool($val)}] ;#normalise to 1 or 0 + lset assigned_values $i [lindex $var_actions $i 2] + #puts stderr "==========[lindex $assigned_values $i]" + lset expected_values $i [list var $varname spec $lhsspec info "match-boolean-rhs-any-lhs" lhs - rhs $val] ;#retain underlying val in expected_values for diagnostics. + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-boolean-rhs-any-lhs" lhs - rhs $val] + break + } + } else { + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + set extra_match_info "-crossbind-first" + set lhs $expected_earlier + } + } + } + + + #may have already matched above..(for variable) + if {[lindex $match_state $i] != 1} { + if {![catch {punk::pipe::boolean_almost_equal $lhs $val} ismatch]} { + if {$ismatch} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info match-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info mismatch-boolean-almost-equal$extra_match_info lhs $lhs rhs $val] + break + } + } else { + #we should only error from boolean_equal if passed something Tcl doesn't recognise as a boolean + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info badvalue-boolean$extra_match_info lhs $lhs rhs $val] + break + } + } + } elseif {$isglob} { + if {$ispin} { + set existing_expected [lindex $expected_values $i] + set lhs [dict get $existing_expected lhs] + } else { + set lhs $lhsspec ;#literal glob in the pattern - no classifier prefix + } + if {[string match $lhs $val]} { + lset match_state $i 1 + lset expected_values $i [list var $varname spec $lhsspec info "match-glob" lhs $lhs rhs $val] + } else { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-glob" lhs $lhs rhs $val] + break + } + } elseif {$ispin} { + #handled above.. leave case in place so we don't run else for pins + } else { + #puts stdout "==> $lhsspec" + #NOTE - pinned var of same name is independent! + #ie ^x shouldn't look at earlier x bindings in same pattern + #unpinned non-atoms + #cross-binding. Within this multivar pattern group only (use pin ^ for binding to result from a previous pattern) + # + switch -- $varname { + "" { + #don't attempt cross-bind on empty-varname + lset match_state $i 1 + #don't change var_action $i 1 to set + lset expected_values $i [list var $varname spec $lhsspec info "match-no-lhs-var" lhs - rhs $val] + } + "_" { + #don't cross-bind on the special 'don't-care' varname + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs-dontcare-var" lhs - rhs $val] + } + default { + set first_bound [lsearch -index 0 $var_actions $varname] + #assertion first_bound >=0, we will always find something - usually self + if {$first_bound == $i} { + lset match_state $i 1 + lset var_actions $i 1 [string range $act 1 end] ;# ?set -> set + lset expected_values $i [list var $varname spec $lhsspec info "match-any-lhs" lhs - rhs $val] + } else { + assert {$first_bound < $i} assertion_fail: _multi_bind_result condition: [list $first_bound < $i] + set expectedinfo [lindex $expected_values $first_bound] + set expected_earlier [dict get $expectedinfo rhs] + if {$expected_earlier ne $val} { + lset match_state $i 0 + lset expected_values $i [list var $varname spec $lhsspec info "mismatch-crossbind-first" lhs $expected_earlier rhs $val] + break + } else { + lset match_state $i 1 + #don't convert ?set to set - or var setter will write for each crossbound instance. Possibly no big deal for performance - but could trigger unnecessary write traces for example + #lset var_actions $i 1 [string range $act 1 end] + lset expected_values $i [list var $varname spec $lhsspec info "match-crossbind-first" lhs $expected_earlier rhs $val] + } + } + } + } + } + + incr i + } + + #JMN2 - review + #set returnval [lindex $assigned_values 0] + if {[llength $assigned_values] == 1} { + set returnval [join $assigned_values] + } else { + set returnval $assigned_values + } + #puts stdout "----> > rep returnval: [rep $returnval]" + + + #-------------------------------------------------------------------------- + #Variable assignments (set) should only occur down here, and only if we have a match + #-------------------------------------------------------------------------- + set match_count_needed [llength $var_actions] + #set match_count [expr [join $match_state +]] ;#expr must be unbraced here + set matches [lsearch -all -inline $match_state 1] ;#default value for each match_state entry is "?" + set match_count [llength $matches] + + + debug.punk.pipe.var {MATCH_STATE: $match_state count_needed: $match_count_needed vs match_count: $match_count} 4 + debug.punk.pipe.var {VARACTIONS2: $var_actions} 5 + debug.punk.pipe.var {EXPECTED : $expected_values} 4 + + #set match_count [>f . foldl 0 [>f . sum .] $match_state] ;#ok method.. but slow compared to expr with join + if {$match_count == $match_count_needed} { + #do assignments + for {set i 0} {$i < [llength $var_actions]} {incr i} { + if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3) && ([string length [set varname [lindex $var_names $i]]])} { + #isvar + if {[lindex $var_actions $i 1] eq "set"} { + upvar $lvlup $varname the_var + set the_var [lindex $var_actions $i 2] + } + } + } + dict set returndict ismatch 1 + #set i 0 + #foreach va $var_actions { + # #set isvar [expr {[lindex $var_class $i 1] == 6}] + # if {([lindex $var_class $i 1] == 6 || [lindex $var_class $i] == 3 ) && ([string length [set varname [lindex $var_names $i]]])} { + # #isvar + # lassign $va lhsspec act val + # upvar $lvlup $varname the_var + # if {$act eq "set"} { + # set the_var $val + # } + # #if {[lindex $var_actions $i 1] eq "set"} { + # # set the_var $val + # #} + # } + # incr i + #} + } else { + #todo - some way to restrict mismatch info to simple "mismatch" and avoid overhead of verbose message + #e.g for within pipeswitch block where mismatches are expected and the reasons are less important than moving on quickly + set vidx 0 + set mismatches [lmap m $match_state v $var_names {expr {$m == 0} ? {[list mismatch $v]} : {[list match $v]}}] + set var_display_names [list] + foreach v $var_names { + if {$v eq ""} { + lappend var_display_names {{}} + } else { + lappend var_display_names $v + } + } + set mismatches_display [lmap m $match_state v $var_display_names {expr {$m == 0} ? {$v} : {[expr {$m eq "?"} ? {"?[string repeat { } [expr [string length $v] -1]]"} : {[string repeat " " [string length $v]]} ]}}] + set msg "\n" + append msg "Unmatched\n" + append msg "Cannot match right hand side to pattern $multivar\n" + append msg "vars/atoms/etc: $var_names\n" + append msg "mismatches: [join $mismatches_display { }]\n" + set i 0 + #0 - novar + #1 - atom ' + #2 - pin ^ + #3 - boolean & + #4 - integer + #5 - double + #6 - var + #7 - glob (no classifier and contains * or ?) + foreach mismatchinfo $mismatches { + lassign $mismatchinfo status varname + if {$status eq "mismatch"} { + # varname can be empty string + set varclass [lindex $var_class $i 1] + set val [lindex $var_actions $i 2] + set e [dict get [lindex $expected_values $i] lhs] + set type "" + if {2 in $varclass} { + append type "pinned " + } + + if {$varclass == 1} { + set type "atom" + } elseif {$varclass == 2} { + set type "pinned var" + } elseif {3 in $varclass} { + append type "boolean" + } elseif {4 in $varclass} { + append type "int" + } elseif {5 in $varclass} { + append type "double" + } elseif {$varclass == 6} { + set type "var" + } elseif {7 in $varclass} { + append type "glob" + } elseif {8 in $varclass} { + append type "numeric" + } + if {$type eq ""} { + set type "" + } + + set lhs_tag "- [dict get [lindex $expected_values $i] info]" + set mmaction [lindex $var_actions $i 1] ;#e.g ?mismatch-dict-index-out-of-range + set tag "?mismatch-" + if {[string match $tag* $mmaction]} { + set mismatch_reason [string range $mmaction [string length $tag] end] + } else { + set mismatch_reason $mmaction + } + append msg " $type: '$varname' $mismatch_reason $lhs_tag LHS: '$e' vs RHS: '$val'\n" + } + incr i + } + #error $msg + dict unset returndict result + #structured error return - used by pipeswitch/pipecase - matching on "binding mismatch*" + dict set returndict mismatch [dict create binding mismatch varnames $var_names matchinfo $mismatches display $msg data $data] + return $returndict + } + + if {![llength $var_names]} { + #var_name entries can be blank - but it will still be a list + #JMN2 + #dict set returndict result [list $data] + dict set returndict result $data + } else { + assert {$i == [llength $var_names]} assertion_fail _multi_bind_result condition {$i == [llength $var_names]} + dict set returndict result $returnval + } + return $returndict + } + + ######################################################## + # dragons. + # using an error as out-of-band way to signal mismatch is the easiest. + # It comes at some cost (2us 2023?) to trigger catches. (which is small relative to uncompiled pipeline costs in initial version - but per pattern mismatch will add up) + # The alternative of attempting to tailcall return the mismatch as data - is *hard* if not impossible to get right. + # We need to be able to match on things like {error {mismatch etc}} - without it then itself being interpreted as a mismatch! + # A proper solution may involve a callback? tailcall some_mismatch_func? + # There may be a monad-like boxing we could do.. to keep it in data e.g {internalresult match } {internalresult mismatch } and be careful to not let boxed data escape ?? + # make sure there is good test coverage before experimenting with this + proc _handle_bind_result {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -errorcode [list binding mismatch varnames [dict get $d mismatch varnames]] [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + # initially promising - but the approach runs into impossible disambiguation of mismatch as data vs an actual mismatch + proc _handle_bind_result_experimental1 {d} { + #set match_caller [info level 2] + #debug.punk.pipe {_handle_bind_result match_caller: $match_caller} 9 + if {![dict exists $d result]} { + tailcall return [dict get $d mismatch] + } else { + return [dict get $d result] + } + } + ######################################################## + + #timings very similar. listset3 closest in performance to pipeset. review - test on different tcl versions. + #Unfortunately all these variations seem around 10x slower than 'set list {a b c}' or 'set list [list a b c]' + #there seems to be no builtin for list setting with args syntax. lappend is close but we would need to catch unset the var first. + #proc listset1 {listvarname args} { + # tailcall set $listvarname $args + #} + #interp alias {} listset2 {} apply {{vname args} {tailcall set $vname $args}} + #interp alias {} listset3 {} apply {{vname args} {upvar $vname v; set v $args}} + proc pipeset {pipevarname args} { + upvar $pipevarname the_pipe + set the_pipe $args + } + + #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::objclone $args] + set nscaller [uplevel 1 [list namespace current]] + tailcall interp alias {} $targetcmd {} apply [list args [append cmdcopy " {*}\$args"] $nscaller] + } + proc pipealias_extract {targetcmd} { + set applybody [lindex [interp alias "" $targetcmd] 1 1] + #strip off trailing " {*}$args" + return [lrange [string range $applybody 0 end-9] 0 end] + } + #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::objclone $args] + set nscaller [uplevel 1 [list namespace current]] + tailcall interp alias {} $targetcmd {} apply [list args [concat "\[concat" [list $cmdcopy] "\$args]"] $nscaller] + } + + + #same as used in unknown func for initial launch + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #variable re_assign {^[\{]{0,1}([^ \t\r\n=]*)=(.*)} + variable re_assign {^([^ \t\r\n=\{]*)=(.*)} + variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #match_assign is tailcalled from unknown - uplevel 1 gets to caller level + proc match_assign {scopepattern equalsrhs args} { + #review - :: is legal in atoms! + if {[string match "*::*" $scopepattern]} { + error "match_assign scopepattern '$scopepattern' contains namespace separator '::' - invalid." + } + #puts stderr ">> match_assign '$scopepattern=$equalsrhs' $args" + set fulltail $args + set cmdns ::punk::pipecmds + set namemapping [punk::pipe::lib::pipecmd_namemapping $equalsrhs] + + #we deliberately don't call pipecmd_namemapping on the scopepattern even though it may contain globs. REVIEW + #(we need for example x*= to be available as is via namespace path mechanism (from punk::pipecmds namespace)) + + set pipecmd ${cmdns}::$scopepattern=$namemapping + + #pipecmd could have glob chars - test $pipecmd in the list - not just that info commands returns results. + 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]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + + #NOTE: + #we need to ensure for case: + #= x=y + #that the second arg is treated as a raw value - never a pipeline command + + #equalsrhs is set if there is a segment-insertion-pattern *directly* after the = + #debug.punk.pipe {match_assign '$multivar' '$equalsrhs' '$fulltail'} 4 + #can match pattern on lhs with a value where pattern is a minilang that can refer to atoms (simple non-whitespace strings), numbers, or varnames (possibly pinned) as well as a trailing spec for position within the data. + + # allow x=insertionpattern to begin a pipeline e.g x= |> string tolower ? or x=1 a b c <| X to produce a X b c + # + #to assign an entire pipeline to a var - use pipeset varname instead. + + # in our script's handling of args: + #avoid use of regexp match on each element - or we will unnecessarily force string reps on lists + #same with lsearch with a string pattern - + #wouldn't matter for small lists - but we need to be able to handle large ones efficiently without unneccessary string reps + set script [string map [list $scopepattern $equalsrhs] { + #script built by punk::match_assign + if {[llength $args]} { + #scan for existence of any pipe operator (|*> or <*|) only - we don't need position + #all pipe operators must be a single element + #we don't first check llength args == 1 because for example: + # x= <| + # x= |> + #both leave x empty. To assign a pipelike value to x we would have to do: x= <| |> (equiv: set x |>) + foreach a $args { + if {![catch {llength $a} sublen]} { + #don't enforce sublen == 1. Legal to have whitespace including newlines {| x >} + if {[string match |*> $a] || [string match <*| $a]} { + tailcall punk::pipeline = "" "" {*}$args + } + } + } + if {[llength $args] == 1} { + set segmenttail [lindex $args 0] + } else { + error "pipedata = must take a single argument. Got [llength $args] args: '$args'" "match_assign $args" [list pipedata segment too_many_elements segment_type =] + } + } else { + #set segmenttail [purelist] + set segmenttail [lreplace x 0 0] + } + }] + + + if {[string length $equalsrhs]} { + # as we aren't in a pipleine - there is no data to insert - we proably still need to run _split_equalsrhs to verify the syntax. + # review - consider way to turn it off as optimisation for non-pipelined assignment - but generally standard Tcl set could be used for that purpose. + # We are probably only here if testing in the repl - in which case the error messages are important. + set var_index_position_list [punk::pipe::lib::_split_equalsrhs $equalsrhs] + #we may have an insertion-spec that inserts a literal atom e.g to wrap in "ok" + # x='ok'>0/0 data + # => {ok data} + # we won't examine for vars as there is no pipeline - ignore + # also ignore trailing * (indicator for variable data to be expanded or not - ie {*}) + # we will differentiate between / and @ in the same way that general pattern matching works. + # /x will simply call linsert without reference to length of list + # @x will check for out of bounds + # + # !TODO - sort by position lowest to highest? or just require user to order the pattern correctly? + + + foreach v_pos $var_index_position_list { + lassign $v_pos v indexspec positionspec + #e.g =v1/1>0 A pattern predator system) + # + #todo - review + # + # + #for now - the script only needs to handle the case of a single segment pipeline (no |> <|) + + + #temp - needs_insertion + #we can safely output no script for variable insertions for now - because if there was data available, + #we would have to be in a pipeline - in which case the script above would have delegated all our operations anyway. + #tag: positionspechandler + if {([string index $v 0] eq "'" && [string index $v end] eq "'") || [string is integer -strict $v]} { + #(for now)don't allow indexspec on a literal value baked into the pipeline - it doesn't really make sense + #- unless the pipeline construction has been parameterised somehow e.g "=${something}/0" + #review + if {[string length $indexspec]} { + error "pipesyntax literal value $v - index specification not allowed (match_assign)1" "match_assign $scopepattern $equalsrhs $args" [list pipesyntax index_on_literal] + } + if {[string index $v 0] eq "'" && [string index $v end] eq "'"} { + set datasource [string range $v 1 end-1] + } elseif {[string is integer -strict $v]} { + set datasource $v + } + append script [string map [list $datasource] { + set insertion_data "" ;#atom could have whitespace + }] + + set needs_insertion 1 + } elseif {$v eq ""} { + #default variable is 'data' + set needs_insertion 0 + } else { + append script [string map [list $v] { + #uplevel? + #set insertion_data [set ] + }] + set needs_insertion 0 + } + if {$needs_insertion} { + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data"] $script2] + append script $script2 + } + } + } + + if {![string length $scopepattern]} { + append script { + return $segmenttail + } + } else { + append script [string map [list $scopepattern] { + #we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail + set d [punk::_multi_bind_result {} $segmenttail] + #return [punk::_handle_bind_result $d] + #maintenance: inlined + if {![dict exists $d result]} { + #uplevel 1 [list error [dict get $d mismatch]] + #error [dict get $d mismatch] + return -code error -level 1 -errorcode [list binding mismatch] [dict get $d mismatch] + } else { + return [dict get $d result] + } + }] + } + + 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]] + if {$cmdns ni $existing_path} { + uplevel 1 [list ::namespace path [concat $existing_path $cmdns]] + } + tailcall $pipecmd {*}$args + } + + #return a script for inserting data into listvar + #review - needs updating for list-return semantics of patterns? + proc list_insertion_script {keyspec listvar {data }} { + set positionspec [string trimright $keyspec "*"] + set do_expand [expr {[string index $keyspec end] eq "*"}] + if {$do_expand} { + set exp {{*}} + } else { + set exp "" + } + #NOTE: linsert and lreplace can take multiple values at tail ie expanded data + + set ptype [string index $positionspec 0] + if {$ptype in [list @ /]} { + set index [string range $positionspec 1 end] + } else { + #the / is optional (default) at first position - and we have already discarded the ">" + set ptype "/" + set index $positionspec + } + #puts stderr ">> >> $index" + set script "" + set isint [string is integer -strict $index] + if {$index eq "."} { + #do nothing - this char signifies no insertion + } elseif {$isint || [regexp {^(end|end[-+]{1,2}[0-9]+)$} $index]} { + if {$ptype eq "@"} { + #compare position to *possibly updated* list - note use of $index > $datalen rather than $index+1 > $datalen - (we allow 'insertion' at end of list by numeric index) + if {$isint} { + append script [string map [list $listvar $index] { + if {( > [llength $])} { + #not a pipesyntax error + error "pipedata insertionpattern index out of bounds. index: vs len: [llength $] use /x instead of @x to avoid check (list_insertion_script)" "list_insertion_script $keyspec" [list pipedata insertionpattern index_out_f_bounds] + } + }] + } + #todo check end-x bounds? + } + if {$isint} { + append script [string map [list $listvar $index $exp $data] { + set [linsert [lindex [list $ [unset ]] 0] ] + }] + } else { + append script [string map [list $listvar $index $exp $data] { + #use inline K to make sure the list is unshared (optimize for larger lists) + set [linsert [lindex [list $ [unset ]] 0] ] + }] + } + } elseif {[string first / $index] < 0 && [string first - $index] > 0} { + if {[regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $index _ start end]} { + #also - range checks for @ which must go into script !!! + append script [string map [list $listvar $start $end $exp $data] { + set [lreplace [lindex [list $ [unset ]] 0] ] + }] + } else { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)2" "list_insertion_script $keyspec" [list pipedata insertionpattern_invalid] + } + } elseif {[string first / $index] >= 0} { + #nested insertion e.g /0/1/2 /0/1-1 + set parts [split $index /] + set last [lindex $parts end] + if {[string first - $last] >= 0} { + lassign [split $last -] a b + if {![regexp {^([0-9]+|end|end[-+]{1,2}[0-9]+)-([0-9]+|end|end[-+]{1,2}([0-9]+))$} $last _ a b]} { + error "pipesyntax error in segment insertionpattern - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)3" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + if {$a eq $b} { + if {!$do_expand} { + #we can do an lset + set lsetkeys [list {*}[lrange $parts 0 end-1] $a] + append script [string map [list $listvar $lsetkeys $data] { + lset + }] + } else { + #we need to lreplace the containing item + append script [string map [list $listvar [lrange $parts 0 end-1] $a $data] { + set target [lindex $ ] + lset target {*} + lset $target + }] + } + } else { + #we need to lreplace a range at the target level + append script [string map [list $listvar [lrange $parts 0 end-1] $a $b $exp $data] { + set target [lindex $ ] + set target [lreplace $target ] + lset $target + }] + } + } else { + #last element has no -, so we are inserting at the final position - not replacing + append script [string map [list $listvar [lrange $parts 0 end-1] $last $exp $data] { + set target [lindex $ ] + set target [linsert $target ] + lset $target + }] + } + } else { + error "pipesyntax error in segment - positionspec:'$keyspec' unable to interpret position spec (list_insertion_script)4" "list_insertion_script $keyspec" [list pipesyntax insertionpattern_invalid] + } + return $script + } + + + proc _is_math_func_prefix {e1} { + #also catch starting brackets.. e.g "(min(4,$x) " + if {[regexp {^[^[:alnum:]]*([[:alnum:]]*).*} $e1 _ word]} { + #possible math func + if {$word in [info functions]} { + return true + } + } + return false + } + + #todo - option to disable these traces which provide clarifying errors (performance hit?) + proc pipeline_args_read_trace_error {args} { + error "The pipelined data doesn't appear to be a valid Tcl list\nModify input, or use \$data or another variable name instead of \$args." "pipeline_args_read_trace_error $args" [list pipedata args_unavailable_data_not_a_list] + } + + + #NOTE: the whole idea of scanning for %x% is a lot of work(performance penalty) + #consider single placeholder e.g "_" as only positional indicator - for $data only - and require braced script with $var for more complex requirements + #possibly also *_ for expanded _ ? + #This would simplify code a lot - but also quite possible to collide with user data. + #Perhaps not a big deal as unbraced segments between |> are mainly(?) a convenience for readability/repl etc. + # (but importantly (at pipeline start anyway) unbraced segments are a mechanism to inject data from calling scope or from pipeline args <|) + # + #detect and retrieve %xxx% elements from item without affecting list/string rep + #commas, @, ', ^ and whitespace not part of a valid tag (allows some substitution within varspecs) + #%% is not a valid tag + #(as opposed to using regexp matching which causes string reps) + proc get_tags {item} { + set chars [split $item {}] + set terminal_chars [list , @ ' ^ " " \t \n \r] + #note % is both terminal and initiating - so for the algorithm we don't include it in the list of terminal_chars + set nonterminal [lmap v $chars {expr {$v ni $terminal_chars}}] + set percents [lmap v $chars {expr {$v eq "%"}}] + #useful for test/debug + #puts "CHARS : $chars" + #puts "NONTERMINAL: $nonterminal" + #puts "PERCENTS : $percents" + set sequences [list] + set in_sequence 0 + set start -1 + set end -1 + set i 0 + #todo - some more functional way of zipping/comparing these lists? + set s_length 0 ;#sequence length including % symbols - minimum for tag therefore 2 + foreach n $nonterminal p $percents { + if {!$in_sequence} { + if {$n & $p} { + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + set s_length 0 + } + } else { + if {$n ^ $p} { + incr s_length + incr end + } else { + if {$n & $p} { + if {$s_length == 1} { + # % followed dirctly by % - false start + #start again from second % + set s_length 1 + set in_sequence 1 + set start $i + set end $i + } else { + incr end + lappend sequences [list $start $end] + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } else { + #terminated - not a tag + set in_sequence 0 + set s_length 0 + set start -1; set end -1 + } + } + } + incr i + } + + set tags [list] + foreach s $sequences { + lassign $s start end + set parts [lrange $chars $start $end] + lappend tags [join $parts ""] + } + return $tags + } + + #show underlying rep of list and first level + proc rep_listname {lname} { + upvar $lname l + set output "$lname list rep: [rep $l]\n" + foreach item $l { + append output "-rep $item\n" + append output " [rep $item]\n" + } + return $output + } + + + # -- + #consider possible tilde templating version ~= vs .= + #support ~ and ~* placeholders only. + #e.g x~= list aa b c |> lmap v ~ {string length $v} |> tcl::mathfunc::max ~* + #The ~ being mapped to $data in the pipeline. + #This is more readable and simpler for beginners - although it doesn't handle more advanced insertion requirements. + #possibility to mix as we can already with .= and = + #e.g + #x.= list aa b c |> ~= lmap v ~ {string length $v} |> .=>* tcl::mathfunc::max + # -- + proc pipeline {segment_op initial_returnvarspec equalsrhs args} { + set fulltail $args + #unset args ;#leave args in place for error diagnostics + debug.punk.pipe {call pipeline: op:'$segment_op' '$initial_returnvarspec' '$equalsrhs' '$fulltail'} 4 + #debug.punk.pipe.rep {[rep_listname fulltail]} 6 + + + #--------------------------------------------------------------------- + # test if we have an initial x.=y.= or x.= y.= + + #nextail is tail for possible recursion based on first argument in the segment + #set nexttail [lassign $fulltail next1] ;#tail head + + set next1 [lindex $args 0] + switch -- $next1 { + pipematch { + set nexttail [lrange $args 1 end] + set results [uplevel 1 [list pipematch {*}$nexttail]] + debug.punk.pipe {>>> pipematch results: $results} 1 + + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + pipecase { + set msg "pipesyntax\n" + append msg "pipecase does not return a value directly in the normal way\n" + append msg "It will return a casemismatch dict on mismatch\n" + append msg "But on a successful match - it will use an 'error' mechanism to return {ok result {something}} in the caller's scope -\n" + append msg "This will appear as an error in the repl, or disrupt pipeline result propagation if not in an appropriate wrapper\n" + append msg "Call pipecase from within a pipeline script block or wrapper such as pipeswitch or apply." + error $msg + } + } + + #temp - this is related to a script for the entire pipeline (functional composition) - not the script for the segment-based x=y or x.=y proc. + set ::_pipescript "" + + + #NOTE: + #important that for assignment: + #= x=y .. + #The second element is always treated as a raw value - not a pipeline instruction. + #whereas... for execution: + #.= x=y the second element is a pipeline-significant symbol based on the '=' even if it was passed in as an argument. + #Usually an execution segment (.= cmd etc..) will have args inserted at the tail anyway - + #- but if the pipeline is designed to put an argument in the zero position - then presumably it is intended as a pipeline-significant element anyway + #This gives a *slight* incompatibility with external commands containing '=' - in that they may not work properly in pipelines + # + if {$segment_op ne "="} { + #handle for example: + #var1.= var2= "etc" |> string toupper + # + #var1 will contain ETC (from entire pipeline), var2 will contain etc (from associated segment) + # + + if {([set nexteposn [string last = $next1]] >= 0) && (![punk::pipe::lib::arg_is_script_shaped $next1])} { + set nexttail [lrange $args 1 end] + #*SUB* pipeline recursion. + #puts "======> recurse based on next1:$next1 " + if {[string index $next1 $nexteposn-1] eq {.}} { + #var1.= var2.= ... + #non pipelined call to self - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe.rep {==> rep recursive results: [rep $results]} 5 + #debug.punk.pipe {>>> results: $results} 1 + return [_handle_bind_result [_multi_bind_result $initial_returnvarspec $results]] + } + #puts "======> recurse assign based on next1:$next1 " + #if {[regexp {^([^ \t\r\n=\{]*)=(.*)} $next1 _ nextreturnvarspec nextrhs]} { + #} + #non pipelined call to plain = assignment - return result + set results [uplevel 1 [list $next1 {*}$nexttail]] + #debug.punk.pipe {>>> results: $results} 1 + set d [_multi_bind_result $initial_returnvarspec $results] + return [_handle_bind_result $d] + } + } + + set procname $initial_returnvarspec.=$equalsrhs + + #--------------------------------------------------------------------- + + #todo add 'op' argument and handle both .= and = + # + #|> data piper symbol + #<| args piper symbol (arguments supplied at end of pipeline e.g from commandline or from calling and/or currying the command) + # + + set more_pipe_segments 1 ;#first loop + + #this contains the main %data% and %datalist% values going forward in the pipeline + #as well as any extra pipeline vars defined in each |> + #It also contains any 'args' with names supplied in <| + set dict_tagval [dict create] ;#cumulative %x% tag dict which operates on the whole length of the pipeline + + #determine if there are input args at the end of the pipeline indicated by reverse <| symbol possibly with argspecs e.g transform x y z = 0} { + set tailremaining [lrange $fulltail 0 $firstargpipe_posn-1] + set argslist [lrange $fulltail $firstargpipe_posn+1 end] ;#Note that this could be a whole other pipeline with |> and/or <| elements. + set argpipe [lindex $fulltail $firstargpipe_posn] + set argpipespec [string range $argpipe 1 end-1] ;# strip off < & | from " b1 b2 b3 |outpipespec> c1 c2 c3 + # for a1 a2 a3 - the pipe to the right is actually an outpipespec and for c1 c2 c3 the pipe to the left is an inpipespec + + + #our initial command list always has *something* before we see any pipespec |> + #Therefore we initially have a blank inpipespec (although in effect, it comes from the argpipespec <|) + set inpipespec $argpipespec + set outpipespec "" + + #avoiding regexp on each arg to maintain list reps + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ## set tailmap [lmap v $tailremaining {if {[regexp {^\|(.*)>$} $v _ outpipespec] && !$pipeseen} {set pipeseen 1;set outpipespec} {if {$pipeseen} {set v} 0}}] + #e.g for: a b c |> e f g |> h + #set firstpipe_posn [lsearch $tailmap {| >}] + + set firstpipe_posn [lsearch $tailremaining "|*>"] + + if {$firstpipe_posn >= 0} { + set outpipespec [string range [lindex $tailremaining $firstpipe_posn] 1 end-1] + set segment_members [lrange $tailremaining 0 $firstpipe_posn-1] + #set tailremaining [lrange $tailremaining $firstpipe_posn+1 end] + set tailremaining [lreplace $tailremaining 0 $firstpipe_posn] ;#generally too short for any K combinator benefit? what about lists with scripts? is it dependent on list length or also element content size? + } else { + set segment_members $tailremaining + set tailremaining [list] + } + + + set script_like_first_word 0 + set rhs $equalsrhs + + set segment_first_is_script 0 ;#default assumption until tested + + set segment_first_word [lindex $segment_members 0] + if {$segment_op ne "="} { + if {[punk::pipe::lib::arg_is_script_shaped $segment_first_word]} { + set segment_first_is_script 1 + } + } else { + if {[llength $segment_members] > 1} { + error "pipedata = can only accept a single argument (got: '$segment_members')" "pipeline $segment_op $initial_returnvarspec $equalsrhs $fulltail" [list pipedata too_many_elements] + #proc pipeline {segment_op initial_returnvarspec equalsrhs args} + } + set segment_members $segment_first_word + } + + + #tailremaining includes x=y during the loop. + set returnvarspec $initial_returnvarspec + if {![llength $argslist]} { + unset -nocomplain previous_result ;# we want it unset for first iteration - differentiate from empty string + } else { + set previous_result $argslist + } + + set segment_result_list [list] + set i 0 ;#segment id + set j 1 ;#next segment id + set pipespec(args) $argpipespec ;# from trailing <| + set pipespec(0,in) $inpipespec + set pipespec(0,out) $outpipespec + + set max_iterations 100 ;# configurable? -1 for no limit ? This is primarily here to aid debugging of runaway loops in initial development .. should probably set to no-limit in final version. + while {$more_pipe_segments == 1} { + #--------------------------------- + debug.punk.pipe {[a yellow bold]i$i SEGMENT MEMBERS([llength $segment_members]): $segment_members[a]} 4 + debug.punk.pipe {[a yellow bold]i$i TAIL REMAINING([llength $tailremaining]): $tailremaining[a]} 4 + debug.punk.pipe {[a] inpipespec(prev [a yellow bold]|$pipespec($i,in)[a]>) outpipespec(next [a+ yellow bold]|$pipespec($i,out)>[a])} 4 + debug.punk.pipe {[a cyan bold] segment_first_is_script:$segment_first_is_script} 4 + if {$segment_first_is_script} { + debug.punk.pipe {[a cyan bold] script segment: [lindex $segment_members 0][a]} 4 + } + + + #examine inpipespec early to give faster chance for mismatch. ie before scanning segment for argument position + set segment_result "" + if {[info exists previous_result]} { + set prevr $previous_result + } else { + set prevr "" + } + set pipedvars [dict create] + if {[string length $pipespec($i,in)]} { + #check the varspecs within the input piper + # - data and/or args may have been manipulated + set d [apply { + {mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + } + } $pipespec($i,in) $prevr] + #temp debug + #if {[dict exists $d result]} { + #set jjj [dict get $d result] + #puts "!!!!! [rep $jjj]" + #} + set inpipespec_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + set prevr $inpipespec_result ;# leftmost spec in |> needs to affect pipeline flow of 'data' + #puts stdout "inpipespec:|$pipespec($i,in)> prevr:$prevr setvars: $pipedvars" + } + debug.punk.pipe {[a] previous_iteration_result: $prevr[a]} 6 + debug.punk.pipe.rep {rep previous_iteration_result [rep $prevr]} + + + if {$i == $max_iterations} { + puts stderr "ABORTING. Reached max_iterations $max_iterations (todo: make configurable)" + set more_pipe_segments 0 + } + + set insertion_patterns [punk::pipe::lib::_split_equalsrhs $rhs] ;#raises error if rhs of positionspec not like /* or @* + set segment_has_insertions [expr {[llength $insertion_patterns] > 0}] + #if {$segment_has_insertions} { + # puts stdout ">>> $segment_members insertion_patterns $insertion_patterns" + #} + + debug.punk.pipe.var {segment_has_insertions: $insertion_patterns} 5 + debug.punk.pipe.rep {[rep_listname segment_members]} 4 + + + #whether the segment has insertion_patterns or not - apply any modification from the piper argspecs (script will use modified args/data) + #pipedvars comes from either previous segment |>, or <| args + if {[dict exists $pipedvars "data"]} { + #dict set dict_tagval %data% [list [dict get $pipedvars "data"]] + dict set dict_tagval data [dict get $pipedvars "data"] + } else { + if {[info exists previous_result]} { + dict set dict_tagval data $prevr + } + } + foreach {vname val} $pipedvars { + #add additionally specified vars and allow overriding of %args% and %data% by not setting them here + if {$vname eq "data"} { + #already potentially overridden + continue + } + dict set dict_tagval $vname $val + } + + #todo! + #segment_script - not in use yet. + #will require non-iterative pipeline processor to use ... recursive.. or coroutine based + set script "" + + if {!$segment_has_insertions} { + #debug.punk.pipe.var {[a cyan]SEGMENT has no tags[a]} 7 + #add previous_result as data in end position by default, only if *no* insertions specified (data is just list-wrapped previous_result) + #set segment_members_filled [concat $segment_members [dict get $dict_tagval %data%]] ;# data flows through by default as single element - not args - because some strings are not valid lists + #insertion-specs with a trailing * can be used to insert data in args format + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + lappend segment_members_filled [dict get $dict_tagval data] + } + } else { + debug.punk.pipe.var {processing insertion_pattern dict_tagval: $dict_tagval} 4 + set segment_members_filled [list] + set segmenttail $segment_members ;# todo - change to segment_members here to match punk::match_assign + + set rhsmapped [punk::pipe::lib::pipecmd_namemapping $rhs] + set cmdname "::punk::pipecmds::insertion::_$rhsmapped" + #glob chars have been mapped - so we can test by comparing info commands result to empty string + if {[info commands $cmdname] eq ""} { + set insertion_script "proc $cmdname {dict_tagval segmenttail} {\n" + foreach v_pos $insertion_patterns { + #puts stdout "v_pos '$v_pos'" + lassign $v_pos v indexspec positionspec ;#v may be atom, or varname (in pipeline scope) + #puts stdout "v:'$v' indexspec:'$indexspec' positionspec:'$positionspec'" + #julz + + append insertion_script \n [string map [list $v_pos] { + lassign [list ] v indexspec positionspec + }] + + if {([string index $v 0] eq "'") && ([string index $v end] eq "'")} { + set v [string range $v 1 end-1] ;#assume trailing ' is present! + if {[string length $indexspec]} { + error "pipesyntax - index not supported on atom" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n "set insertion_data [list $v]" ;#sub in shortened $v now -i.e use atom value itself (string within single quotes) + } elseif {[string is double -strict $v]} { + #don't treat numbers as variables + if {[string length $indexspec]} { + error "pipesyntax - index not supported on number" "pipeline $segment_op $initial_returnvarspec $equalsrhs $args" [list pipesyntax index_on_literal] + } + append insertion_script \n {set insertion_data $v} + } else { + #todo - we should potentially group by the variable name and pass as a single call to _multi_bind_result - because stateful @ and @@ won't work in independent calls + append insertion_script \n [string map [list $cmdname] { + #puts ">>> v: $v dict_tagval:'$dict_tagval'" + if {$v eq ""} { + set v "data" + } + if {[dict exists $dict_tagval $v]} { + set insertion_data [dict get $dict_tagval $v] + #todo - use destructure_func + set d [punk::_multi_bind_result $indexspec $insertion_data] + set insertion_data [punk::_handle_bind_result $d] + } else { + #review - skip error if varname is 'data' ? + #e.g we shouldn't really fail for: + #.=>* list a b c <| + #??? Technically + #we need to be careful not to insert empty-list as an argument by default + error "pipevariable - varname $v not present in pipeline context. pipecontext_vars: [dict keys $dict_tagval] (2)" " pipecontext_vars: [dict keys $dict_tagval]" [list pipevariable variable_not_in_pipeline_scope] + } + + }] + } + + + #append script [string map [list $getv]{ + # + #}] + #maintenance - index logic should be similar identical? to to match_assign - which only needs to process atoms because it (for now?) delegates all pipeline ops here, so no vars available (single segment assign) + #tag: positionspechandler + + + #puts stdout "=== list_insertion_script '$positionspec' segmenttail " + set script2 [punk::list_insertion_script $positionspec segmenttail ] + set script2 [string map [list "\$insertion_data"] $script2] + append insertion_script \n $script2 + } + append insertion_script \n {set segmenttail} + append insertion_script \n "}" + #puts stderr "$insertion_script" + debug.punk.pipe.compile {creating proc ::punk::pipecmds::insertion::_$rhsmapped } 4 + eval $insertion_script + } + + set segment_members_filled [::punk::pipecmds::insertion::_$rhsmapped $dict_tagval [lindex [list $segmenttail [unset segmenttail]] 0]] + + #set segment_members_filled $segmenttail + #note - length of segment_members_filled may now differ from length of original segment_members! (if do_expand i.e trailing * in any insertion_patterns) + } + set rhs [string map $dict_tagval $rhs] ;#obsolete? + + debug.punk.pipe.rep {segment_members_filled rep: [rep $segment_members_filled]} 4 + + + # script index could have changed!!! todo fix! + + #we require re_dot_assign before re_assign (or fix regexes so order doesn't matter!) + if {(!$segment_first_is_script) && $segment_op eq ".="} { + #no scriptiness detected + + #debug.punk.pipe.rep {[a yellow bold][rep_listname segment_members_filled][a]} 4 + + set cmdlist_result [uplevel 1 $segment_members_filled] + #debug.punk.pipe {[a green bold]forward_result: $forward_result[a]} 4 + #debug.punk.pipe.rep {[a yellow bold]forward_result REP: [rep $forward_result][a]} 4 + + #set d [_multi_bind_result $returnvarspec [punk::K $cmdlist_result [unset cmdlist_result]]] + set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0]] + + set segment_result [_handle_bind_result $d] + #puts stderr ">>forward_result: $forward_result segment_result $segment_result" + } elseif {$segment_op eq "="} { + #slightly different semantics for assigment! + #We index into the DATA - not the position within the segment! + #(an = segment must take a single argument, as opposed to a .= segment) + #(This was a deliberate design choice for consistency with set, and to reduce errors.) + #(we could have allowed multiple args to = e.g to form a list, but it was tried, and the edge-cases were unintuitive and prone to user error) + #(The choice to restrict to single argument, but allow insertion and appending via insertion-specs is more explicit and reliable even though the insertion-specs operate differently to those of .=) + # + #we have to ensure that for an empty segment - we don't append to the empty list, thus listifying the data + #v= {a b c} |> = + # must return: {a b c} not a b c + # + if {!$segment_has_insertions} { + set segment_members_filled $segment_members + if {[dict exists $dict_tagval data]} { + if {![llength $segment_members_filled]} { + set segment_members_filled [dict get $dict_tagval data] + } else { + lappend segment_members_filled [dict get $dict_tagval data] + } + } + } + + set d [_multi_bind_result $returnvarspec [lindex [list $segment_members_filled [unset segment_members_filled]] 0]] + set segment_result [_handle_bind_result $d] + } elseif {$segment_first_is_script || $segment_op eq "script"} { + #script + debug.punk.pipe {[a+ cyan bold].. evaluating as script[a]} 2 + + set script [lindex $segment_members 0] + + #build argument lists for 'apply' + set segmentargnames [list] + set segmentargvals [list] + foreach {k val} $dict_tagval { + if {$k eq "args"} { + #skip args - it is manually added at the end of the apply list if it's a valid tcl list + continue + } + lappend segmentargnames $k + lappend segmentargvals $val + } + + set argsdatalist $prevr ;#default is raw result as a list. May be overridden by an argspec within |> e.g |args@@key> or stripped if not a tcl list + #puts "------> rep prevr argsdatalist: [rep $argsdatalist]" + set add_argsdata 0 + if {[dict exists $dict_tagval "args"]} { + set argsdatalist [dict get $dict_tagval "args"] + #see if the raw result can be treated as a list + if {[catch {lindex $argsdatalist 0}]} { + #we cannot supply 'args' + set pre_script "" + #todo - only add trace if verbose warnings enabled? + append pre_script "trace add variable args read punk::pipeline_args_read_trace_error\n" + set script $pre_script + append script $segment_first_word + set add_argsdata 0 + } else { + set add_argsdata 1 + } + } + + debug.punk.pipe.rep {>> [rep_listname segmentargvals]} 4 + set ns [uplevel 1 {::namespace current}] + if {!$add_argsdata} { + debug.punk.pipe {APPLY1: (args not set; not a list) segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals" + set evaluation [uplevel 1 [list ::apply [::list $segmentargnames $script $ns] {*}$segmentargvals]] + } else { + debug.punk.pipe {APPLY2: (args is set)segment vars:$segmentargnames} 4 + #puts stderr " script: $script" + #puts stderr " vals: $segmentargvals $argsdatalist" + #pipeline script context should be one below calling context - so upvar v v will work + #ns with leading colon will fail with apply + set evaluation [uplevel 1 [list ::apply [::list [::concat $segmentargnames args] $script $ns] {*}$segmentargvals {*}$argsdatalist]] + } + + debug.punk.pipe.rep {script result, evaluation: [rep_listname evaluation]} 4 + #puts "---> rep script evaluation result: [rep $evaluation]" + #set d [_multi_bind_result $returnvarspec [punk::K $evaluation [unset evaluation]]] + + #trailing segment_members are *pipedata* scripts - as opposed to ordinary pipeline scripts! + set tail_scripts [lrange $segment_members 1 end] + if {[llength $tail_scripts]} { + set r [pipedata $evaluation {*}$tail_scripts] + } else { + set r $evaluation + } + set d [_multi_bind_result $returnvarspec [lindex [list $r [unset r]] 0]] + set segment_result [_handle_bind_result $d] + } else { + #tags ? + #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 + if {false} { + #set s [list uplevel 1 [concat $rhs $segment_members_filled]] + if {![info exists pscript]} { + upvar ::_pipescript pscript + } + if {![info exists pscript]} { + #set pscript $s + set pscript [funcl::o_of_n 1 $segment_members] + } else { + #set pscript [string map [list

$pscript] {uplevel 1 [concat $rhs $segment_members_filled [

]]}] + #set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled " + #append snew "set pipe_[expr $i -1]" + #append pscript $snew + set pscript [funcl::o_of_n 1 $segment_members $pscript] + } + } + + set cmdlist_result [uplevel 1 $segment_members_filled] + #set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]] + set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0]] + + #multi_bind_result needs to return a funcl for rhs of: + #lindex [list [set syncvar [main pipeline.. ]] [rhs binding funcl...] 1 ] + #which uses syncvar + # + #The lhs of 'list' runs first so now syncvar can be the root level of the rhs function list and bind the necessary vars. + #NOTE: unintuitively, we are returning the value of rhs to the main pipleline! (leftmost binding) this is because the leftmost binding determines what goes back to the pipeline result + + set segment_result [_handle_bind_result $d] + } + #the subresult doesn't need to go backwards - as the final assignment can emit the result into a variable + #It makes more sense and is ultimately more useful (and more easy to reason about) for the result of each assignment to be related only to the pre-pipe section + #It may however make a good debug point + #puts stderr "segment $i segment_result:$segment_result" + + debug.punk.pipe.rep {[rep_listname segment_result]} 3 + + + #examine tailremaining. + # either x x x |?> y y y ... + # or just y y y + #we want the x side for next loop + + #set up the conditions for the next loop + #|> x=y args + # inpipespec - contents of previous piper |xxx> + # outpipespec - empty or content of subsequent piper |xxx> + # previous_result + # assignment (x=y) + + + set pipespec($j,in) $pipespec($i,out) + set outpipespec "" + set tailmap "" + set next_pipe_posn -1 + if {[llength $tailremaining]} { + #set tailmap [lmap v $tailremaining {lreplace [split $v {}] 1 end-1}] + ##e.g for: a b c |> e f g |> h + #set next_pipe_posn [lsearch $tailmap {| >}] + set next_pipe_posn [lsearch $tailremaining "|*>"] + + set outpipespec [string range [lindex $tailremaining $next_pipe_posn] 1 end-1] + } + set pipespec($j,out) $outpipespec + + + set script_like_first_word 0 + if {[llength $tailremaining] || $next_pipe_posn >= 0} { + if {$next_pipe_posn >= 0} { + set next_all_members [lrange $tailremaining 0 $next_pipe_posn-1] ;#exclude only piper |xxx> for + set tailremaining [lrange $tailremaining $next_pipe_posn+1 end] + } else { + set next_all_members $tailremaining + set tailremaining [list] + } + + + #assignment is the arg immediately following |> operator e.g x.=blah or x=etc (or a normal commandlist or script!) + set segment_first_word "" + set returnvarspec "" ;# the lhs of x=y + set segment_op "" + set rhs "" + set segment_first_is_script 0 + if {[llength $next_all_members]} { + if {[punk::pipe::lib::arg_is_script_shaped [lindex $next_all_members 0]]} { + set segment_first_word [lindex $next_all_members 0] + set segment_first_is_script 1 + set segment_op "" + set segment_members $next_all_members + } else { + set possible_assignment [lindex $next_all_members 0] + #set re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + if {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op ".=" + set segment_first_word [lindex $next_all_members 1] + set script_like_first_word [punk::pipe::lib::arg_is_script_shaped $segment_first_word] + if {$script_like_first_word} { + set segment_first_is_script 1 ;#relative to segment_members which no longer includes the .= + } + set segment_members [lrange $next_all_members 1 end] + } elseif {[regexp {^([^ \t\r\n=]*)=(.*)} $possible_assignment _ returnvarspec rhs]} { + set segment_op "=" + #never scripts + #must be at most a single element after the = ! + if {[llength $next_all_members] > 2} { + #raise this as pipesyntax as opposed to pipedata? + error "pipesyntax - at most one element can follow = (got [lrange $next_all_members 1 end])" "pipeline $segment_op $returnvarspec $rhs [lrange $next_all_members 1 end]" [list pipesyntax too_many_elements] + } + set segment_first_word [lindex $next_all_members 1] + if {[catch {llength $segment_first_word}]} { + set segment_is_list 0 ;#only used for segment_op = + } else { + set segment_is_list 1 ;#only used for segment_op = + } + + set segment_members $segment_first_word + } else { + #no assignment operator and not script shaped + set segment_op "" + set returnvarspec "" + set segment_first_word [lindex $next_all_members 0] + set segment_first_word [lindex $next_all_members 1] + set segment_members $next_all_members + #puts stderr ">>3 no-operator segment_first_word: '$segment_first_word'" + } + } + } else { + #?? two pipes in a row ? + debug.punk.pipe {[a+ yellow bold]WARNING: no segment members found[a]} 0 + set segment_members return + set segment_first_word return + } + + #set forward_result $segment_result + #JMN2 + set previous_result $segment_result + #set previous_result [join $segment_result] + } else { + debug.punk.pipe {[a+ cyan bold]End of pipe segments ($i)[a]} 4 + #output pipe spec at tail of pipeline + + set pipedvars [dict create] + if {[string length $pipespec($i,out)]} { + set d [apply { + {mv res} { + punk::_multi_bind_result $mv $res -levelup 1 + } + } $pipespec($i,out) $segment_result] + set segment_result [_handle_bind_result $d] + set pipedvars [dict get $d setvars] + } + + set more_pipe_segments 0 + } + + #the segment_result is based on the leftmost var on the lhs of the .= + #whereas forward_result is always the entire output of the segment + #JMN2 + #lappend segment_result_list [join $segment_result] + lappend segment_result_list $segment_result + incr i + incr j + } ;# end while + + return [lindex $segment_result_list end] + #JMN2 + #return $segment_result_list + #return $forward_result + } + + + #just an experiment + #what advantage/difference versus [llength [lrange $data $start $end]] ??? + proc data_range_length {data start end} { + set datalen [llength $data] + + #normalize to s and e + if {$start eq "end"} { + set s [expr {$datalen - 1}] + } elseif {[string match end-* $start]} { + set stail [string range $start 4 end] + set posn [expr {$datalen - $stail - 1}] + if {$posn < 0} { + return 0 + } + set s $posn + } else { + #int + if {($start < 0) || ($start > ($datalen - 1))} { + return 0 + } + set s $start + } + if {$end eq "end"} { + set e [expr {$datalen - 1}] + } elseif {[string match end-* $end]} { + set etail [string range $end 4 end] + set posn [expr {$datalen - $etail - 1}] + if {$posn < 0} { + return 0 + } + set e $posn + } else { + #int + if {($end < 0)} { + return 0 + } + set e $end + } + if {$s > ($datalen - 1)} { + return 0 + } + if {$e > ($datalen - 1)} { + set e [expr {$datalen - 1}] + } + + + if {$e < $s} { + return 0 + } + + return [expr {$e - $s + 1}] + } + + # unknown -- + # This procedure is called when a Tcl command is invoked that doesn't + # exist in the interpreter. It takes the following steps to make the + # command available: + # + # 1. See if the autoload facility can locate the command in a + # Tcl script file. If so, load it and execute it. + # 2. If the command was invoked interactively at top-level: + # (a) see if the command exists as an executable UNIX program. + # If so, "exec" the command. + # (b) see if the command requests csh-like history substitution + # in one of the common forms !!, !, or ^old^new. If + # so, emulate csh's history substitution. + # (c) see if the command is a unique abbreviation for another + # command. If so, invoke the command. + # + # Arguments: + # args - A list whose elements are the words of the original + # command, including the command name. + + #review - we shouldn't really be doing this + #We need to work out if we can live with the real default unknown and just inject some special cases at the beginning before falling-back to the normal one + + proc ::unknown {args} { + #puts stderr "unk>$args" + variable ::tcl::UnknownPending + global auto_noexec auto_noload env tcl_interactive errorInfo errorCode + + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo + } + if {[info exists errorCode]} { + set savedErrorCode $errorCode + } + + set name [lindex $args 0] + if {![info exists auto_noload]} { + # + # Make sure we're not trying to load the same proc twice. + # + if {[info exists UnknownPending($name)]} { + return -code error "self-referential recursion\ + in \"unknown\" for command \"$name\"" + } + set UnknownPending($name) pending + set ret [catch { + auto_load $name [uplevel 1 {::namespace current}] + } msg opts] + unset UnknownPending($name) + if {$ret != 0} { + dict append opts -errorinfo "\n (autoloading \"$name\")" + return -options $opts $msg + } + if {![array size UnknownPending]} { + unset UnknownPending + } + if {$msg} { + if {[info exists savedErrorCode]} { + set ::errorCode $savedErrorCode + } else { + unset -nocomplain ::errorCode + } + if {[info exists savedErrorInfo]} { + set errorInfo $savedErrorInfo + } else { + unset -nocomplain errorInfo + } + set code [catch {uplevel 1 $args} msg opts] + if {$code == 1} { + # + # Compute stack trace contribution from the [uplevel]. + # Note the dependence on how Tcl_AddErrorInfo, etc. + # construct the stack trace. + # + set errInfo [dict get $opts -errorinfo] + set errCode [dict get $opts -errorcode] + set cinfo $args + if {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 150] + while {[string length [encoding convertto utf-8 $cinfo]] > 150} { + set cinfo [string range $cinfo 0 end-1] + } + append cinfo ... + } + set tail "\n (\"uplevel\" body line 1)\n invoked\ + from within\n\"uplevel 1 \$args\"" + set expect "$msg\n while executing\n\"$cinfo\"$tail" + if {$errInfo eq $expect} { + # + # The stack has only the eval from the expanded command + # Do not generate any stack trace here. + # + dict unset opts -errorinfo + dict incr opts -level + return -options $opts $msg + } + # + # Stack trace is nested, trim off just the contribution + # from the extra "eval" of $args due to the "catch" above. + # + set last [string last $tail $errInfo] + if {$last + [string length $tail] != [string length $errInfo]} { + # Very likely cannot happen + return -options $opts $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\"$cinfo\"" + set last [string last $tail $errInfo] + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo $errInfo $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\n invoked from within\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + set tail "\n while executing\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + return -options $opts $msg + } else { + dict incr opts -level + return -options $opts $msg + } + } + } + #set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}] + set isrepl [punk::repl::codethread::is_running] ;#may not be reading though + if {$isrepl} { + #set ::tcl_interactive 1 + } + 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" + } + + + #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 + } + + # -- --- --- --- --- + 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 {[dict get $::punk::config::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 + + #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" + } 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 { + 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 + } + } + + 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 + } + } + + 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 + } + } + } + + #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]" + } + } + } + return -code error -errorcode [list TCL LOOKUP COMMAND $name] "invalid command name $name" + } + + proc know {cond body} { + set existing [info body ::unknown] + #assuming we can't test on cond being present in existing unknown script - because it may be fairly simple and prone to false positives (?) + ##This means we can't have 2 different conds with same body if we test for body in unknown. + ##if {$body ni $existing} { + set scr [base64::encode -maxlen 0 $cond] ;#will only be decoded if the debug is triggered + #tcllib has some double-substitution going on.. base64 seems easiest and will not impact the speed of normal execution when debug off. + proc ::unknown {args} [string map [list @c@ $cond @b@ $body @scr@ $scr] { + #--------------------------------------- + if {![catch {expr {@c@}} res] && $res} { + debug.punk.unknown {HANDLED BY: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + return [eval {@b@}] + } else { + debug.punk.unknown {skipped: punk unknown_handler ([llength $args]) args:'$args' "cond_script:'[punk::decodescript @scr@]'" } 4 + } + #--------------------------------------- + }]$existing + #} + } + + proc know? {{len 2000}} { + puts [string range [info body ::unknown] 0 $len] + } + proc decodescript {b64} { + if { + [catch { + base64::decode $b64 + } scr] + } { + return "" + } else { + return "($scr)" + } + } + + # --------------------------- + # commands that should be aliased in safe interps that need to use punk repl + # + proc get_repl_runid {} { + if {[interp issafe]} { + if {[info commands ::tsv::exists] eq ""} { + puts stderr "punk::get_repl_runid cannot operate directly in safe interp - install the appropriate punk aliases" + error "punk::get_repl_runid punk repl aliases not installed" + } + #if safe interp got here - there must presumably be a direct set of aliases on tsv::* commands + } + if {[tsv::exists repl runid]} { + return [tsv::get repl runid] + } else { + return 0 + } + } + #ensure we don't get into loop in unknown when in safe interp - which won't have tsv + proc set_repl_last_unknown {args} { + if {[interp issafe]} { + if {[info commands ::tsv::set] eq ""} { + puts stderr "punk::set_repl_last_unknown cannot operate directly in safe interp - install an alias to tsv::set repl last_unknown" + return + } + #tsv::* somehow working - possibly custom aliases for tsv functionality ? review + } + if {[info commands ::tsv::set] eq ""} { + puts stderr "set_repl_last_unknown - tsv unavailable!" + return + } + tsv::set repl last_unknown {*}$args + } + # --------------------------- + + #---------------- + #for var="val {a b c}" + #proc ::punk::val {{v {}}} {tailcall lindex $v} + #proc ::punk::val {{v {}}} {return $v} ;#2023 - approx 2x faster than the tailcall lindex version + proc ::punk::val [list [list v [purelist]]] {return $v} + #---------------- + + proc configure_unknown {} { + #----------------------------- + #these are critical e.g core behaviour or important for repl displaying output correctly + + + #can't use know - because we don't want to return before original unknown body is called. + proc ::unknown {args} [string cat { + #set ::punk::last_run_display [list] + #set ::repl::last_unknown [lindex $args 0] ;#jn + #tsv::set repl last_unknown [lindex $args 0] ;#REVIEW + punk::set_repl_last_unknown [lindex $args 0] + }][info body ::unknown] + + + #handle process return dict of form {exitcode num etc blah} + #ie when the return result as a whole is treated as a command + #exitcode must be the first key + know {[lindex $args 0 0] eq "exitcode"} { + uplevel 1 [list exitcode {*}[lrange [lindex $args 0] 1 end]] + } + + + #----------------------------- + # + # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + #todo - repl output info that it was evaluated as an expression + #know {[expr $args] || 1} {expr $args} + know {[expr $args] || 1} {tailcall expr $args} + + #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc + #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) + know {[regexp {^([+-]*[0-9_]+)\.\.([+-]*[0-9_]+)$} [lindex $args 0 0] -> from to]} {punk::lib::range $from $to} + + + #NOTE: + #we don't allow setting namespace qualified vars in the lhs assignment pattern. + #The principle is that we shouldn't be setting vars outside of the immediate calling scope. + #(It would also be difficult and error-prone and generally make the pipelines less re-usable and reliable) + #Therefore ::nswhatever::blah= x is the pipeline: blah= x - where the corresponding command, if any is first resolved in ::nswhatever + #We will require that the namespace already exists - which is consistent with if the command were to be run without unknown + proc ::punk::_unknown_assign_dispatch {matchedon pattern equalsrhs args} { + set tail [lassign $args hd] + #puts "-> _unknown_assign_dispatch '$partzerozero' pattern:'$pattern' equalsrhs:'$equalsrhs' args:'$args' argshd:'$hd' argstail:'$tail'" + if {$hd ne $matchedon} { + if {[llength $tail]} { + error "unknown_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $tail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs tail + regexp {^([^\t\r\n=]*)\=([^\r\n]*)} $hd _ pattern fullrhs + lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs tail + } + #NOTE: - it doesn't make sense to call 'namespace' qualifiers or 'namespace tail' on a compound hd such as v,::etc= blah + # we only look at leftmost namespace-like thing and need to take account of the pattern syntax + # e.g for ::etc,'::x'= + # the ns is :: and the tail is etc,'::x'= + # (Tcl's namespace qualifiers/tail won't help here) + if {[string match ::* $hd]} { + set patterns [punk::pipe::lib::_split_patterns_memoized $hd] + #get a pair-list something like: {::x /0} {etc {}} + set ns [namespace qualifiers [lindex $patterns 0 0]] + set nslen [string length $ns] + set patterntail [string range $ns $nslen end] + } else { + set ns "" + set patterntail $pattern + } + 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]] + #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 + #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'" + #we call the namespaced function - we don't evaluate it *in* the namespace. + #REVIEW + #warn for now...? + #tailcall $pattern=$equalsrhs {*}$args + tailcall $pattern=$rhsmapped {*}$tail + } + } + #puts "--->nscurrent [uplevel 1 [list ::namespace current]]" + #ignore the namespace.. + #We could interpret the fact that the nonexistant pipe was called with a namespace to indicate that's where the pipecommand should be created.. + #But.. we would need to ensure 1st (compiling) invocation runs the same way as subsequent invocations. + #namespace evaling match_assign here probably wouldn't accomplish that and may create surprises with regards to where lhs vars(if any) are created + tailcall ::punk::match_assign $patterntail $equalsrhs {*}$tail + #return [uplevel 1 [list ::punk::match_assign $varspecs $rhs $tail]] + } + #variable re_assign {^([^\r\n=\{]*)=(.*)} + #characters directly following = need to be assigned to the var even if they are escaped whitespace (e.g \t \r \n) + #unescaped whitespace causes the remaining elements to be part of the tail -ie are appended to the var as a list + #e.g x=a\nb c + #x will be assigned the list {a\nb c} ie the spaces between b & c are not maintained + # + #know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + #know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + + proc ::punk::_unknown_compare {val1 val2 args} { + if {![string length [string trim $val2]]} { + if {[llength $args] > 1} { + #error "Extra args after comparison operator ==. usage e.g : \$var1==\$var2 or \$var1==\$var2 + 2" + set val2 [string cat {*}[lrange $args 1 end]] + return [expr {$val1 eq $val2}] + } + return $val1 + } elseif {[llength $args] == 1} { + #simple comparison + if {[string is digit -strict $val1$val2]} { + return [expr {$val1 == $val2}] + } else { + return [string equal $val1 $val2] + } + } elseif {![catch {expr $val2 {*}[lrange $args 1 end]} evaluated]} { + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } else { + set evaluated [uplevel 1 [list {*}$val2 {*}[lrange $args 1 end]]] + if {[string is digit -strict $val1$evaluated]} { + return [expr {$val1 == $evaluated}] + } else { + return [expr {$val1 eq $evaluated}] + } + } + } + #ensure == is after = in know sequence + #.* on left is pretty broad - todo: make it a little more specific to avoid unexpected interactions + know {[regexp {(.*)==(.*)} [lindex $args 0] _ val1 val2]} {tailcall ::punk::_unknown_compare $val1 $val2 {*}$args} + #.= must come after = here to ensure it comes before = in the 'unknown' proc + #set punk::re_dot_assign {([^=]*)\.=(.*)} + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] _ varspecs rhs]} { + # set tail [expr {([lindex $args 0] eq [lindex $args 0 0]) ? [lrange $args 1 end] : [concat [lrange [lindex $args 0] 1 end] [lrange $args 1 end] ] }] + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + # } + # + + + proc ::punk::_unknown_dot_assign_dispatch {partzerozero pattern equalsrhs args} { + #puts stderr ". unknown dispatch $partzerozero" + set argstail [lassign $args hd] + + #this equates to auto-flattening the head.. which seems like a bad idea, the structure was there for a reason. + #we should require explicit {*} expansion if the intention is for the args to be joined in at that level. + #expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + + if {$hd ne $partzerozero} { + if {[llength $argstail]} { + error "unknown_dot_assign_dispatch: pipeline with args unexpanded. Try {*}\$pipeline $argstail" + } + #regexp $punk::re_assign $hd _ pattern equalsrhs + #we assume the whole pipeline has been provided as the head + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + #regexp {^([^ \t\r\n=\{]*)\.=([^ \t\r\n]*)(.*)} $hd _ pattern equalsrhs argstail + + regexp {^([^ \t\r\n=\{]*)\.=([^\r\n]*)} $hd _ pattern fullrhs + lassign [punk::pipe::lib::_rhs_tail_split $fullrhs] equalsrhs argstail + } + #tailcall ::punk::match_assign $pattern $equalsrhs {*}$argstail + + + return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]] + } + + # + know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + + #variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + + #add escaping backslashes to a value + #matching odd keys in dicts using pipeline syntax can be tricky - as + #e.g + #set ktest {a"b} + #@@[escv $ktest].= list a"b val + #without escv: + #@@"a\\"b".= list a"b val + #with more backslashes in keys the escv use becomes more apparent: + #set ktest {\\x} + #@@[escv $ktest].= list $ktest val + #without escv we would need: + #@@\\\\\\\\x.= list $ktest val + proc escv {v} { + #https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically + #thanks to DKF + regsub -all {\W} $v {\\&} + } + interp alias {} escv {} punk::escv + #review + #set v "\u2767" + # + #escv $v + #\ + #the + + + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { + # set argstail [lassign $args hd] + # #set tail [expr {($hd eq $partzerozero) ? $argstail : [concat [lrange $hd 1 end] $argstail ] }] ;#!WRONG. expr will convert some numbers to scientific notation - this is premature/undesirable! + # #avoid using the return from expr and it works: + # expr {($hd eq $partzerozero) ? [set tail $argstail] : [set tail [concat [lrange $hd 1 end] $argstail ]] } + # + # tailcall ::punk::match_exec $varspecs $rhs {*}$tail + # #return [uplevel 1 [list ::punk::match_exec $varspecs $rhs {*}$tail]] + #} + } + configure_unknown + #if client redefines 'unknown' after package require punk, they must call punk::configure_unknown afterwards. + # + + #main Pipe initiator function - needed especially if 'unknown' not configured to interpret x.= x= etc + #Should theoretically be slightly faster.. but pipelines are relatively slow until we can get pipeline compiling and optimisation. + proc % {args} { + set arglist [lassign $args assign] ;#tail, head + if {$assign eq ".="} { + tailcall {*}[list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + tailcall {*}[list ::punk::pipeline = "" "" {*}$arglist] + } + + set is_script [punk::pipe::lib::arg_is_script_shaped $assign] + + if {!$is_script && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=\{]*)\.=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=\{]*)=$} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::% unable to interpret pipeline '$args'" "% $args" [list pipesyntax unable_to_interpret] + } + } else { + if {$is_script} { + set cmdlist [list ::punk::pipeline "script" "" "" {*}$args] + } else { + set cmdlist [list ::punk::pipeline ".=" "" "" {*}$args] + } + } + tailcall {*}$cmdlist + + + #result-based mismatch detection can probably never work nicely.. + #we need out-of-band method to detect mismatch. Otherwise we can't match on mismatch results! + # + set result [uplevel 1 $cmdlist] + #pipeline result not guaranteed to be a proper list so we can't use list methods to directly look for 'binding mismatch' + #.. but if we use certain string methods - we shimmer the case where the main result is a list + #string match doesn't seem to change the rep.. though it does generate a string rep. + #puts >>1>[rep $result] + if {[catch {lrange $result 0 1} first2wordsorless]} { + #if we can't get as a list then it definitely isn't the semi-structured 'binding mismatch' + return $result + } else { + if {$first2wordsorless eq {binding mismatch}} { + error $result + } else { + #puts >>2>[rep $result] + return $result + } + } + } + + proc ispipematch {args} { + expr {[lindex [uplevel 1 [list 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}} + proc pipematch {args} { + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + variable re_dot_assign + variable re_assign + + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string index $assign end] eq "="} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + # set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + # set dumbeditor {\}} + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax punk::pipematch unable to interpret pipeline '$args'" "pipematch $args" [pipesyntax unable_to_interpret] + } + } else { + set cmdlist $args + #script? + #set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + #puts stderr "pipematch erroptions:$erroptions" + #debug.punk.pipe {pipematch error $result} 4 + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + #puts stderr "pipematch converting error to {error {mismatch }}" + return [list error [list mismatch $result]] + } + } + pipesyntax { + #error $result + return -options $erroptions $result + } + casematch { + return $result + } + } + #return [dict create error [dict create reason $result]] + return [list error [list reason $result]] + } else { + return [list ok [list result $result]] + #debug.punk.pipe {pipematch result $result } 4 + #return [dict create ok [dict create result $result]] + } + } + + proc pipenomatchvar {varname args} { + if {[string first = $varname] >= 0} { + #first word "pipesyntax" is looked for by pipecase + error "pipesyntax pipenomatch expects a simple varname as first argument" "pipenomatchvar $varname $args" [list pipesyntax expected_simple_varname] + } + #debug.punk.pipe {pipematch level [info level] levelinfo [info level 0]} 2 + + set assign [lindex $args 0] + set arglist [lrange $args 1 end] + if {[string first = $assign] >= 0} { + variable re_dot_assign + variable re_assign + #what if we get passed a script block containing = ?? e.g {error x=a} + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + } elseif {[regexp $re_dot_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs $rhs {*}$arglist] + } elseif {[regexp $re_assign $assign _ returnvarspecs rhs]} { + set cmdlist [list ::punk::pipeline = $returnvarspecs $rhs {*}$arglist] + } else { + debug.punk.pipe {[a+ yellow bold] Unexpected arg following pipenomatchvar variable [a]} 0 + set cmdlist $args + #return [dict create error [dict create reason [dict create pipematch bad_first_word value $assign pipeline [list pipematch $assign {*}$args]]]] + } + } else { + set cmdlist $args + } + + upvar 1 $varname nomatchvar + if {[catch {uplevel 1 $cmdlist} result erroptions]} { + set ecode [dict get $erroptions -errorcode] + debug.punk.pipe {[a+ yellow bold]pipematchnomatch error $result[a]} 3 + if {[lindex $ecode 0] eq "pipesyntax"} { + set errordict [dict create error [dict create pipesyntax $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + if {[lrange $ecode 0 1] eq "binding mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + set errordict [dict create error [dict create mismatch $result]] + set nomatchvar $errordict + return -options $erroptions $result + } + set errordict [dict create error [dict create reason $result]] + set nomatchvar $errordict + #re-raise the error for pipeswitch to deal with + return -options $erroptions $result + } else { + debug.punk.pipe {pipematchnomatch result $result } 4 + set nomatchvar "" + #uplevel 1 [list set $varname ""] + #return raw result only - to pass through to pipeswitch + return $result + #return [dict create ok [dict create result $result]] + } + } + + #should only raise an error for pipe syntax errors - all other errors should be wrapped + proc pipecase {args} { + #debug.punk.pipe {pipecase level [info level] levelinfo [info level 0]} 9 + set arglist [lassign $args assign] + if {$assign eq ".="} { + set cmdlist [list ::punk::pipeline .= "" "" {*}$arglist] + } elseif {$assign eq "="} { + #set cmdlist [list ::punk::pipeline = "" "" {*}$arglist] + set cmdlist [list ::= {*}$arglist] + } elseif {![punk::pipe::lib::arg_is_script_shaped $assign] && [string first "=" $assign] >= 0} { + #set re_dotequals {^([^ \t\r\n=\{]*)\.=$} + #set dumbeditor {\}} + #set re_equals {^([^ \t\r\n=\{]*)=$} + #set dumbeditor {\}} + + if {[regexp {^([^ \t\r\n=]*)\.=.*} $assign _ returnvarspecs]} { + set cmdlist [list ::punk::pipeline .= $returnvarspecs "" {*}$arglist] + } elseif {[regexp {^([^ \t\r\n=]*)=.*} $assign _ returnvarspecs]} { + set cmdlist [list $assign {*}$arglist] + #set cmdlist [list ::punk::pipeline = $returnvarspecs "" {*}$arglist] + } else { + error "pipesyntax pipecase unable to interpret pipeline '$args'" + } + #todo - account for insertion-specs e.g x=* x.=/0* + } else { + #script? + set cmdlist [list ::punk::pipeline .= "" "" {*}$args] + } + + + if {[catch {uplevel 1 [list ::if 1 $cmdlist]} result erroptions]} { + #puts stderr "====>>> result: $result erroptions" + set ecode [dict get $erroptions -errorcode] + switch -- [lindex $ecode 0] { + pipesyntax { + #error $result + return -options $erroptions $result + } + casenomatch { + return -options $erroptions $result + } + binding { + if {[lindex $ecode 1] eq "mismatch"} { + #error {reason xxx} should only be returned for underlying tcl errors. error {someotherkey xxx} for structured errors such as a binding mismatch + #return [dict create error [dict create mismatch $result]] + # + #NOTE: casemismatch is part of the api for pipecase. It is a casemismatch rather than an error - because for a pipecase - a casemismatch is an expected event (many casemismatches - one match) + return [dict create casemismatch $result] + } + } + } + + #we can't always treat $result as a list - may be an error string which can't be represented as a list, and there may be no useful errorCode + #todo - use errorCode instead + if {[catch {lindex $result 0} word1]} { + #tailcall error $result + return -options $erroptions $result + } else { + switch -- $word1 { + switcherror {-} funerror { + error $result "pipecase [lsearch -all -inline $args "*="]" + } + resultswitcherror {-} resultfunerror { + #recast the error as a result without @@ok wrapping + #use the tailcall return to stop processing other cases in the switch! + tailcall return [dict create error $result] + } + ignore { + #suppress error, but use normal return + return [dict create error [dict create suppressed $result]] + } + default { + #normal tcl error + #return [dict create error [dict create reason $result]] + tailcall error $result "pipecase $args" [list caseerror] + } + } + } + } else { + tailcall return -errorcode [list casematch] [dict create ok [dict create result $result]] + } + } + + #note that pipeswitch deliberately runs in callers scope to have direct access to variables - it is akin to a control structure. + #It also - somewhat unusually accepts args - which we provide as 'switchargs' + #This is unorthodox/risky in that it will clobber any existing var of that name in callers scope. + #Solve using documentation.. consider raising error if 'switchargs' already exists, which would require user to unset switchargs in some circumstances. + proc pipeswitch {pipescript args} { + #set nextargs $args + #unset args + #upvar args upargs + #set upargs $nextargs + upvar switchargs switchargs + set switchargs $args + uplevel 1 [::list ::if 1 $pipescript] + } + #static-closure version - because we shouldn't be writing back to calling context vars directly + #Tcl doesn't (2023) have mutable closures - but for functional pipeline composition - we probably don't want that anyway! + #pipeswitchc is preferable to pipeswitch in that we can access context without risk of affecting it, but is less performant. (particularly in global scope.. but that probably isn't an important usecase) + proc pipeswitchc {pipescript args} { + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list info vars] + } else { + set get_vars [list info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars switchargs] + set vars [lreplace $vars $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + lappend binding [list switchargs $args] + apply [list $binding $pipescript [uplevel 1 {::namespace current}]] + } + + proc pipedata {data args} { + #puts stderr "'$args'" + set r $data + for {set i 0} {$i < [llength $args]} {incr i} { + set e [lindex $args $i] + #review: string is list is as slow as catch {llength $e} - and also affects ::errorInfo unlike other string is commands. bug/enhancement report? + if {![string is list $e]} { + #not a list - assume script and run anyway + set r [apply [list {data} $e] $r] + } else { + if {[llength $e] == 1} { + switch -- $e { + > { + #output to calling context. only pipedata return value and '> varname' should affect caller. + incr i + uplevel 1 [list set [lindex $args $i] $r] + } + % {-} pipematch {-} ispipematch { + incr i + set e2 [lindex $args $i] + #set body [list $e {*}$e2] + #append body { $data} + + set body [list $e {*}$e2] + append body { {*}$data} + + + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + pipeswitch {-} pipeswitchc { + #pipeswitch takes a script not a list. + incr i + set e2 [lindex $args $i] + set body [list $e $e2] + #pipeswitch takes 'args' - so expand $data when in pipedata context + append body { {*}$data} + #use applylist instead of uplevel when in pipedata context! + #can use either switchdata/data but not vars in calling context of 'pipedata' command. + #this is consistent with pipeswitch running in a % / .= pipeline which can only access vars in immediate calling context. + set applylist [list {data} $body] + #puts stderr $applylist + set r [apply $applylist $r] + } + default { + #puts "other single arg: [list $e $r]" + append e { $data} + set r [apply [list {data} $e] $r] + } + } + } elseif {[llength $e] == 0} { + #do nothing - pass data through + #leave r as is. + } else { + set r [apply [list {data} $e] $r] + } + } + } + return $r + } + + + proc scriptlibpath {{shortname {}} args} { + upvar ::punk::config::running running_config + set scriptlib [dict get $running_config scriptlib] + if {[string match "lib::*" $shortname]} { + set relpath [string map [list "lib::" "" "::" "/"] $shortname] + set relpath [string trimleft $relpath "/"] + set fullpath $scriptlib/$relpath + } else { + set shortname [string trimleft $shortname "/"] + set fullpath $scriptlib/$shortname + } + return $fullpath + } + + + #useful for aliases e.g treemore -> xmore tree + proc xmore {args} { + if {[llength $args]} { + uplevel #0 [list {*}$args | more] + } else { + error "usage: punk::xmore args where args are run as {*}\$args | more" + } + } + + + #environment path as list + # + #return *appendable* pipeline - i.e no args via <| + proc path_list_pipe {{glob *}} { + if {$::tcl_platform(platform) eq "windows"} { + set sep ";" + } else { + # : ok for linux/bsd ... mac? + set sep ":" + } + set cond [string map [list $glob] {expr {[string length $item] && [string match $item]}}] + #env members such as ''path' not case sensitive on windows - but are on some other platforms (at least FreeBSD) + return [list .= set ::env(PATH) |> .=>2 string trimright $sep |> .=>1 split $sep |> list_filter_cond $cond] + } + proc path_list {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe + } + proc path {{glob *}} { + set pipe [punk::path_list_pipe $glob] + {*}$pipe |> list_as_lines + } + + #------------------------------------------------------------------- + #sh 'test' equivalent - to be used with exitcode of process + # + + #single evaluation to get exitcode + proc sh_test {args} { + set a1 [lindex $args 0] + if {$a1 in [list -b -c -d -e -f -h -L -s -S -x -w]} { + set a2 [lindex $args 1] + if { + ![catch { + set attrinfo [file attributes $a2] + } errM] + } { + if {[dict exists $attrinfo -vfs] && [dict get $attrinfo -vfs] == 1} { + puts stderr "WARNING: external 'test' being called on vfs path. External command will probably not have access to the vfs. Use 'TEST' for Tcl view of vfs mounted filesystems." + } + } + } + tailcall run test {*}$args + } + + #whether v is an integer from perspective of unix test command. + #can be be bigger than a tcl int or wide ie bignum - but must be whole number + #test doesn't handle 1.0 - so we shouldn't auto-convert + proc is_sh_test_integer {v} { + if {[string first . $v] >= 0 || [string first e $v] >= 0} { + return false + } + #if it is double but not sci notation and has no dots - then we can treat as a large integer for 'test' + if {[string is double -strict $v]} { + return true + } else { + return false + } + } + #can use double-evaluation to get true/false + #faster tcl equivalents where possible to accuratley provide, and fallthrough to sh for compatibility of unimplemented + #The problem with fallthrough is that sh/bash etc have a different view of existant files + #e.g unix files such as /dev/null vs windows devices such as CON,PRN + #e.g COM1 is mapped as /dev/ttyS1 in wsl (?) + #Note also - tcl can have vfs mounted file which will appear as a directory to Tcl - but a file to external commands! + #We will stick with the Tcl view of the file system. + #User can use their own direct calls to external utils if + #Note we can't support $? directly in Tcl - script would have to test ${?} or use [set ?] + proc sh_TEST {args} { + upvar ? lasterr + set lasterr 0 + set a1 [lindex $args 0] + set a2 [lindex $args 1] + set a3 [lindex $args 2] + set fileops [list -b -c -d -e -f -h -L -s -S -x -w] + if {[llength $args] == 1} { + #equivalent of -n STRING + set boolresult [expr {[string length $a1] != 0}] + } elseif {[llength $args] == 2} { + if {$a1 in $fileops} { + if {$::tcl_platform(platform) eq "windows"} { + #e.g trailing dot or trailing space + if {[punk::winpath::illegalname_test $a2]} { + #protect with \\?\ to stop windows api from parsing + #will do nothing if already prefixed with \\?\ + + set a2 [punk::winpath::illegalname_fix $a2] + } + } + } + switch -- $a1 { + -b { + #dubious utility on FreeBSD, windows? + #FreeBSD has dropped support for block devices - stating 'No serious applications rely on block devices' + #Linux apparently uses them though + if{[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "blockSpecial"}] + } else { + set boolresult false + } + } + -c { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "characterSpecial"}] + } else { + set boolresult false + } + } + -d { + set boolresult [file isdirectory $a2] + } + -e { + set boolresult [file exists $a2] + } + -f { + #e.g on windows CON,NUL + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "file"}] + } else { + set boolresult false + } + } + -h {-} + -L { + set boolresult [expr {[file type $a2] eq "link"}] + } + -s { + set boolresult [expr {[file exists $a2] && ([file size $a2] > 0)}] + } + -S { + if {[file exists $a2]} { + set boolresult [expr {[file type $a2] eq "socket"}] + } else { + set boolresult false + } + } + -x { + set boolresult [expr {[file exists $a2] && [file executable $a2]}] + } + -w { + set boolresult [expr {[file exists $a2] && [file writable $a2]}] + } + -z { + set boolresult [expr {[string length $a2] == 0}] + } + -n { + set boolresult [expr {[string length $a2] != 0}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + } + } elseif {[llength $args] == 3} { + switch -- $a2 { + "=" { + #test does string comparisons + set boolresult [string equal $a1 $a3] + } + "!=" { + #string comparison + set boolresult [expr {$a1 ne $a3}] + } + "-eq" { + #test expects a possibly-large integer-like thing + #shell scripts will + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 == $a3}] + } + "-ge" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 >= $a3}] + } + "-gt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 > $a3}] + } + "-le" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 <= $a3}] + } + "-lt" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 < $a3}] + } + "-ne" { + if {![is_sh_test_integer $a1]} { + puts stderr "sh_TEST: invalid integer '$a1'" + set lasterr 2 + return false + } + if {![is_sh_test_integer $a3]} { + puts stderr "sh_TEST: invalid integer '$a3'" + set lasterr 2 + return false + } + set boolresult [expr {$a1 != $a3}] + } + default { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + } + } else { + puts stderr "sh_TEST: delegating 'test $args' to external 'test' command" + #set boolresult [apply {arglist {uplevel #0 [runx test {*}$arglist]} ::} $args] + set callinfo [runx test {*}$args] + set errinfo [dict get $callinfo stderr] + set exitcode [dict get $callinfo exitcode] + if {[string length $errinfo]} { + puts stderr "sh_TEST error in external call to 'test $args': $errinfo" + set lasterr $exitcode + } + if {$exitcode == 0} { + set boolresult true + } else { + set boolresult false + } + } + + #normalize 1,0 etc to true,false + #we want to make it obvious we are not just reporting exitcode 0 for example - which represents true in tcl. + if {$boolresult} { + return true + } else { + if {$lasterr == 0} { + set lasterr 1 + } + return false + } + } + proc sh_echo {args} { + tailcall run echo {*}$args + } + proc sh_ECHO {args} { + #execute the result of the run command - which is something like: 'exitcode n' - to get true/false + tailcall apply {arglist {uplevel #0 [run echo {*}$arglist]} ::} $args + } + + + #sh style true/false for process exitcode. 0 is true - everything else false + proc exitcode {args} { + set c [lindex $args 0] + if {[string is integer -strict $c]} { + #return [expr {$c == 0}] + #return true/false to make it clearer we are outputting tcl-boolean inverse mapping from the shell style 0=true + if {$c == 0} { + return true + } else { + return false + } + } else { + return false + } + } + #------------------------------------------------------------------- + + namespace export help aliases alias exitcode % pipedata pipecase pipeline pipematch pipeswitch pipeswitchc pipecase linelist linesort inspect list_as_lines val treemore + + #namespace ensemble create + + + #tilde + #These aliases work fine for interactive use - but the result is always a string int-rep + #interp alias {} ~ {} file join $::env(HOME) ;#HOME must be capitalized to work cross platform (lowercase home works on windows - but probably not elsewhere) + #interp alias {} ~ {} apply {args {file join $::env(HOME) $args}} + proc ~ {args} { + set hdir [punk::objclone $::env(HOME)] + file pathtype $hdir + set d $hdir + #use the file join 2-arg optimisation to avoid losing path-rep - probably doesn't give any advantage on all Tcl versions + foreach a $args { + set d [file join $d $a] + } + file pathtype $d + return [punk::objclone $d] + } + interp alias {} ~ {} punk::~ + + + #maint - punk::args has similar + #this is largely obsolete - uses dict for argspecs (defaults) instead of textblock as in punk::args + #textblock has more flexibility in some ways - but not as easy to manipulate especially with regards to substitutions + #todo - consider a simple wrapper for punk::args to allow calling with dict of just name and default? + #JMN + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values + #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. + #only supports -flag val pairs, not solo options + #If an option is supplied multiple times - only the last value is used. + #TODO - remove + proc get_leading_opts_and_values {defaults rawargs args} { + if {[llength $defaults] % 2 != 0} { + error "get_leading_opts_and_values expected first argument 'defaults' to be a dictionary" + } + dict for {k v} $defaults { + if {![string match -* $k]} { + error "get_leading_opts_and_values problem with supplied defaults. Expect each key to begin with a dash. Got key '$k'" + } + } + #puts "--> [info frame -2] <--" + set cmdinfo [dict get [info frame -2] cmd] + #we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work + #hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc + #we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly) + set caller [regexp -inline {\S+} $cmdinfo] + + #if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace" + if {$caller eq "namespace"} { + set caller "get_leading_opts_and_values called from namespace" + } + + # ------------------------------ + if {$caller ne "get_leading_opts_and_values"} { + #check our own args + lassign [get_leading_opts_and_values {-anyopts 0 -minvalues 0 -maxvalues -1} $args] _o ownopts _v ownvalues + if {[llength $ownvalues] > 0} { + error "get_leading_opts_and_values expected: a dictionary of defaults, a list of args and at most two option pairs -minvalues and -maxvalues - got extra arguments: '$ownvalues'" + } + set opt_minvalues [dict get $ownopts -minvalues] + set opt_maxvalues [dict get $ownopts -maxvalues] + set opt_anyopts [dict get $ownopts -anyopts] + } else { + #don't check our own args if we called ourself + set opt_minvalues 0 + set opt_maxvalues 0 + set opt_anyopts 0 + } + # ------------------------------ + + if {[set eopts [lsearch $rawargs "--"]] >= 0} { + set values [lrange $rawargs $eopts+1 end] + set arglist [lrange $rawargs 0 $eopts-1] + } else { + if {[lsearch $rawargs -*] >= 0} { + #to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex + set i 0 + foreach {k v} $rawargs { + if {![string match -* $k]} { + break + } + if {$i + 1 >= [llength $rawargs]} { + #no value for last flag + error "bad options for $caller. No value supplied for last option $k" + } + incr i 2 + } + set arglist [lrange $rawargs 0 $i-1] + set values [lrange $rawargs $i end] + } else { + set values $rawargs ;#no -flags detected + set arglist [list] + } + } + if {$opt_maxvalues == -1} { + #only check min + if {[llength $values] < $opt_minvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues" + } + } else { + if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} { + if {$opt_minvalues == $opt_maxvalues} { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues" + } else { + error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive" + } + } + } + + if {!$opt_anyopts} { + set checked_args [dict create] + for {set i 0} {$i < [llength $arglist]} {incr i} { + #allow this to error out with message indicating expected flags + dict set checked_args [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $defaults] [lindex $arglist $i]] [lindex $arglist $i+1] + incr i ;#skip val + } + } else { + set checked_args $arglist + } + set opts [dict merge $defaults $checked_args] + + #maintain order of opts $opts values $values as caller may use lassign. + return [dict create opts $opts values $values] + } + + + #-------------------------------------------------- + #some haskell-like operations + #group equivalent + #http://zvon.org/other/haskell/Outputlist/group_f.html + #as we can't really distinguish a single element list from a string we will use 2 functions + proc group_list1 {lst} { + set out [list] + set prev [lindex $lst 0] + set g [list] + foreach i $lst { + if {$i eq $prev} { + lappend g $i + } else { + lappend out $g + set g [list $i] + } + set prev $i + } + lappend out $g + return $out + } + proc group_list {lst} { + set out [list] + set next [lindex $lst 1] + set tail [lassign $lst x] + set g [list $x] + set y [lindex $tail 0] + set last_condresult [expr {$x}] + set n 1 ;#start at one instead of zero for lookahead + foreach x $tail { + set y [lindex $tail $n] + set condresult [expr {$x}] + if {$condresult eq $last_condresult} { + lappend g $x + } else { + lappend out $g + set g [list $x] + set last_condresult $condresult + } + incr n + } + lappend out $g + return $out + } + + #NOT attempting to match haskell other than in overall concept. + # + #magic var-names are a bit of a code-smell. But submitting only an expr argument is more Tcl-like than requiring an 'apply' specification. + #Haskell seems to take an entire lambda so varnames can be user-specified - but the 'magic' there is in it's choice of submitting 2 elements at a time + #We could do similar .. but we'll focus on comprehensibility for the basic cases - especially as begginning and end of list issues could be confusing. + # + #vars: index prev, prev0, prev1, item, next, next0, next1,nextr, cond + #(nextr is a bit obscure - but basically means next-repeat ie if no next - use same value. just once though.) + #group by cond result or first 3 wordlike parts of error + #e.g group_list_by {[lindex $item 0]} {{a 1} {a 2} {b 1}} + proc group_list_by {cond lst} { + set out [list] + set prev [list] + set next [lindex $lst 1] + set tail [lassign $lst item] + set g [list $item] + set next [lindex $tail 0] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set last_condresult [apply { + {index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: 0 ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } 0 $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + set n 1 ;#start at one instead of zero for lookahead + #note - n also happens to matchi zero-based index of original list + set prev $item + foreach item $tail { + set next [lindex $tail $n] + if {$prev eq ""} { + set prev0 0 + set prev1 1 + set prevr $item + } else { + set prev0 $prev + set prev1 $prev + set prevr $prev + } + if {$next eq ""} { + set next0 0 + set next1 1 + set nextr $item + } else { + set next0 $next + set next1 $next + set nextr $next + } + set condresult [apply { + {index cond prev prev0 prev1 prevr item next next0 next1 nextr} { + if {[catch {expr $cond} r]} { + puts stderr "index: $index ERROR $r" + set wordlike_parts [regexp -inline -all {\S+} $r] + set r [list ERROR {*}[lrange $wordlike_parts 0 2]] + } + set r + } + } $n $cond $prev $prev0 $prev1 $prevr $item $next $next0 $next1 $nextr] + if {$condresult eq $last_condresult} { + lappend g $item + } else { + lappend out $g + set g [list $item] + set last_condresult $condresult + } + incr n + set prev $item + } + lappend out $g + return $out + } + + #group_numlist ? preserve representation of numbers rather than use string comparison? + + + # - group_string + #.= punk::group_string "aabcccdefff" + # aa b ccc d e fff + proc group_string {str} { + lmap v [group_list [split $str ""]] {string cat {*}$v} + } + + #lists may be of unequal lengths + proc transpose_lists {list_rows} { + set res {} + #set widest [pipedata $list_rows {lmap v $data {llength $v}} {tcl::mathfunc::max {*}$data}] + set widest [tcl::mathfunc::max {*}[lmap v $list_rows {llength $v}]] + for {set j 0} {$j < $widest} {incr j} { + set newrow {} + foreach oldrow $list_rows { + if {$j >= [llength $oldrow]} { + continue + } else { + lappend newrow [lindex $oldrow $j] + } + } + lappend res $newrow + } + return $res + } + proc transpose_strings {list_of_strings} { + set charlists [lmap v $list_of_strings {split $v ""}] + set tchars [transpose_lists $charlists] + lmap v $tchars {string cat {*}$v} + } + + package require struct::matrix + #transpose a serialized matrix using the matrix command + #Note that we can have missing row values below and to right + #e.g + #a + #a b + #a + proc transpose_matrix {matrix_rows} { + set mcmd [struct::matrix] + #serialization format: numcols numrows rowlist + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + $mcmd transpose + set result [lindex [$mcmd serialize] 2] ;#strip off dimensions + $mcmd destroy + return $result + } + + set objname [namespace current]::matrixchain + if {$objname ni [info commands $objname]} { + oo::class create matrixchain { + variable mcmd + constructor {matrixcommand} { + puts "wrapping $matrixcommand with [self]" + set mcmd $matrixcommand + } + destructor { + puts "matrixchain destructor called for [self] (wrapping $mcmd)" + $mcmd destroy + } + method unknown {args} { + if {[llength $args]} { + switch -- [lindex $args 0] { + add - delete - insert - transpose - sort - set - swap { + $mcmd {*}$args + return [self] ;#result is the wrapper object for further chaining in pipelines + } + default { + tailcall $mcmd {*}$args + } + } + } else { + #will error.. but we should pass that on + tailcall $mcmd + } + } + } + } + + #review + #how do we stop matrix pipelines from leaving commands around? i.e how do we call destroy on the matrixchain wrapper if not explicitly? + #Perhaps will be solved by: Tip 550: Garbage collection for TclOO + #Theoretically this should allow tidy up of objects created within the pipeline automatically + #If the object name is placed in the pipeline variable dict then it should survive across segment apply scripts and only go out of scope at the end. + proc matrix_command_from_rows {matrix_rows} { + set mcmd [struct::matrix] + set widest [tcl::mathfunc::max {*}[lmap v $matrix_rows {llength $v}]] + $mcmd deserialize [list [llength $matrix_rows] $widest $matrix_rows] + #return $mcmd + set wrapper [punk::matrixchain new $mcmd] + } + + #-------------------------------------------------- + + proc list_filter_cond {itemcond listval} { + set filtered_list [list] + set binding {} + if {[info level] == 1} { + #up 1 is global + set get_vars [list ::info vars] + } else { + set get_vars [list ::info locals] + } + set vars [uplevel 1 {*}$get_vars] + set posn [lsearch $vars item] + set vars [lreplace $vars $posn $posn] + foreach v $vars { + upvar 1 $v var + if {(![array exists var]) && [info exists var]} { + lappend binding [list $v $var] ;#values captured as defaults for apply args. + } + } + #lappend binding [list item $args] + + #puts stderr "binding: [join $binding \n]" + #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]]]} { + lappend filtered_list $item + } + } + return $filtered_list + } + + + proc ls {args} { + if {![llength $args]} { + set args [list [pwd]] + } + if {[llength $args] == 1} { + return [glob -nocomplain -tails -dir [lindex $args 0] *] + } else { + set result [dict create] + foreach a $args { + set k [file normalize $a] + set contents [glob -nocomplain -tails -dir $a *] + dict set result $k $contents + } + return $result + } + } + + + #linelistraw is essentially split $text \n so is only really of use for pipelines, where the argument order is more convenient + #like linelist - but keeps leading and trailing empty lines + #single \n produces {} {} + #the result can be joined to reform the arg if a single arg supplied + # + proc linelistraw {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + lappend linelist {*}$nlsplit + } + #return [split $text \n] + return $linelist + } + proc linelist1 {args} { + set linelist [list] + foreach {a} $args { + set nlsplit [split $a \n] + set start 0 + set end "end" + + if {[lindex $nlsplit 0] eq ""} { + set start 1 + } + if {[lindex $nlsplit end] eq ""} { + set end "end-1" + } + set alist [lrange $nlsplit $start $end] + lappend linelist {*}$alist + } + return $linelist + } + + + #An implementation of a notoriously controversial metric. + proc LOC {args} { + set argspecs [subst { + @dynamic + @id -id ::punk::LOC + @cmd -name punk::LOC -help\ + "LOC - lines of code. + An implementation of a notoriously controversial metric" + -dir -default "\uFFFF" + -exclude_dupfiles -default 1 -type boolean + ${[punk::args::resolved_def ::punk::path::treefilenames -antiglob_paths]} + -exclude_punctlines -default 1 -type boolean + -show_largest -default 0 -type integer -help\ + "Report the top largest linecount files. + The value represents the number of files + to report on." + #we could map away whitespace and use string is punct - but not as flexible? review + -punctchars -default { [list \{ \} \" \\ - _ + = . > , < ' : \; ` ~ ! @ # \$ % ^ & * \[ \] ( ) | / ?] } + }] + set argd [punk::args::get_dict $argspecs $args] + lassign [dict values $argd] leaders opts values received + set searchspecs [dict values $values] + + # -- --- --- --- --- --- + set opt_dir [dict get $opts -dir] + if {$opt_dir eq "\uFFFF"} { + set opt_dir [pwd] ;#pwd can take over a ms on windows in a not terribly deep path even with SSDs - so as a general rule we don't use it in the original defaults list + } + # -- --- --- --- --- --- + set opt_exclude_dupfiles [dict get $opts -exclude_dupfiles] + set opt_exclude_punctlines [dict get $opts -exclude_punctlines] ;#exclude lines that consist purely of whitespace and the chars in -punctchars + set opt_punctchars [dict get $opts -punctchars] + set opt_largest [dict get $opts -show_largest] + # -- --- --- --- --- --- + + + set filepaths [punk::path::treefilenames -dir $opt_dir {*}$searchspecs] + set loc 0 + set dupfileloc 0 + set seentails [dict create] + set seencksums [dict create] ;#key is cksum value is list of paths + set largestloc [dict create] + set dupfilecount 0 + set extensions [list] + set purepunctlines 0 + set dupinfo [dict create] + set has_hashfunc [expr {![catch {package require sha1}]}] + set notes "" + if {$has_hashfunc} { + set dupfilemech sha1 + if {$opt_exclude_punctlines} { + append notes "checksums are on content stripped of whitespace lines,trailing whitespace, and pure punct lines. Does not indicate file contents equal.\n" + } else { + append notes "checksums are on content stripped of whitespace lines and trailing whitespace. Does not indicate file contents equal.\n" + } + } else { + set dupfilemech filetail + append notes "dupfilemech filetail because sha1 not loadable\n" + } + foreach fpath $filepaths { + set isdupfile 0 + set floc 0 + set fpurepunctlines 0 + set ext [file extension $fpath] + if {$ext ni $extensions} { + lappend extensions $ext + } + if {[catch {fcat $fpath} contents]} { + puts stderr "Error processing $fpath\n $contents" + continue + } + set lines [linelist -line {trimright} -block {trimall} $contents] + if {!$opt_exclude_punctlines} { + set floc [llength $lines] + set comparedlines $lines + } else { + set mapawaypunctuation [list] + foreach p $opt_punctchars empty {} { + lappend mapawaypunctuation $p $empty + } + set comparedlines [list] + foreach ln $lines { + if {[string length [string trim [string map $mapawaypunctuation $ln]]] > 0} { + incr floc + lappend comparedlines $ln + } else { + incr fpurepunctlines + } + } + } + if {$opt_largest > 0} { + dict set largestloc $fpath $floc + } + if {$has_hashfunc} { + set cksum [sha1::sha1 [encoding convertto utf-8 [join $comparedlines \n]]] + if {[dict exists $seencksums $cksum]} { + set isdupfile 1 + incr dupfilecount + incr dupfileloc $floc + dict lappend seencksums $cksum $fpath + } else { + dict set seencksums $cksum [list $fpath] + } + } else { + if {[dict exists $seentails [file tail $fpath]]} { + set isdupfile 1 + incr dupfilecount + incr dupfileloc $floc + } + } + if {!$isdupfile || ($isdupfile && !$opt_exclude_dupfiles)} { + incr loc $floc + incr purepunctlines $fpurepunctlines + } + + dict lappend seentails [file tail $fpath] $fpath + #lappend seentails [file tail $fpath] + } + if {$has_hashfunc} { + dict for {cksum paths} $seencksums { + if {[llength $paths] > 1} { + dict set dupinfo checksums $cksum $paths + } + } + } + dict for {tail paths} $seentails { + if {[llength $paths] > 1} { + dict set dupinfo sametail $tail $paths + } + } + + if {$opt_exclude_punctlines} { + set result [dict create \ + loc $loc \ + filecount [llength $filepaths] \ + dupfiles $dupfilecount \ + dupfilemech $dupfilemech \ + dupfileloc $dupfileloc \ + dupinfo $dupinfo \ + extensions $extensions \ + purepunctuationlines $purepunctlines \ + notes $notes] + } else { + set result [dict create \ + loc $loc \ + filecount [llength $filepaths] \ + dupfiles $dupfilecount \ + dupfilemech $dupfilemech \ + dupfileloc $dupfileloc \ + dupinfo $dupinfo \ + extensions $extensions \ + notes $notes] + } + if {$opt_largest > 0} { + set largest_n [dict create] + set sorted [lsort -stride 2 -index 1 -decreasing -integer $largestloc] + set kidx 0 + for {set i 0} {$i < $opt_largest} {incr i} { + if {$kidx + 1 > [llength $sorted]} {break} + dict set largest_n [lindex $sorted $kidx] [lindex $sorted $kidx+1] + incr kidx 2 + } + dict set result largest $largest_n + } + return $result + } + + + #!!!todo fix - linedict is unfinished and non-functioning + #linedict based on indents + proc linedict {args} { + set data [lindex $args 0] + set opts [lrange $args 1 end] ;#todo + set nlsplit [split $data \n] + set rootindent -1 + set stepindent -1 + + #set wordlike_parts [regexp -inline -all {\S+} $lastitem] + set d [dict create] + set keys [list] + set i 1 + set firstkeyline "N/A" + set firststepline "N/A" + foreach ln $nlsplit { + if {![string length [string trim $ln]]} { + incr i + continue + } + set is_rootkey 0 + regexp {(\s*)(.*)} $ln _ space linedata + puts stderr ">>line:'$ln' [string length $space] $linedata" + set this_indent [string length $space] + if {$rootindent < 0} { + set firstkeyline $ln + set rootindent $this_indent + } + if {$this_indent == $rootindent} { + set is_rootkey 1 + } + if {$this_indent < $rootindent} { + error "bad root indentation ($this_indent) at line: $i smallest indent was set by first key line: $firstkeyline" + } + if {$is_rootkey} { + dict set d $linedata {} + lappend keys $linedata + } else { + if {$stepindent < 0} { + set stepindent $this_indent + set firststepline $ln + } + if {$this_indent == $stepindent} { + dict set d [lindex $keys end] $ln + } else { + if {($this_indent % $stepindent) != 0} { + error "bad indentation ($this_indent) at line: $i not a multiple of the first key indent $step_indent seen on $firststepline" + } + + #todo fix! + set parentkey [lindex $keys end] + lappend keys [list $parentkey $ln] + set oldval [dict get $d $parentkey] + if {[string length $oldval]} { + set new [dict create $oldval $ln] + } else { + dict set d $parentkey $ln + } + } + } + incr i + } + return $d + } + proc dictline {d} { + puts stderr "unimplemented" + set lines [list] + + return $lines + } + + + proc ooinspect {obj} { + set obj [uplevel 1 [list namespace which -command $obj]] + set isa [lmap type {object class metaclass} { + if {![info object isa $type $obj]} {continue} + set type + }] + foreach tp $isa { + switch -- $tp { + class { + lappend info {class superclasses} {class mixins} {class filters} + lappend info {class methods} {class methods} + lappend info {class variables} {class variables} + } + object { + lappend info {object class} {object mixins} {object filters} + lappend info {object methods} {object methods} + lappend info {object variables} {object variables} + lappend info {object namespace} {object vars} ;#{object commands} + } + } + } + + set result [dict create isa $isa] + foreach args $info { + dict set result $args [info {*}$args $obj] + foreach opt {-private -all} { + catch { + dict set result [list {*}$args $opt] [info {*}$args $obj $opt] + } + } + } + dict filter $result value {?*} + } + + punk::args::define { + @id -id ::punk::inspect + @cmd -name punk::inspect -help\ + "Function to display values - used pimarily in a punk pipeline. + The raw value arguments (not options) are always returned to pass + forward in the pipeline. + (pipeline data inserted at end of each |...> segment is passed as single item unless + inserted with an expanding insertion specifier such as .=>* ) + e.g1: + .= list a b c |v1,/1-end,/0>\\ + .=>* inspect -label i1 -- |>\\ + .=v1> inspect -label i2 -- |>\\ + string toupper + (3) i1: {a b c} {b c} a + (1) i2: a b c + + - A B C + " + -label -type string -default "" -help\ + "An optional label to help distinguish output when multiple + inspect statements are in a pipeline. This appears after the + bracketed count indicating number of values supplied. + e.g (2) MYLABEL: val1 val2 + The label can include ANSI codes. + e.g + inspect -label [a+ red]mylabel -- val1 val2 val3 + " + -limit -type int -default 20 -help\ + "When multiple values are passed to inspect - limit the number + of elements displayed in -channel output. + When truncation has occured an elipsis indication (...) will be appended. + e.g + .= lseq 20 to 50 by 3 |> .=>* inspect -limit 4 -- |> .=>* tcl::mathop::+ + (11) 20 23 26 29... + + - 385 + + For no limit - use -limit -1 + " + -channel -type string -default stderr -help\ + "An existing open channel to write to. If value is any of nul, null, /dev/nul + the channel output is disabled. This effectively disables inspect as the args + are simply passed through in the return to continue the pipeline. + " + -showcount -type boolean -default 1 -help\ + "Display a leading indicator in brackets showing the number of arg values present." + -ansi -type integer -default 1 -nocase 1 -choices {0 1 2 VIEW 3 VIEWCODES 4 VIEWSTYLES} -choicelabels { + 0 "Strip ANSI codes from display + of values. The disply output will + still be colourised if -ansibase has + not been set to empty string or + [a+ normal]. The stderr or stdout + channels may also have an ansi colour. + (see 'colour off' or punk::config)" + 1 "Leave value as is" + 2 "Display the ANSI codes and + other control characters inline + with replacement indicators. + e.g esc, newline, space, tab" + VIEW "Alias for 2" + 3 "Display as per 2 but with + colourised ANSI replacement codes." + VIEWCODES "Alias for 3" + 4 "Display ANSI and control + chars in default colour, but + apply the contained ansi to + the text portions so they display + as they would for -ansi 1" + VIEWSTYLE "Alias for 4" + } + -ansibase -type ansistring -default {${[a+ brightgreen]}} -help\ + "Base ansi code(s) that will apply to output written to the chosen -channel. + If there are ansi resets in the displayed values - output will revert to this base. + Does not affect return value." + -- -type none -help\ + "End of options marker. + It is advisable to use this, as data in a pipeline may often begin with -" + + @values -min 0 -max -1 + arg -type string -optional 1 -multiple 1 -help\ + "value to display" + } + #pipeline inspect + #e.g + #= {a z c} |> inspect -label input_dict |> lsort |> {inspect $data} + proc inspect {args} { + set defaults [list -label "" -limit 20 -channel stderr -showcount 1 -ansi 1 -ansibase [a+ brightgreen]] + set flags [list] + set endoptsposn [lsearch $args --] ;#first -- if data expected to contain --, then should always be called with --. e.g inspect -- + if {$endoptsposn >= 0} { + set flags [lrange $args 0 $endoptsposn-1] + set pipeargs [lrange $args $endoptsposn+1 end] + } else { + #no explicit end of opts marker + #last trailing elements of args after taking *known* -tag v pairs is the value to inspect + for {set i 0} {$i < [llength $args]} {incr i} { + set k [lindex $args $i] + if {$k in [dict keys $defaults]} { + lappend flags {*}[lrange $args $i $i+1] + incr i + } else { + #first unrecognised option represents end of flags + break + } + } + set pipeargs [lrange $args $i end] + } + 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 + } + } + set opts [dict merge $defaults $flags] + # -- --- --- --- --- + set label [dict get $opts -label] + set channel [dict get $opts -channel] + set showcount [dict get $opts -showcount] + if {[string length $label]} { + set label "${label}: " + } + set limit [dict get $opts -limit] + set opt_ansiraw [dict get $opts -ansi] + set opt_ansi [tcl::prefix::match -error "" [list 0 1 2 3 4 view viewcodes viewstyle] [string tolower $opt_ansiraw]] + switch -- [string tolower $opt_ansi] { + 0 {-} 1 {-} 2 {-} 3 {-} 4 {} + view {set opt_ansi 2} + viewcodes {set opt_ansi 3} + viewstyle {set opt_ansi 4} + default { + error "inspect -ansi 0|1|2|view|3|viewcodes|4|viewstyle - received -ansi $opt_ansiraw" + } + } + # -- --- --- --- --- + + set more "" + if {[llength $pipeargs] == 1} { + #usual case is data as a single element + set val [lindex $pipeargs 0] + set count 1 + } else { + #but the pipeline segment could have an insertion-pattern ending in * + set val $pipeargs + set count [llength $pipeargs] + } + switch -- [string tolower $channel] { + nul {-} null {-} /dev/null { + return $val + } + } + set displayval $val ;#default - may be overridden based on -limit + + if {$count > 1} { + #val is a list + set llen [llength $val] + if {$limit > 0 && ($limit < $llen)} { + set displayval [lrange $val 0 $limit-1] + if {$llen > $limit} { + set more "..." + } + } + } else { + #not a valid tcl list - limit by lines + if {$limit > 0} { + set rawlines [split $val \n] + set llen [llength $rawlines] + set displaylines [lrange $rawlines 0 $limit-1] + set displayval [join $displaylines "\n"] + if {$llen > $limit} { + set more "\n..." + } + } + } + if {$showcount} { + set displaycount "[a purple bold]($count)[a] " + if {$showcount} { + set countspace [expr {[string length $count] + 3}] ;#lhs margin size of count number plus brackets and one space + set margin [string repeat " " $countspace] + set displayval [string map [list \r "" \n "\n$margin"] $displayval] + } + } else { + set displaycount "" + } + + set ansibase [dict get $opts -ansibase] + if {$ansibase ne ""} { + #-ansibase default is hardcoded into punk::args definition + #run a test using any ansi code to see if colour is still enabled + if {[a+ red] eq ""} { + set ansibase "" ;#colour seems to be disabled + } + } + + switch -- $opt_ansi { + 0 { + set displayval $ansibase[punk::ansi::ansistrip $displayval] + } + 1 { + #val may have ansi - including resets. Pass through ansibase_lines to + if {$ansibase ne ""} { + set displayval [::textblock::ansibase_lines $displayval $ansibase] + } + } + 2 { + set displayval $ansibase[ansistring VIEW $displayval] + if {$ansibase ne ""} { + set displayval [::textblock::ansibase_lines $displayval $ansibase] + } + } + 3 { + set displayval $ansibase[ansistring VIEWCODE $displayval] + if {$ansibase ne ""} { + set displayval [::textblock::ansibase_lines $displayval $ansibase] + } + } + 4 { + set displayval $ansibase[ansistring VIEWSTYLE $displayval] + if {$ansibase ne ""} { + set displayval [::textblock::ansibase_lines $displayval $ansibase] + } + } + } + + if {![string length $more]} { + puts $channel "$displaycount$label$displayval[a]" + } else { + puts $channel "$displaycount$label$displayval[a yellow bold]$more[a]" + } + return $val + } + + + #return list of {chan chunk} elements + proc help_chunks {args} { + set chunks [list] + set linesep [string repeat - 76] + set mascotblock "" + catch { + package require patternpunk + #lappend chunks [list stderr [>punk . rhs]] + append mascotblock [textblock::frame -checkargs 0 [>punk . banner -title "Punk Shell" -left Tcl -right [package provide Tcl]]] + } + + set topic [lindex $args end] + set argopts [lrange $args 0 end-1] + + + set title "[a+ brightgreen] Punk core navigation commands: " + + #todo - load from source code annotation? + set cmdinfo [list] + lappend cmdinfo [list help "?topics?" "This help. To see available subitems type: help topics"] + lappend cmdinfo [list i "cmd ?subcommand...?" "Show usage for a command or ensemble subcommand"] + lappend cmdinfo [list ./ "?subdir?" "view/change directory"] + lappend cmdinfo [list ../ "" "go up one directory"] + lappend cmdinfo [list ./new "subdir" "make new directory and switch to it"] + lappend cmdinfo [list n/ "?glob...?" "view/change namespace\n (accepts ns path globs e.g **::*get* to match comands at any level )"] + lappend cmdinfo [list n// "" "view/change namespace (with command listing)"] + lappend cmdinfo [list "nn/" "" "go up one namespace"] + lappend cmdinfo [list "n/new" "" "make child namespace and switch to it"] + lappend cmdinfo [list dev "?subcommand?" "(ensemble command to make new projects/modules and to generate docs)"] + lappend cmdinfo [list a? "?subcommand...?" "view ANSI colours\n e.g a? web"] + + #set cmds [lsearch -all -inline -index 0 -subindices $cmdinfo *] + #set descr [lsearch -all -inline -index 1 -subindices $cmdinfo *] + #set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {string length $v}]] + #set widest2 [tcl::mathfunc::max {*}[lmap v $descr {string length $v}]] + set t [textblock::class::table new -show_seps 0] + #foreach c $cmds d $descr { + # $t add_row [list $c $d] + #} + foreach row $cmdinfo { + $t add_row $row + } + set width_0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$width_0 + 2}] + set width_1 [$t column_datawidth 1] + $t configure_column 1 -minwidth [expr {$width_1 + 1}] + $t configure -title $title + + set text "" + append text [$t print] + + + set warningblock "" + set introblock $mascotblock + append introblock \n $text + + #if {[catch {package require textblock} errM]} { + # append warningblock \n "WARNING: textblock package couldn't be loaded. Side-by-side display not available" + #} else { + # set introblock [textblock::join -- " " \n$mascotblock " " $text] + #} + + + lappend chunks [list stdout $introblock] + + + if {$topic in [list tcl]} { + 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] + } + 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]" + } + } + + set text "" + if {$topic in [list env environment]} { + #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config + + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] + append text \n + set usetable 1 + if {$usetable} { + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + if {"windows" eq $::tcl_platform(platform)} { + #If any env vars have been set to empty string - this is considered a deletion of the variable on windows. + #The Tcl ::env array is linked to the underlying process view of the environment + #- but info exists ::env(var) can misreport as true if it has been deleted by setting to empty string rather than using unset. + #an 'array get' will resynchronise. + #Even if an env variable didn't exist before - setting it to empty string can get it to this inconsistent state. + array get ::env + } + #do an array read on ::env + foreach {v vinfo} $punkenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] + } + $t configure_column 0 -headers [list "Punk environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 4}] -blockalign left -textalign left -header_colspans {any} + + set punktable [$t print] + $t destroy + + set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] + foreach {v vinfo} $otherenv_config { + if {[info exists ::env($v)]} { + set c2 [set ::env($v)] + } else { + set c2 "(NOT SET)" + } + $t add_row [list $v $c2] + } + $t configure_column 0 -headers [list "Other environment vars"] + $t configure_column 0 -minwidth [expr {[$t column_datawidth 0] + 4}] -blockalign left -textalign left -header_colspans {any} + + set othertable [$t print] + $t destroy + append text [textblock::join -- $punktable " " $othertable]\n + } else { + append text $linesep\n + append text "punk environment vars:\n" + append text $linesep\n + set col1 [string repeat " " 25] + set col2 [string repeat " " 50] + foreach v $known_punk { + set c1 [overtype::left $col1 $v] + if {[info exists ::env($v)]} { + set c2 [overtype::left $col2 [set ::env($v)]] + } else { + set c2 [overtype::right $col2 "(NOT SET)"] + } + append text "$c1 $c2\n" + } + append text $linesep\n + } + + lappend chunks [list stdout $text] + } + + if {$topic in [list console terminal]} { + set indent [string repeat " " [string length "WARNING: "]] + lappend cstring_tests [dict create \ + type "PM " \ + msg "PRIVACY MESSAGE" \ + f7 punk::ansi::controlstring_PM \ + f7desc "7bit ESC ^" \ + f8 punk::ansi::controlstring_PM8 \ + f8desc "8bit \\x9e"] + lappend cstring_tests [dict create \ + type SOS \ + msg "STRING" \ + f7 punk::ansi::controlstring_SOS \ + f7desc "7bit ESC X" \ + f8 punk::ansi::controlstring_SOS8 \ + f8desc "8bit \\x98"] + lappend cstring_tests [dict create \ + type APC \ + msg "APPLICATION PROGRAM COMMAND" \ + f7 punk::ansi::controlstring_APC \ + f7desc "7bit ESC _" \ + f8 punk::ansi::controlstring_APC8 \ + f8desc "8bit \\x9f"] + + foreach test $cstring_tests { + set m [[dict get $test f7] [dict get $test msg]] + set hidden_width_m [punk::console::test_char_width $m] + set m8 [[dict get $test f8] [dict get $test msg]] + set hidden_width_m8 [punk::console::test_char_width $m8] + if {$hidden_width_m != 0 || $hidden_width_m8 != 0} { + if {$hidden_width_m == 0} { + set d "[a+ green bold][dict get $test f7desc] [a red]${m}[a]" + } else { + set d "[a+ yellow bold][dict get $test f7desc] [a red]$m[a]" + } + if {$hidden_width_m8 == 0} { + set d8 "[a+ green][dict get $test f8desc] [a red]$m8[a]" + } else { + set d8 "[a+ yellow bold][dict get $test f8desc] [a red]$m8[a]" + } + append warningblock \n "WARNING: terminal doesn't hide all [dict get $test type] control strings: $d $d8" + } + } + if {![catch {punk::console::check::has_bug_legacysymbolwidth} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has legacysymbolwidth bug - screen position for symbol reports 2 wide but displays 1 wide." + append warningblock \n $indent "Layout using 'legacy symbols for computing' affected." + append warningblock \n $indent "(e.g textblock frametype block2 unsupported)" + append warningblock \n $indent "This can cause extreme layout deformation when ANSI is present" + append warningblock \n $indent "In some cases unwanted spacing effects occur at a distance from the characters causing it" + } + } else { + append warningblock \n "WARNING: terminal unable to check for legacysymbolwidth bug. err:$result" + } + + if {![catch {punk::console::check::has_bug_zwsp} result]} { + if {$result} { + append warningblock \n "WARNING: terminal has zero width space (\\u200b) bug - cursor position incremented when it shouldn't be." + append warningblock \n $indent "The zwsp may or may not be displayed. zwsp contributes to line length and wrapping point" + } + } else { + append warningblock \n "WARNING: terminal unable to check for zwsp bug. err:$result" + } + + + set grapheme_support [punk::console::grapheme_cluster_support] + #mode, 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) + if {![dict size $grapheme_support] || [dict get $grapheme_support mode] eq "unsupported"} { + append warningblock \n "WARNING: terminal either doesn't support grapheme clusters, or doesn't report so via decmode 2027 query." + if {[dict size $grapheme_support] && [dict get $grapheme_support available]} { + append warningblock \n $indent "(but punk::console::grapheme_cluster_support has determined it is probably available)" + } + } else { + if {![dict get $grapheme_support available]} { + switch -- [dict get $grapheme_support mode] { + "unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is off." + } + "permanently_unset" { + append warningblock \n "WARNING: terminal reports via decmode 2027 that grapheme cluster support is permanently off." + } + "BAD_RESPONSE" { + append warningblock \n "WARNING: terminal doesn't seem to recognize decmode 2027 query. No grapheme cluster support." + } + } + } + } + } + + lappend chunks [list stderr $warningblock] + if {$topic in [list topics help]} { + set text "" + set topics [dict create \ + "topics|help" "List help topics" \ + "tcl" "Tcl version warnings" \ + "env|environment" "punkshell environment vars" \ + "console|terminal" "Some console behaviour tests and warnings"] + + set t [textblock::class::table new -show_seps 0] + $t add_column -headers [list "Topic"] + $t add_column + foreach {k v} $topics { + $t add_row [list $k $v] + } + set widest0 [$t column_datawidth 0] + $t configure_column 0 -minwidth [expr {$widest0 + 4}] + append text \n[$t print] + + lappend chunks [list stdout $text] + } + + return $chunks + } + proc help {args} { + set chunks [help_chunks {*}$args] + foreach chunk $chunks { + lassign $chunk chan text + puts -nonewline $chan $text + } + } + proc mode {{raw_or_line query}} { + package require punk::console + tailcall ::punk::console::mode $raw_or_line + } + + #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::lib::aliases $glob + } + proc alias {{aliasorglob ""} args} { + tailcall punk::lib::alias $aliasorglob {*}$args + } + + + #pipeline-toys - put in lib/scriptlib? + ##geometric mean + #alias gmean .=> llength |> expr 1.0 / |e> .=i>* tcl::mathop::* |> .=>1,e>3 expr ** {::tcl::tm::add {*}$data; set path} |> inspect -label added_to_module_path <0/#| + + + #interp alias {} c {} clear ;#external executable 'clear' may not always be available + #todo - review + interp alias {} clear {} ::punk::reset + interp alias {} c {} ::punk::reset + proc reset {} { + if {[llength [info commands ::punk::repl::reset_terminal]]} { + #punk::repl::reset_terminal notifies prompt system of reset + punk::repl::reset_terminal + } else { + puts -nonewline stdout [punk::ansi::reset] + } + } + + + #fileutil::cat except with checking for windows illegal path names (when on windows platform) + interp alias {} fcat {} punk::mix::util::fcat + + #---------------------------------------------- + interp alias {} linelistraw {} punk::linelistraw + + # 'path' collides with kettle path in kettle::doc function - todo - patch kettle? + interp alias {} PATH {} punk::path + + interp alias {} path_list {} punk::path_list + interp alias {} list_filter_cond {} punk::list_filter_cond + + + interp alias {} inspect {} punk::inspect + interp alias {} ooinspect {} punk::ooinspect + + interp alias {} linedict {} punk::linedict + interp alias {} dictline {} punk::dictline + + #todo - pipepure - evaluate pipeline in a slave interp without commands that have side-effects. (safe interp?) + interp alias {} % {} punk::% + interp alias {} pipeswitch {} punk::pipeswitch + interp alias {} pipeswitchc {} punk::pipeswitchc ;#closure version - more correct + interp alias {} pipecase {} punk::pipecase + interp alias {} pipematch {} punk::pipematch + interp alias {} ispipematch {} punk::ispipematch + interp alias {} pipenomatchvar {} punk::pipenomatchvar + interp alias {} pipedata {} punk::pipedata + interp alias {} pipeset {} punk::pipeset + interp alias {} pipealias {} punk::pipealias + interp alias {} listset {} punk::listset ;#identical to pipeset + + + #non-core aliases + interp alias {} is_list_all_in_list {} punk::lib::is_list_all_in_list + interp alias {} is_list_all_ni_list {} punk::libis_list_all_ni_list + + + #interp alias {} = {} ::punk::pipeline = "" "" + #interp alias {} = {} ::punk::match_assign "" "" + interp alias {} .= {} ::punk::pipeline .= "" "" + #proc .= {args} { + # #uplevel 1 [list ::punk::pipeline .= "" "" {*}$args] + # tailcall ::punk::pipeline .= "" "" {*}$args + #} + + + interp alias {} rep {} ::tcl::unsupported::representation + interp alias {} dis {} ::tcl::unsupported::disassemble + + + # ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion + interp alias {} l {} sh_runout -n ls -A ;#plain text listing + #interp alias {} ls {} sh_runout -n ls -AF --color=always + interp alias {} ls {} shellrun::runconsole ls -AF --color=always ;#use unknown to use terminal and allow | more | less + #note that shell globbing with * won't work on unix systems when using unknown/exec + interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) + interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. + # -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? + #interp alias {} lw {} ls -aFv --color=always + + interp alias {} dir {} shellrun::runconsole dir + + # punk::nav::fs + package require punk::nav::fs + interp alias {} ./ {} punk::nav::fs::d/ + interp alias {} ../ {} punk::nav::fs::dd/ + interp alias {} d/ {} punk::nav::fs::d/ + interp alias {} dd/ {} punk::nav::fs::dd/ + + interp alias {} vwd {} punk::nav::fs::vwd ;#return punk::nav::fs::VIRTUAL_CWD - and report to stderr pwd if different + interp alias {} dirlist {} punk::nav::fs::dirlist + interp alias {} dirfiles {} punk::nav::fs::dirfiles + interp alias {} dirfiles_dict {} punk::nav::fs::dirfiles_dict + + interp alias {} ./new {} punk::nav::fs::d/new + interp alias {} d/new {} punk::nav::fs::d/new + interp alias {} ./~ {} punk::nav::fs::d/~ + interp alias {} d/~ {} punk::nav::fs::d/~ + interp alias "" x/ "" punk::nav::fs::x/ + + + if {$::tcl_platform(platform) eq "windows"} { + set has_powershell 1 + interp alias {} dl {} dir /q + interp alias {} dw {} dir /W/D + } else { + #todo - natsorted equivalent + #interp alias {} dl {} + interp alias {} dl {} puts stderr "not implemented" + interp alias {} dw {} puts stderr "not implemented" + #todo - powershell detection on other platforms + set has_powershell 0 + } + if {$has_powershell} { + #see also powershell runspaces etc: + # powershell runspaces e.g $rs=[RunspaceFactory]::CreateRunspace() + # $ps = [Powershell]::Create() + + interp alias {} ps {} exec >@stdout pwsh -nolo -nop -c + interp alias {} psx {} runx -n pwsh -nop -nolo -c + interp alias {} psr {} run -n pwsh -nop -nolo -c + interp alias {} psout {} runout -n pwsh -nop -nolo -c + interp alias {} pserr {} runerr -n pwsh -nop -nolo -c + interp alias {} psls {} shellrun::runconsole pwsh -nop -nolo -c ls + interp alias {} psps {} shellrun::runconsole pwsh -nop -nolo -c ps + } else { + set ps_missing "powershell missing (powershell is open source and can be installed on windows and most unix-like platforms)" + interp alias {} ps {} puts stderr $ps_missing + interp alias {} psx {} puts stderr $ps_missing + interp alias {} psr {} puts stderr $ps_missing + interp alias {} psout {} puts stderr $ps_missing + interp alias {} pserr {} puts stderr $ps_missing + interp alias {} psls {} puts stderr $ps_missing + interp alias {} psps {} puts stderr $ps_missing + } + proc psencode {cmdline} { + + } + proc psdecode {encodedcmd} { + + } + + 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" + } + } + } +} + + +# -- --- --- --- +#Load decks. commandset packages are not loaded until the deck is called. +# -- --- --- --- +package require punk::mod +#punk::mod::cli set_alias pmod +punk::mod::cli set_alias app + +#todo - change to punk::dev +package require punk::mix +punk::mix::cli set_alias dev +punk::mix::cli set_alias deck ;#deprecate! + +#todo - add punk::deck for managing cli modules and commandsets + +package require punkcheck::cli +punkcheck::cli set_alias pcheck +punkcheck::cli set_alias punkcheck +# -- --- --- --- + +package provide punk [namespace eval punk { + #FUNCTL + variable version + set version 0.1 +}] 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 3d1d87e9..5b45b2bc 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 @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::aliascore 0 0.1.0] #[copyright "2024"] #[titledesc {punkshell command aliases}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::aliascore] #[keywords module alias] #[description] @@ -98,7 +98,7 @@ package require Tcl 8.6- # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::aliascore { - tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable aliases #use absolute ns ie must be prefixed with :: #single element commands are imported if source command already exists, otherwise aliased. multi element commands are aliased @@ -136,7 +136,7 @@ tcl::namespace::eval punk::aliascore { #*** !doctools #[subsection {Namespace punk::aliascore}] - #[para] Core API functions for punk::aliascore + #[para] Core API functions for punk::aliascore #[list_begin definitions] @@ -144,13 +144,13 @@ tcl::namespace::eval punk::aliascore { #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" #} #todo - options as to whether we should raise an error if collisions found, undo aliases etc? @@ -208,13 +208,13 @@ tcl::namespace::eval punk::aliascore { #todo - ensure exported? noclobber? if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { #puts stderr "importing $cmd" - tcl::namespace::eval :: [list namespace import $cmd] + tcl::namespace::eval :: [list namespace import $cmd] } else { #target command name differs from exported name #e.g stripansi -> punk::ansi::ansistrip #import and rename #puts stderr "importing $cmd (with rename to ::$a)" - tcl::namespace::eval $tempns [list namespace import $cmd] + tcl::namespace::eval $tempns [list namespace import $cmd] catch {rename ${tempns}::[namespace tail $cmd] ::$a} } } else { @@ -242,18 +242,18 @@ tcl::namespace::eval punk::aliascore { # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::aliascore::lib { - namespace export {[a-z]*} ;# Convention: export all lowercase + namespace export {[a-z]*} ;# Convention: export all lowercase namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::aliascore::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 + # #[para]Description of utility1 + # return 1 #} @@ -271,17 +271,17 @@ namespace eval punk::aliascore::lib { namespace eval punk::aliascore::system { #*** !doctools #[subsection {Namespace punk::aliascore::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::aliascore [namespace eval punk::aliascore { variable pkg punk::aliascore variable version - set version 0.1.0 + set version 0.1.0 }] return 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 b367be2a..50ea5082 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 @@ -19,21 +19,21 @@ #[manpage_begin punkshell_module_punk::ansi 0 0.1.1] #[copyright "2023"] #[titledesc {Ansi string functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] +#[moddesc {punk Ansi library}] [comment {-- Description at end of page heading --}] #[require punk::ansi] #[keywords module ansi terminal console string] #[description] -#[para]Ansi based terminal control string functions -#[para]See [package punk::ansi::console] for related functions for controlling a console +#[para]Ansi based terminal control string functions +#[para]See [package punk::ansi::console] for related functions for controlling a console # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Overview] -#[para] overview of punk::ansi +#[para] overview of punk::ansi #[para]punk::ansi functions return their values - no implicit emission to console/stdout #[subsection Concepts] -#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner +#[para]Ansi codes can be used to control most terminals on most platforms in an 'almost' standard manner #[para]There are many differences in terminal implementations - but most should support a core set of features #[para]punk::ansi does not contain any code for direct terminal manipulation via the local system APIs. #[para]Sticking to ansi codes where possible may be better for cross-platform and remote operation where such APIs are unlikely to be useable. @@ -45,7 +45,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by punk::ansi +#[para] packages used by punk::ansi #[list_begin itemized] package require Tcl 8.6- @@ -72,7 +72,7 @@ tcl::namespace::eval punk::ansi::class { if {![llength [tcl::info::commands class_ansi]]} { oo::class create class_ansi { - variable o_ansistringobj + variable o_ansistringobj variable o_render_dimensions ;#last dimensions at which we rendered variable o_rendered @@ -83,7 +83,7 @@ tcl::namespace::eval punk::ansi::class { } #a straight string compare may be faster.. but a checksum is much smaller in memory, so we'll use that by default. - set o_rendered_what "" + set o_rendered_what "" #There may also be advantages to renering to a class_ansistring class object set o_render_dimensions $dimensions @@ -100,7 +100,7 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set cksum "not-done" - if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { + if {$dimensions ne $o_render_dimensions || $o_rendered_what ne [set cksum [$o_ansistringobj checksum]]} { #some ansi layout/art relies on wrapping at the width-dimension to display properly #this includes cursor movements ie right arrow can move cursor to columns in lines below #overflow is a different concept - perhaps not particularly congruent with the idea of the textblock as a mini terminal emulator. @@ -111,7 +111,7 @@ tcl::namespace::eval punk::ansi::class { #if dimensions changed - the checksum won't have been done set o_rendered_what [$o_ansistringobj checksum] } else { - set o_rendered_what $cksum + set o_rendered_what $cksum } set o_render_dimensions $dimensions } @@ -127,8 +127,8 @@ tcl::namespace::eval punk::ansi::class { error "class_ansi::render dimensions must be of the form x" } set o_dimensions $dimensions - - + + set rendered [overtype::renderspace -cp437 1 -expand_right 0 -wrap 1 -width $w -height $h -appendlines 1 "" [$o_ansistringobj get]] return $rendered } @@ -185,12 +185,12 @@ tcl::namespace::eval punk::ansi::class { set lfvis [ansistring VIEW -lf 1 \n] set maplf [list \n "[a+ green bold reverse]${lfvis}[a]\n"] ;#a mapping to highlight newlines - set lines [split [$o_ansistringobj get] \n] + set lines [split [$o_ansistringobj get] \n] set rlines [lrange $lines 0 $x] - set chunk [::join $rlines \n] + set chunk [::join $rlines \n] append chunk \n if {$opt_minus ne "0"} { - set chunk [tcl::string::range $chunk 0 end-$opt_minus] + 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 marker "" @@ -212,7 +212,7 @@ tcl::namespace::eval punk::ansi::class { 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 + #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 renderheight [llength [split $rendered \n]] set chunkdisplay_lines [split $chunkdisplay \n] @@ -221,7 +221,7 @@ tcl::namespace::eval punk::ansi::class { #the input chunk lines are often much longer than the output.. resulting in main content being way up the screen. It's often impractical to view more than the tail of the chunkdisplay. textblock::join -- $rendered $chunkdisplay_block } - + method checksum {} { return [$o_ansistringobj checksum] } @@ -237,7 +237,7 @@ tcl::namespace::eval punk::ansi::class { -lf 0\ -vt 0\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -267,7 +267,7 @@ tcl::namespace::eval punk::ansi::class { method viewchars {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -295,7 +295,7 @@ tcl::namespace::eval punk::ansi::class { method viewstyle {args} { set defaults [list\ -width "auto"\ - ] + ] set opts $defaults foreach {k v} $args { switch -- $k { @@ -338,20 +338,20 @@ tcl::namespace::eval punk::ansi::class { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::ansi { - variable PUNKARGS + variable PUNKARGS #*** !doctools #[subsection {Namespace punk::ansi}] - #[para] Core API functions for punk::ansi + #[para] Core API functions for punk::ansi #[list_begin definitions] - #old-school ansi graphics - C0 control glyphs. - variable cp437_map + #old-school ansi graphics - C0 control glyphs. + variable cp437_map #for cp437 images we need to map these *after* splitting ansi, to single-width unicode chars #It would also probably be problematic to map \u000A to the glyph - as this is the newline - it included in the map anyway for completeness. The caller may have to manually carve that or other specific c0 controls out of the map to use it depending on the situation(?) #Layout for cp437 won't be right if you don't at least set width of control-chars to 1 - but also some images specifically use these glyphs - #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too + #most fonts don't seem to supply graphics for these control characters even when cp437 is in use - the c1 control glyphs appear to be more widely available - but we could add them here too #by mapping these we can display regardless. - #nul char - no cp437 image but commonly used as space in ansi graphics. + #nul char - no cp437 image but commonly used as space in ansi graphics. #(This is a potential conflict because we use nul as a filler to mean empty column in overtype rendering) REVIEW tcl::dict::set cp437_map \u0000 " " ;#space tcl::dict::set cp437_map \u0001 \u263A ;#smiley @@ -377,11 +377,11 @@ tcl::namespace::eval punk::ansi { tcl::dict::set cp437_map \u0015 \u00A7 ;#Section Sign tcl::dict::set cp437_map \u0016 \u25AC ;#Heavy horizontal? tcl::dict::set cp437_map \u0017 \u21A8 ;#updown arrow 2 ? - tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow - tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow - tcl::dict::set cp437_map \u001A \u2192 ;#right arrow - tcl::dict::set cp437_map \u001B \u2190 ;#left arrow - tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner + tcl::dict::set cp437_map \u0018 \u2191 ;#up arrow + tcl::dict::set cp437_map \u0019 \u2193 ;#down arrow + tcl::dict::set cp437_map \u001A \u2192 ;#right arrow + tcl::dict::set cp437_map \u001B \u2190 ;#left arrow + tcl::dict::set cp437_map \u001C \u221F ;#bottom left corner tcl::dict::set cp437_map \u001D \u2194 ;#left-right arrow tcl::dict::set cp437_map \u001E \u25B2 ;#up arrow triangle tcl::dict::set cp437_map \u001F \u25BC ;#down arrow triangle @@ -396,7 +396,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics c \u240c ;#symbol for FF tcl::dict::set map_special_graphics d \u240d ;#symbol for CR tcl::dict::set map_special_graphics e \u240a ;#symbol for LF - tcl::dict::set map_special_graphics f \u00b0 ;#degree sign + tcl::dict::set map_special_graphics f \u00b0 ;#degree sign tcl::dict::set map_special_graphics g \u00b1 ;#plus-minus sign tcl::dict::set map_special_graphics h \u2424 ;#symbol for NL tcl::dict::set map_special_graphics i \u240b ;#symbol for VT @@ -408,8 +408,8 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics o \u23ba ;#horizontal scan line-1 tcl::dict::set map_special_graphics p \u23bb ;#horizontal scan line-3 tcl::dict::set map_special_graphics q \u2500 ;#light horizontal - box drawing - tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 - tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 + tcl::dict::set map_special_graphics r \u23bc ;#horizontal scan line-7 + tcl::dict::set map_special_graphics s \u23bd ;#horizontal scan line-9 tcl::dict::set map_special_graphics t \u251c ;#light vertical and right - box drawing tcl::dict::set map_special_graphics u \u2524 ;#light vertical and left - box drawing tcl::dict::set map_special_graphics v \u2534 ;#light up and horizontal - box drawing @@ -419,10 +419,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set map_special_graphics z \u2265 ;#greater than or equal tcl::dict::set map_special_graphics "\{" \u03c0 ;#greek small letter pi tcl::dict::set map_special_graphics "|" \u2260 ;#not equal to - tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign + tcl::dict::set map_special_graphics "\}" \u00a3 ;#pound sign tcl::dict::set map_special_graphics ~ \u00b7 ;#middle dot - #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control + #see also ansicolour page on wiki https://wiki.tcl-lang.org/page/ANSI+color+control variable test "blah\033\[1;33mETC\033\[0;mOK" @@ -451,14 +451,14 @@ tcl::namespace::eval punk::ansi { 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\\ \u009c] ;#note mix of 1 and 2-byte terminals + #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\\ \u009c] ;#note mix of 1 and 2-byte terminals tcl::dict::set escape_terminals DCS [list \007 \033\\ \u009c] tcl::dict::set escape_terminals MISC [list \007 \033\\ \u009c] - #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) + #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) #This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows? - #review - there doesn't seem to be an \x1b#7 + #review - there doesn't seem to be an \x1b#7 # https://espterm.github.io/docs/VT100%20escape%20codes.html #self-contained 2 byte ansi escape sequences - review more? @@ -479,9 +479,9 @@ tcl::namespace::eval punk::ansi { #comparitive test (performance) string-append vs 2-object (with existing splits) append proc test_cat1 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -492,13 +492,13 @@ tcl::namespace::eval punk::ansi { $s2 destroy #$s1 append \033\[31mX ;#redX - return $s1 + return $s1 } proc test_cat2 {ansi1 ansi2} { #make sure objects have splits - set s1 [ansistring NEW $ansi1] + set s1 [ansistring NEW $ansi1] tcl::namespace::eval [info object namespace $s1] {my MakeSplit} - set s2 [ansistring NEW $ansi2] + set s2 [ansistring NEW $ansi2] tcl::namespace::eval [info object namespace $s2] {my MakeSplit} #operation under test @@ -513,12 +513,12 @@ tcl::namespace::eval punk::ansi { # -------------------------------------- - #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? + #review - We have file possibly encoded directly in another codepage such as 437 - or utf8,utf16 etc, but then still needing post conversion to e.g cp437? #In testing old ansi graphics files available on the web, some files need encoding {utf-8 cp437} some just cp437 proc readfile {fname {encoding cp437}} { - #todo + #todo #1- look for BOM - read according to format given by BOM - #2- assume utf-8 + #2- assume utf-8 #3- if errors - assume cp437? if {[llength $encoding] == 1} { @@ -605,7 +605,7 @@ tcl::namespace::eval punk::ansi { Defaults to /src/testansi - where projectbase is determined from the current directory. " - @values -min 0 -max -1 + @values -min 0 -max -1 files -default {belinda.ans bot.ans flower.ans fish.ans} -multiple true -help\ "List of filenames - leave empty to display 4 defaults" } ""] @@ -620,7 +620,7 @@ tcl::namespace::eval punk::ansi { set fnames [dict get $argd values files] #assumes fixed column widths e.g 80col images will fit in 82-width frames (common standard for old ansi art) (of arbitrary height) - #todo - review dependency on punk::repo ? + #todo - review dependency on punk::repo ? package require textblock package require punk::repo package require punk::console @@ -630,13 +630,13 @@ tcl::namespace::eval punk::ansi { puts stderr "Ensure ansi test files exist: $fnames" #error "punk::ansi::example Cannot find example files" } - set termsize [punk::console:::get_size] + set termsize [punk::console:::get_size] set termcols [dict get $termsize columns] set margin 4 ;#review set freewidth [expr {$termcols-$margin}] if {$freewidth < $colwidth} { puts stderr "[a+ red bold]punk::ansi::example freewidth: $freewidth < colwidth: $colwidth TRUNCATING IMAGES[a]" - set colwidth $freewidth + set colwidth $freewidth } set per_row [expr {$freewidth / $colwidth}] @@ -655,7 +655,7 @@ tcl::namespace::eval punk::ansi { #set img [join [lines_as_list -line trimline -block trimtail [ansicat $filepath]] \n] #-line trimline will wreck some images set img [join [lines_as_list -block trimtail [ansicat $filepath]] \n] - lappend pics [tcl::dict::create filename $f pic $img status ok] + lappend pics [tcl::dict::create filename $f pic $img status ok] } } @@ -670,13 +670,13 @@ tcl::namespace::eval punk::ansi { foreach picinfo $pics { set subtitle "" if {[tcl::dict::get $picinfo status] ne "ok"} { - set subtitle [tcl::dict::get $picinfo status] + set subtitle [tcl::dict::get $picinfo status] } set title [tcl::dict::get $picinfo filename] set fr [textblock::frame -checkargs 0 -width $colwidth -subtitle $subtitle -title $title [tcl::dict::get $picinfo pic]] - # -- --- --- --- + # -- --- --- --- #we need the max height of a row element to use join_basic instead of join below - # -- --- --- --- + # -- --- --- --- set fr_height [textblock::height $fr] lappend row $fr lappend rowh $fr_height @@ -691,8 +691,8 @@ tcl::namespace::eval punk::ansi { set rowmax $fr_height lset maxheights end $rowmax } - } - # -- --- --- --- + } + # -- --- --- --- if {$i % $per_row == 0} { lappend rowlist $row @@ -718,9 +718,9 @@ tcl::namespace::eval punk::ansi { if {$h < $maxheight} { #add blank lines to bottom of shorter images so join_basic can be used. #textblock::join of ragged-height images would work and remove the need for all the height calculation - #.. but it requires much more processing + #.. but it requires much more processing append i [string repeat \n$blankline [expr {$maxheight - $h}]] - } + } lappend adjusted_row $i } append result [textblock::join_basic -- {*}$adjusted_row] \n @@ -746,12 +746,12 @@ tcl::namespace::eval punk::ansi { #b) DEVICE CONTROL STRING (DCS) #c) OPERATING SYSTEM COMMAND (OSC) #d) PRIVACY MESSAGE (PM) - #e) START OF STRING (SOS) + #e) START OF STRING (SOS) # #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ - #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. + #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. #todo - review - printing_length calculations affected by whether terminal honours PMs or not. detect and accomodate. #review - can terminals handle SGR codes within a PM? #Wezterm will hide PM,SOS,APC - but not any part following an SGR code - i.e it seems to terminate hiding before the ST (apparently at the ) @@ -779,7 +779,7 @@ tcl::namespace::eval punk::ansi { #candidate for zig/c implementation? proc stripansi2 {text} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters join [::punk::ansi::ta::split_at_codes $text] "" } @@ -793,7 +793,7 @@ tcl::namespace::eval punk::ansi { #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - #set re {\033\(0[^\033]*\033\(B} + #set re {\033\(0[^\033]*\033\(B} #set re {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} #set re2 {\033\(0(.*)\033\(B} ;#capturing @@ -806,9 +806,9 @@ tcl::namespace::eval punk::ansi { #don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this. - set re_g0_open_or_close {\x1b\(0|\x1b\(B} + set re_g0_open_or_close {\x1b\(0|\x1b\(B} set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text] - set out {} + set out {} set g0_on 0 foreach {other g} $parts { if {$g0_on} { @@ -838,7 +838,7 @@ tcl::namespace::eval punk::ansi { #That will either stop us matching - so no conversion - or risk converting parts of the ansi codes #using not \033 inside to stop greediness - review how does it compare to ".*?" #variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} - set re {\033\(0[^\033]*\033\(B} + set re {\033\(0[^\033]*\033\(B} set re2 {\033\(0(.*)\033\(B} ;#capturing #box sample @@ -902,10 +902,10 @@ tcl::namespace::eval punk::ansi { #Note that SYN (\016) seems to put terminals in a state #where alternate graphics are not processed. #an ETB (\017) needs to be sent to get alt graphics working again. - #It isn't known what software utilises SYN/ETB within altg sequences + #It isn't known what software utilises SYN/ETB within altg sequences # (presumably to alternate between the charsets within a graphics-on/graphics-off section) #but as modern emulators seem to react to it, we should handle it. - #REVIEW - this mapping not fully understood + #REVIEW - this mapping not fully understood #used by groptim variable grforw variable grback @@ -938,10 +938,10 @@ tcl::namespace::eval punk::ansi { proc ansistrip_gx {text} { #e.g "\033(0" - select VT100 graphics for character set G0 - #e.g "\033(B" - reset + #e.g "\033(B" - reset #e.g "\033)0" - select VT100 graphics for character set G1 #e.g "\033)X" - where X is any char other than 0 to reset ?? - + #return [convert_g0 $text] return [tcl::string::map [list \x1b(0 "" \x1b(B "" \x1b)0 "" \x1b)X ""] $text] } @@ -953,7 +953,7 @@ tcl::namespace::eval punk::ansi { #CSI m = SGR (Select Graphic Rendition) #leave map unindented - used both as a dict and for direct display variable SGR_setting_map { -reset 0 bold 1 dim 2 italic 3 noitalic 23 +reset 0 bold 1 dim 2 italic 3 noitalic 23 underline 4 doubleunderline 21 nounderline 24 blink 5 fastblink 6 noblink 25 reverse 7 noreverse 27 hide 8 nohide 28 strike 9 nostrike 29 normal 22 defaultfg 39 defaultbg 49 overline 53 nooverline 55 @@ -967,26 +967,26 @@ Black 40 Red 41 Green 42 Yellow 43 Blue brightblack 90 brightred 91 brightgreen 92 brightyellow 93 brightblue 94 brightpurple 95 brightcyan 96 brightwhite 97 Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblue 104 Brightpurple 105 Brightcyan 106 Brightwhite 107 } - variable SGR_map ;#public - part of interface - review + variable SGR_map ;#public - part of interface - review set SGR_map [tcl::dict::merge $SGR_colour_map $SGR_setting_map] #we use prefixes e.g web-white and/or x11-white #Only a leading capital letter will indicate the colour target is background vs lowercase for foreground - #In the map key-lookup context the colour names will be canonically lower case + #In the map key-lookup context the colour names will be canonically lower case #We should be case insensitive in the non-prefix part ie after determining fg/bg target from first letter of the prefix - #e.g Web-Lime or Web-lime are ok and are targeting background + #e.g Web-Lime or Web-lime are ok and are targeting background #foreground target examples: web-Lime web-LIME web-DarkSalmon web-Darksalmon #specified in decimal - but we should also accept hex format directly in a+ function e.g #00FFFF for aqua - variable WEB_colour_map + variable WEB_colour_map #use the totitle format as the canonical lookup key #don't use leading zeros - keep compatible with earlier tcl and avoid octal issue - # -- --- --- + # -- --- --- #css 1-2.0 HTML 3.2-4 Basic colours eg web-silver for fg Web-silver for bg # variable WEB_colour_map_basic tcl::dict::set WEB_colour_map_basic white 255-255-255 ;# #FFFFFF - tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 + tcl::dict::set WEB_colour_map_basic silver 192-192-192 ;# #C0C0C0 tcl::dict::set WEB_colour_map_basic gray 128-128-128 ;# #808080 tcl::dict::set WEB_colour_map_basic black 0-0-0 ;# #000000 tcl::dict::set WEB_colour_map_basic red 255-0-0 ;# #FF0000 @@ -1001,7 +1001,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_basic navy 0-0-128 ;# #000080 tcl::dict::set WEB_colour_map_basic fuchsia 255-0-255 ;# #FF00FF tcl::dict::set WEB_colour_map_basic purple 128-0-128 ;# #800080 - # -- --- --- + # -- --- --- #Pink colours variable WEB_colour_map_pink tcl::dict::set WEB_colour_map_pink mediumvioletred 199-21-133 ;# #C71585 @@ -1010,7 +1010,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_pink hotpink 255-105-180 ;# #FF69B4 tcl::dict::set WEB_colour_map_pink lightpink 255-182-193 ;# #FFB6C1 tcl::dict::set WEB_colour_map_pink pink 255-192-203 ;# #FFCOCB - # -- --- --- + # -- --- --- #Red colours variable WEB_colour_map_red tcl::dict::set WEB_colour_map_red darkred 139-0-0 ;# #8B0000 @@ -1022,7 +1022,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_red salmon 250-128-114 ;# #FA8072 tcl::dict::set WEB_colour_map_red darksalmon 233-150-122 ;# #E9967A tcl::dict::set WEB_colour_map_red lightsalmon 255-160-122 ;# #FFA07A - # -- --- --- + # -- --- --- #Orange colours variable WEB_colour_map_orange tcl::dict::set WEB_colour_map_orange orangered 255-69-0 ;# #FF4500 @@ -1030,7 +1030,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_orange darkorange 255-140-0 ;# #FF8C00 tcl::dict::set WEB_colour_map_orange coral 255-127-80 ;# #FF7F50 tcl::dict::set WEB_colour_map_orange orange 255-165-0 ;# #FFA500 - # -- --- --- + # -- --- --- #Yellow colours variable WEB_colour_map_yellow tcl::dict::set WEB_colour_map_yellow darkkhaki 189-183-107 ;# #BDB76B @@ -1044,7 +1044,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_yellow lightgoldenrodyeallow 250-250-210 ;# #FAFAD2 tcl::dict::set WEB_colour_map_yellow lemonchiffon 255-250-205 ;# #FFFACD tcl::dict::set WEB_colour_map_yellow lightyellow 255-255-224 ;# #FFFFE0 - # -- --- --- + # -- --- --- #Brown colours #maroon as above variable WEB_colour_map_brown @@ -1064,7 +1064,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_brown bisque 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown blanchedalmond 255-228-196 ;# #FFEfC4 tcl::dict::set WEB_colour_map_brown cornsilk 255-248-220 ;# #FFF8DC - # -- --- --- + # -- --- --- #Purple, violet, and magenta colours variable WEB_colour_map_purple tcl::dict::set WEB_colour_map_purple indigo 75-0-130 ;# #4B0082 @@ -1074,7 +1074,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple darkslateblue 72-61-139 ;# #9400D3 tcl::dict::set WEB_colour_map_purple blueviolet 138-43-226 ;# #8A2BE2 tcl::dict::set WEB_colour_map_purple darkorchid 153-50-204 ;# #9932CC - tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF + tcl::dict::set WEB_colour_map_purple fuchsia 255-0-255 ;# #FF00FF tcl::dict::set WEB_colour_map_purple magenta 255-0-255 ;# #FF00FF - same as fuchsia tcl::dict::set WEB_colour_map_purple slateblue 106-90-205 ;# #6A5ACD tcl::dict::set WEB_colour_map_purple mediumslateblue 123-104-238 ;# #7B68EE @@ -1085,7 +1085,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_purple plum 221-160-221 ;# #DDA0DD tcl::dict::set WEB_colour_map_purple thistle 216-191-216 ;# #D88FD8 tcl::dict::set WEB_colour_map_purple lavender 230-230-250 ;# #E6E6FA - # -- --- --- + # -- --- --- #Blue colours variable WEB_colour_map_blue tcl::dict::set WEB_colour_map_blue midnightblue 25-25-112 ;# #191970 @@ -1103,7 +1103,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_blue lightsteelblue 176-196-222 ;# #B0C4DE tcl::dict::set WEB_colour_map_blue lightblue 173-216-230 ;# #ADD8E6 tcl::dict::set WEB_colour_map_blue powderblue 176-224-230 ;# #B0E0E6 - # -- --- --- + # -- --- --- #Cyan colours #teal as above variable WEB_colour_map_cyan @@ -1114,11 +1114,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_cyan mediumturquoise 72-209-204 ;# #48D1CC tcl::dict::set WEB_colour_map_cyan turquoise 64-224-208 ;# #40E0D0 tcl::dict::set WEB_colour_map_cyan aqua 0-255-255 ;# #00FFFF - tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua + tcl::dict::set WEB_colour_map_cyan cyan 0-255-255 ;# #00FFFF - same as aqua tcl::dict::set WEB_colour_map_cyan aquamarine 127-255-212 ;# #7FFFD4 tcl::dict::set WEB_colour_map_cyan paleturquoise 175-238-238 ;# #AFEEEE tcl::dict::set WEB_colour_map_cyan lightcyan 224-255-255 ;# #E0FFFF - # -- --- --- + # -- --- --- #Green colours variable WEB_colour_map_green tcl::dict::set WEB_colour_map_green darkgreen 0-100-0 ;# #006400 @@ -1141,7 +1141,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_green lightgreen 144-238-144 ;# #90EE90 tcl::dict::set WEB_colour_map_green greenyellow 173-255-47 ;# #ADFF2F tcl::dict::set WEB_colour_map_green palegreen 152-251-152 ;# #98FB98 - # -- --- --- + # -- --- --- #White colours variable WEB_colour_map_white tcl::dict::set WEB_colour_map_white mistyrose 255-228-225 ;# #FFE4E1 @@ -1161,7 +1161,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu tcl::dict::set WEB_colour_map_white snow 255-250-250 ;# #FFFAFA tcl::dict::set WEB_colour_map_white ivory 255-255-240 ;# #FFFFF0 tcl::dict::set WEB_colour_map_white white 255-255-255 ;# #FFFFFF - # -- --- --- + # -- --- --- #Gray and black colours variable WEB_colour_map_gray tcl::dict::set WEB_colour_map_gray black 0-0-0 ;# #000000 @@ -1202,8 +1202,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #Xterm colour names (256 colours) - #lists on web have duplicate names - #these have been renamed here in a systematic way: + #lists on web have duplicate names + #these have been renamed here in a systematic way: #They are suffixed with a dash and a letter e.g second deepskyblue4 -> deepskyblue4-b, third deepskyblue4 -> deepskyblue4-c #presumably the xterm colour names are not widely used or are used for reverse lookup from rgb to get an approximate name in the case of dupes? #Review! @@ -1215,10 +1215,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95) #Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway. #The xterm names are boringly unimaginative - and also have some oddities such as: - # DarkSlateGray1 which looks much more like cyan.. + # DarkSlateGray1 which looks much more like cyan.. # The greyxx names are spelt with an e - but the darkslategrayX variants use an a. Perhaps that's because they are more cyan than grey and the a is a hint? # there is no gold or gold2 - but there is gold1 and gold3 - #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. + #but in general the names bear some resemblance to the colours and are at least somewhat intuitive. set xterm_names [list\ black\ @@ -1500,7 +1500,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {!$did_rename} { - error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" + error "Not enough suffixes for duplicate names in xterm colour list. Add more suffixes or review list" } } incr cidx @@ -1510,7 +1510,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #colour_hex2ansidec - #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) + #conversion of hex to format directly pluggable to ansi rgb format (colon separated e.g for foreground we need "38;2;$r;$g;$b" so we return $r;$g;$b) #we want to support arbitrary rgb values specified in hex - so a table of 16M+ is probably not a great idea #hex zero-padded - canonically upper case but mixed or lower accepted #dict for {k v} $WEB_colour_map { @@ -1539,7 +1539,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable SGR_map return $SGR_map } - + proc colourmap1 {args} { set opts {-bg Web-white -forcecolour 0} foreach {k v} $args { @@ -1603,7 +1603,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } package require textblock set clist [list] - set fg "black" + set fg "black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "black"} { @@ -1647,14 +1647,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::get $opts -forcecolour]} { set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 0} {$i <=15} {incr i} { - set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? + set cname [tcl::dict::get $TERM_colour_map_reverse $i] ;#use term-$i etc instead of term-$name? if {[llength $row]== 8} { lappend rows $row set row [list] @@ -1686,7 +1686,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } set out "" - set fg "web-black" + set fg "web-black" for {set i 16} {$i <=231} {incr i} { if {$i % 18 == 16} { if {$fg eq "web-black"} { @@ -1694,7 +1694,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } else { set fg "web-black" } - set br "\n" + set br "\n" } else { set br "" } @@ -1716,10 +1716,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set out "" #use the reverse lookup dict - the original xterm_names list has duplicates - we want the disambiguated (potentially suffixed) names - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-black" + set fg "web-black" set t [textblock::class::table new] $t configure -show_seps 0 -show_edge 0 for {set i 16} {$i <=231} {incr i} { @@ -1892,10 +1892,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set fc "forcecolour" } - variable TERM_colour_map_reverse + variable TERM_colour_map_reverse set rows [list] set row [list] - set fg "web-white" + set fg "web-white" set t [textblock::class::table new] $t configure -show_hseps 0 -show_edge 0 for {set i 232} {$i <=255} {incr i} { @@ -1955,7 +1955,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set all_groupnames [list basic brown yellow red pink orange purple blue cyan green white gray] switch -- $groups { "" - * { - set show_groups $all_groupnames + set show_groups $all_groupnames } ? { return "Web group names: $all_groupnames" @@ -1996,7 +1996,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #$t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Rgb-$cdec] $t configure_row [expr {[$t row_count]-1}] -ansibase [a+ {*}$fc $fg Web-$cname] } - $t configure -frametype {} + $t configure -frametype {} $t configure_column 0 -headers [list "[tcl::string::totitle $g] colours"] $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] @@ -2106,7 +2106,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set undercurly "undercurly \[a+ undercurly und-199-21-133\]text\[a] -> [a+ undercurly und-199-21-133]text$RST" set underdotted "underdotted \[a+ underdotted und#FFD700\]text\[a] -> [a+ underdotted und#FFD700]text$RST" set underdashed "underdashed \[a+ underdashed undt-45\]text\[a] -> [a+ underdashed undt-45]text$RST" - set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" + set underline_c "named terminal colour SGR underline \[a+ underline undt-deeppink1\]text\[a] -> [a+ underline undt-deeppink1]text$RST" append out "${indent}$undercurly $underdotted" \n append out "${indent}$underdashed" \n append out "${indent}$underline_c" \n @@ -2115,7 +2115,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu append out "${indent}If a fallback to standard underline is required, underline should be added along with extended codes such as underlinedotted, underlinedouble etc" \n append out "${indent}e.g cyan with curly yellow underline or fallback all cyan underlined \[a+ cyan undercurly underline undt-yellow\]text\[a] -> [a+ {*}$fc cyan undercurly underline undt-yellow]text$RST" \n append out "[a+ {*}$fc web-white]Standard SGR colours and attributes $RST" \n - set settings_applied $SGR_setting_map + set settings_applied $SGR_setting_map set strmap [list] #safe jumptable test #dict for {k v} $SGR_setting_map {} @@ -2139,7 +2139,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try package require textblock - append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n + append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n set bgname "Web-white" @@ -2287,7 +2287,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu if {[tcl::dict::exists $TERM_colour_map $tail]} { set descr [tcl::dict::get $TERM_colour_map $tail] } else { - set descr "UNKNOWN colour for term" + set descr "UNKNOWN colour for term" } } $t add_row [list $i $descr $s [ansistring VIEW $s]] @@ -2303,11 +2303,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t add_row [list $i $descr $s [ansistring VIEW $s]] } - rgb- - Rgb- - RGB- - - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - + rgb- - Rgb- - RGB- - + rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - - rgb# - Rgb# - RGB# - + RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 - + rgb# - Rgb# - RGB# - und# - und- { set cont [string range $i end-11 end] switch -- $cont { @@ -2430,7 +2430,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } #REVIEW! note that OSC 4 can change the 256 color pallette - #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ + #e.g \x1b\]4\;1\;#HHHHHH\x1b\\ # (or with colour name instead of rgb #HHHHHH on for example wezterm) #Q: If we can't detect OSC 4 - how do we know when to invalidate/clear at least the 256 color portion of the cache? @@ -2492,13 +2492,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set linelen $thislen } else { append line "$ansi$key$RST " - incr linelen $thislen + incr linelen $thislen } } if {[tcl::string::length $line]} { lappend lines $line } - return [join $lines \n] + return [join $lines \n] } #PUNKARGS doc performed below, after we create the proc @@ -2506,10 +2506,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun a+] [opt {ansicode...}]] #[para]Returns the ansi code to apply those from the supplied list - without any reset being performed first - #[para] e.g to set foreground red and bold + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #function name part of cache-key because a and a+ return slightly different results (a has leading reset) @@ -2538,7 +2538,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set args [lremove $args $fcpos] } - set t [list] + set t [list] set e [list] ;#extended codes needing to go in own escape sequence foreach i $args { set f4 [tcl::string::range $i 0 3] @@ -2560,7 +2560,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] switch -- $cont { -contrasting { set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] @@ -2592,7 +2592,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] switch -- $cont { -contrasting { set rgb [join [punk::ansi::colour::contrasting {*}[split $rgbdash -]] {;}] @@ -2629,13 +2629,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu unde { #TODO - fix # extended codes with colon suppress normal SGR attributes when in same escape sequence on terminal that don't support the extended codes. - # need to emit in + # need to emit in switch -- $i { underline { lappend t 4 ;#underline } underlinedefault { - lappend t 59 + lappend t 59 } underextendedoff { #lremove any existing 4:1 etc @@ -2689,7 +2689,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -2749,10 +2749,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a+ $args'" } @@ -2763,19 +2763,19 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a+ $args'" } } } - rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - + rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 - Rgb- - RGB- - Rgb0 - Rgb1 - Rgb2 - Rgb3 - Rgb4 - Rgb5 - Rgb6 - Rgb7 - Rgb8 - Rgb9 - RGB0 - RGB1 - RGB2 - RGB3 - RGB4 - RGB5 - RGB6 - RGB7 - RGB8 - RGB9 { #decimal rgb foreground/background - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx set cont [string range $i end-11 end] switch -- $cont { @@ -2832,8 +2832,8 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx #https://wezfurlong.org/wezterm/escape-sequences.html#csi-582-underline-color-rgb set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set RGB [lrange [tcl::string::map [list - { } , { } {;} { }] $rgbspec] 0 2] @@ -2854,7 +2854,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend e "58:2::$rgbfinal" } "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] #set rgb [join [::scan $hex6 %2X%2X%2X] {:}] set RGB [::scan $hex6 %2X%2X%2X] @@ -2880,10 +2880,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -2894,7 +2894,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -2906,7 +2906,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -2927,10 +2927,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #the performance penalty must not be placed on the standard colour_enabled path. #This is punk. Colour is the happy path despite the costs. - #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. - #As no_color doesn't strip all ansi - the motivation for it should not generally be + #The no_color users will still get a performance boost from shorter string processing if that's one of their motivations. + #As no_color doesn't strip all ansi - the motivation for it should not generally be if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -2940,7 +2940,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -2994,12 +2994,12 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu 0-255 int values for red, green and blue. rgb# Rgb# where is a 6 char hex colour e.g rgb#C71585 web- Web- - + The acceptable values for and can be queried using punk::ansi::a? term and punk::ansi::a? web - + Example to set foreground red and background cyan followed by a reset: set str \"[a+ red Cyan]sample text[a]\" " @@ -3009,11 +3009,11 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun a] [opt {ansicode...}]] #[para]Returns the ansi code to reset any current settings and apply those from the supplied list - #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text - #[para] e.g to set foreground red and bold + #[para] by calling punk::ansi::a with no arguments - the result is a reset to plain text + #[para] e.g to set foreground red and bold #[para]punk::ansi::a red bold #[para]to set background red - #[para]punk::ansi::a Red + #[para]punk::ansi::a Red #[para]see [cmd punk::ansi::a?] to display a list of codes #It's important to put the functionname in the cache-key because a and a+ return slightly different results @@ -3041,7 +3041,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set args [lremove $args $fcpos] } - set t [list] + set t [list] set e [list] ;#extended codes will suppress standard SGR colours and attributes if merged in same escape sequence foreach i $args { set f4 [tcl::string::range $i 0 3] @@ -3052,7 +3052,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground web colour set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $WEB_colour_map $cname]} { - set rgbdash [tcl::dict::get $WEB_colour_map $cname] + set rgbdash [tcl::dict::get $WEB_colour_map $cname] set rgb [tcl::string::map { - ;} $rgbdash] lappend t "38;2;$rgb" } else { @@ -3093,7 +3093,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend t 4 ;#underline } underlinedefault { - lappend t 59 + lappend t 59 } underextendedoff { #lremove any existing 4:1 etc @@ -3147,7 +3147,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } default { puts stderr "ansi term unmatched: defa* '$i' in call 'a $args' (defaultfg,defaultbg,defaultund)" - } + } } } nohi {lappend t 28 ;#nohide} @@ -3207,10 +3207,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend t "38;5;$cc" + lappend t "38;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "38;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term colour unmatched: '$i' in call 'a $args'" } @@ -3221,10 +3221,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #256 colour background by Xterm name or by integer set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] && $cc < 256} { - lappend t "48;5;$cc" + lappend t "48;5;$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" + lappend t "48;5;[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi Term colour unmatched: '$i' in call 'a $args'" } @@ -3232,7 +3232,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } rgb- - rgb0 - rgb1 - rgb2 - rgb3 - rgb4 - rgb5 - rgb6 - rgb7 - rgb8 - rgb9 { #decimal rgb foreground - #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx + #allow variants rgb-xxx-xxx-xxx and rgbxxx-xxx-xxx set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set rgb [tcl::string::map [list - {;} , {;}] $rgbspec] lappend t "38;2;$rgb" @@ -3256,14 +3256,14 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu lappend t "48;2;$rgb" } und- - und0 - und1 - und2 - und3 - und4 - und5 - und6 - und7 - und8 - und9 { - #decimal rgb underline - #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx + #decimal rgb underline + #allow variants und-xxx-xxx-xxx and undxxx-xxx-xxx set rgbspec [tcl::string::trim [tcl::string::range $i 3 end] -] set rgb [tcl::string::map [list - {:} , {:}] $rgbspec] lappend e "58:2::$rgb" } "und#" { - #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators + #hex rgb underline - (e.g kitty, wezterm) - uses colons as separators set hex6 [tcl::string::trim [tcl::string::range $i 4 end] -] set rgb [join [::scan $hex6 %2X%2X%2X] {:}] lappend e "58:2::$rgb" @@ -3274,10 +3274,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #name is xterm name or colour index from 0 - 255 set cc [tcl::string::trim [tcl::string::tolower [tcl::string::range $i 4 end]] -] if {[tcl::string::is integer -strict $cc] & $cc < 256} { - lappend e "58:5:$cc" + lappend e "58:5:$cc" } else { if {[tcl::dict::exists $TERM_colour_map $cc]} { - lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" + lappend e "58:5:[tcl::dict::get $TERM_colour_map $cc]" } else { puts stderr "ansi term underline colour unmatched: '$i' in call 'a $args'" } @@ -3288,7 +3288,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #foreground X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "38;2;$rgb" } else { @@ -3300,7 +3300,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #background X11 names set cname [tcl::string::tolower [tcl::string::range $i 4 end]] if {[tcl::dict::exists $X11_colour_map $cname]} { - set rgbdash [tcl::dict::get $X11_colour_map $cname] + set rgbdash [tcl::dict::get $X11_colour_map $cname] set rgb [tcl::string::map [list - {;}] $rgbdash] lappend t "48;2;$rgb" } else { @@ -3318,9 +3318,9 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } } - + if {$colour_disabled && !$forcecolour} { - set tkeep [list] + set tkeep [list] foreach code $t { switch -- $code { 0 - 1 - 2 - 3 - 23 - 4 - 21 - 24 - 5 - 6 - 25 - 7 - 27 - 8 - 28 - 9 - 29 - 22 - 39 - 49 - 53 - 55 - 51 - 52 - 54 - 59 { @@ -3330,7 +3330,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } } set t $tkeep - set ekeep [list] + set ekeep [list] foreach code $e { switch -- $code { 4:0 - 4:1 - 4:2 - 4:3 - 4:4 - 4:5 { @@ -3431,7 +3431,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun reset]] #[para]reset console - return "\x1bc" + return "\x1bc" } proc reset_soft {} { #*** !doctools @@ -3450,7 +3450,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #*** !doctools #[call [fun reset_colour]] #[para]reset colour only - return "\x1b\[0m" + return "\x1b\[0m" } # -- --- --- --- --- @@ -3578,7 +3578,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu Sequence is of the form: ESCY - This sequence will generally not be understood by terminals + This sequence will generally not be understood by terminals that are not in vt52 mode (e.g DECANM unset). } @values -min 2 -max 2 @@ -3605,7 +3605,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu proc move_emit {row col data args} { #*** !doctools #[call [fun move_emit] [arg row] [arg col] [arg data] [opt {row col data...}]] - #[para]Return an ansi string representing a move to row col with data appended + #[para]Return an ansi string representing a move to row col with data appended #[para]row col data can be repeated any number of times to return a string representing the output of the data elements at all those points #[para]Compare to punk::console::move_emit which calls this function - but writes it to stdout #[para]punk::console::move_emit_return will also return the cursor to the original position @@ -3773,13 +3773,13 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu return \x1b\[3l } - #DECSNM + #DECSNM #Note this can invert the enclosed section including any already reversed by SGR 7 - depending on terminal support. - #e.g + #e.g #set test [a+ reverse]aaa[a+ noreverse]bbb # - $test above can't just be reversed by putting another [a+ reverse] in front of it. # - but the following will work (even if underlying terminal doesn't support ?5 sequences) - #overtype::renderspace -width 20 [enable_inverse]$test + #overtype::renderspace -width 20 [enable_inverse]$test proc enable_inverse {} { return \x1b\[?5h } @@ -3818,7 +3818,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # \x1b\[?7\;1\$y # \x1b\[?7\;2\$y #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) - + #https://wiki.tau.garden/dec-modes/ #(DEC,xterm,contour,mintty,kitty etc) #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking @@ -3837,7 +3837,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu # mouse_urxvt 1015\ # mouse_sgr_pixel 1016\ #] - variable decmode_data { + variable decmode_data { 1 { {origin DEC description "DECCKM - Cursor Keys Mode" names {DECCKM cursor_keys}} } @@ -3864,7 +3864,7 @@ In VT52 mode - use \x1b< to exit. {origin "xterm" description "X10 compatibility mouse" names {SET_X10_MOUSE mouse_tracking} note { Escape sequence on button press only. CSI M CbCxCy (6 chars) -Coords limited to 223 (=255 - 32) +Coords limited to 223 (=255 - 32) } } {origin DEC description "DECINLM - Interlace Mode (obsolete?)" names {DECINLM}} @@ -3925,7 +3925,7 @@ to 223 (=255 - 32) 2004 { {origin "xterm" description "Set bracketed paste mode" names {bracketed_paste}} } - 2027 { + 2027 { {origin Contour description "Grapheme Cluster Processing" names {grapheme_clusters}} } } @@ -3936,7 +3936,7 @@ to 223 (=255 - 32) foreach nm $names { dict set decmode_names $nm $code } - } + } } @@ -3960,12 +3960,12 @@ to 223 (=255 - 32) #Alt screen buffer - smcup/rmcup ti/te #Note \x1b\[?47h doesn't work at all in some terminals (e.g alacritty,cmd on windows and reportedly kitty) - #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. + #It is also reported to have 'deceptively similar' effects to 1049 -but to be 'subtly broken' on some terminals. #see: https://xn--rpa.cc/irl/term.html #1049 (introduced by xterm in 1998?) considered the more modern version? #1047,1048,1049 xterm private modes are 'composite' control sequences as replacement for original 47 sequence #1049 - includes save cursor,switch to alt screen, clear screen - #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) + #e.g ? (below example not known to be exactly what 1049 does - but it's something similar) #SMCUP # \x1b7 (save cursor) # \x1b\[?47h (switch) @@ -3973,10 +3973,10 @@ to 223 (=255 - 32) #RMCUP # \x1b\[?47l (switch back) # \x1b8 (restore cursor) - + #1047 - clear screen on the way out (ony if actually on alt screen) proc enable_alt_screen {} { - #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? + #tput smcup outputs "\x1b\[?1049h\x1b\[22\;0\;0t" second esc sequence - DECSLPP? setting page height one less than main screen? return \x1b\[?1049h } proc disable_alt_screen {} { @@ -4114,13 +4114,13 @@ to 223 (=255 - 32) #[para]Use punk::console::get_cursor_pos or punk::console::get_cursor_pos_list instead. #[para]These functions will emit the code - but read it in from stdin so that it doesn't display, and then return the row and column as a colon-delimited string or list respectively. #[para]The punk::ansi::cursor_pos function is used by punk::console::get_cursor_pos and punk::console::get_cursor_pos_list - return \033\[6n + return \033\[6n } - + proc cursor_pos_extended {} { #includes page e.g ^[[47;3;1R #(but not on all terminals - some (freebsd?) will report as per 6n e.g ^[[74;3R) - return \033\[?6n + return \033\[?6n } @@ -4128,7 +4128,7 @@ to 223 (=255 - 32) #REVIEW - vt100 accepts decimal values 132-126 and 160-255 ("in the current GL or GR in-use table") #some modern terminals accept and display characters outside this range - but this needs investigation. #in a modern unicode era - the restricted range doesn't make a lot of sense - but we need to see what terminal emulators actually do. - #e.g what happens with double-width? + #e.g what happens with double-width? #this wrapper accepts a char rather than a decimal value proc fill_rect {char t l b r} { set dec [scan $char %c] @@ -4169,7 +4169,7 @@ to 223 (=255 - 32) } - #alternative to string terminator is \007 - + #alternative to string terminator is \007 - proc titleset {windowtitle} { #*** !doctools #[call [fun titleset] [arg windowtitles]] @@ -4181,7 +4181,7 @@ to 223 (=255 - 32) return \x1bS$windowtitle\r } #titleget - https://invisible-island.net/xterm/xterm.faq.html#how2_title - #no cross-platform ansi-only mechanism ? + #no cross-platform ansi-only mechanism ? proc test_decaln {} { #Screen Alignment Test @@ -4189,13 +4189,13 @@ to 223 (=255 - 32) #(doesn't work on many terminals - seems to work in FreeBSD 13.2 and wezterm on windows) return \x1b#8 } - + #length of text for printing characters only #- unicode and other non-printing chars and combining sequences should be handled by the ansifreestring_width call at the end. #certain unicode chars are full-width (single char 2 columns wide) e.g see "Halfwdith and fullwidth forms" and ascii_fuillwidth blocks in punk::char::charset_names #review - is there an existing library or better method? printing to a terminal and querying cursor position is relatively slow and terminals lie. #Note this length calculation is only suitable for lines being appended to other strings if the line is pre-processed to account for backspace and carriage returns first - #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. + #If the raw line is appended to another string without such processing - the backspaces & carriage returns can affect data prior to the start of the string. proc printing_length {line} { #string last faster than string first for long strings anyway if {[tcl::string::last \n $line] >= 0} { @@ -4203,7 +4203,7 @@ to 223 (=255 - 32) } #what if line has \v (vertical tab) ie more than one logical screen line? - #review - detect ansi moves and warn/error? They would invalidate this algorithm + #review - detect ansi moves and warn/error? They would invalidate this algorithm #for a string with ansi moves - we would need to use the overtype::renderline function (which is a bit heavier) #arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review #the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char @@ -4237,7 +4237,7 @@ to 223 (=255 - 32) } #NOTE - this is non-destructive backspace as it occurs in text blocks - and is likely different to the sequence coming from a terminal or editor which generally does a destructive backspace - #e.g + #e.g #This means for example that abc\b has a length of 3. Trailing or leading backslashes have no effect #set bs [format %c 0x08] @@ -4260,16 +4260,16 @@ to 223 (=255 - 32) } #mintty seems more 'correct'. It will backspace over an entire grapheme (char+combiners) whereas windows terminal/wezterm etc remove a combiner - #build an output + #build an output set idx 0 set outchars [list] set outsizes [list] # -- - #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code + #tcl8.6/8.7 we can get a fast byte-compiled switch statement only with literals in the source code #this is difficult/risky to maintain - hence the lsearch and grapheme-replacement above #we could reasonably do it with backspace - but cr is more difficult #note that \x08 \b etc won't work to create a compiled switch statement even with unbraced (separate argument) form of switch statement. - #set bs "" + #set bs "" #set cr ? # -- foreach c $chars { @@ -4283,10 +4283,10 @@ to 223 (=255 - 32) set idx 0 } default { - #set nxt [llength $outchars] + #set nxt [llength $outchars] if {$idx < [llength $outchars]} { #overstrike? - should usually have no impact on width - width taken as last grapheme in that column - #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done + #e.g nroff would organise text such that underline written first, then backspace, then the character - so that terminals without overstrike would display something useful if no overstriking is done #Conceivably double_wide_char then backspace then underscore would underreport the length if overstriking were intended. lset outchars $idx $c } else { @@ -4338,7 +4338,7 @@ to 223 (=255 - 32) #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) if {[string length $text] < 2} {return $text} if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] @@ -4358,7 +4358,7 @@ to 223 (=255 - 32) #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } set parts [punk::ansi::ta::split_codes $text] #todo - try: join [lsearch -stride 2 -index 0 -subindices -all -inline $parts *] "" @@ -4369,9 +4369,9 @@ to 223 (=255 - 32) proc ansistripraw {text} { #*** !doctools #[call [fun ansistripraw] [arg text] ] - #[para]Return a string with ansi codes stripped out + #[para]Return a string with ansi codes stripped out #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. - #[para]ie instead of a horizontal line you may see: qqqqqq + #[para]ie instead of a horizontal line you may see: qqqqqq if {[string length $text] < 2} {return $text} set parts [punk::ansi::ta::split_codes $text] @@ -4403,7 +4403,7 @@ tcl::namespace::eval punk::ansi { # name (one not found in xterm's tables) ends processing of the # list of names. proc xtgetcap {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -4412,7 +4412,7 @@ tcl::namespace::eval punk::ansi { return "\x1bP+q$payload\x1b\\" } proc xtgetcap2 {keylist} { - #ESC P = 0x90 = DCS = Device Control String + #ESC P = 0x90 = DCS = Device Control String set hexkeys [list] foreach k $keylist { lappend hexkeys [util::str2hex $k] @@ -4432,8 +4432,8 @@ tcl::namespace::eval punk::ansi { #review - separate namespace for functions that operate on multiple or embedded? proc is_sgr {code} { - #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline - #we will accept and pass through the less common colon separator (ITU Open Document Architecture) + #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline + #we will accept and pass through the less common colon separator (ITU Open Document Architecture) #Terminals should generally ignore it if they don't use it regexp {\033\[[0-9;:]*m$} $code } @@ -4450,7 +4450,7 @@ tcl::namespace::eval punk::ansi { return 1 } } - return 0 + return 0 } #pure SGR reset with no other functions proc is_sgr_reset {code} { @@ -4458,8 +4458,8 @@ tcl::namespace::eval punk::ansi { #[call [fun is_sgr_reset] [arg code]] #[para]Return a boolean indicating whether this string has a trailing pure SGR reset #[para]Note that if the reset is not the very last item in the string - it will not be detected. - #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. - + #[para]This is primarily intended for testing a single ansi code sequence, but code can be any string where the trailing SGR code is to be tested. + #todo 8-bit csi regexp {\x1b\[0*m$} $code } @@ -4469,7 +4469,7 @@ tcl::namespace::eval punk::ansi { #if an SGR code has a reset in it - we don't need to carry forward any previous SGR codes #it generally only makes sense for the reset to be the first parameter - otherwise the code has ineffective portions #However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. - #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. + #We only look at the initial parameter within the trailing SGR code as this is the well-formed normal case. #Review - consider normalizing sgr codes to remove other redundancies such as setting fg or bg colour twice in same code proc has_sgr_leadingreset {code} { @@ -4477,7 +4477,7 @@ tcl::namespace::eval punk::ansi { #[call [fun has_sgr_leadingreset] [arg code]] #[para]The reset must be the very first item in code to be detected. Trailing strings/codes ignored. set params "" - #we need non-greedy + #we need non-greedy if {[regexp {^\033\[([^m]*)m} $code _match params]} { #must match trailing m to be the type of reset we're looking for set plist [split $params ";"] @@ -4506,7 +4506,7 @@ tcl::namespace::eval punk::ansi { #regexp {\x1b\(B|\x1b\)B} $code regexp {\x1b(?:\(B|\)B)} $code } - #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through + #input assumed to be single codes - simple test for 2nd char left bracket and trailing m is done anyway - codes not matching are ignored and passed through #This is not order-preserving if non-sgr codes are present as they are tacked on to the end even if they initially were before all SGR codes variable codestate_empty @@ -4514,11 +4514,11 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty rst "" ;#0 (or empty) tcl::dict::set codestate_empty intensity "" ;#1 bold, 2 dim, 22 normal tcl::dict::set codestate_empty italic "" ;#3 on 23 off - tcl::dict::set codestate_empty underline "" ;#4 on 24 off + tcl::dict::set codestate_empty underline "" ;#4 on 24 off #nonstandard/extended 4:0,4:1,4:2,4:3,4:4,4:5 #4:1 single underline and 4:2 double underline deliberately kept separate to standard SGR versions - #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines + #The extended codes are merged separately allowing fallback SGR to be specified for terminals which don't support extended underlines tcl::dict::set codestate_empty underextended "" ;#4:0 for no extended underline 4:1 etc for underline styles #tcl::dict::set codestate_empty undersingle "" #tcl::dict::set codestate_empty underdouble "" @@ -4550,10 +4550,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate_empty superscript "" ;#73 tcl::dict::set codestate_empty subscript "" ;#74 tcl::dict::set codestate_empty nosupersub "" ;#75 - # -- + # -- tcl::dict::set codestate_empty fg "" ;#30-37 + 90-97 - tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 + tcl::dict::set codestate_empty bg "" ;#40-47 + 100-107 #misnomer should have been sgr_merge_args ? :/ @@ -4562,7 +4562,7 @@ tcl::namespace::eval punk::ansi { if {[llength $args] == 0} { return "" } elseif {[llength $args] == 1} { - return [lindex $args 0] + return [lindex $args 0] } sgr_merge $args } @@ -4610,7 +4610,7 @@ tcl::namespace::eval punk::ansi { set did_reset 0 #we should also handle 8bit CSI here? mixed \x1b\[ and \x9b ? Which should be used in the merged result? - #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? + #There are arguments to move to 8bit CSI for keyboard protocols (to solve keypress timing issues?) - but does this extend to SGR codes? #we will output 7bit merge of the SGRs even if some or all were 8bit CSi #As at 2024 - 7bit are widely supported 8bit seem to be often ignored by pseudoterminals #auto-detecting and emitting 8bit only if any are present in our input doesn't seem like a good idea - as sgr_merge_list is only seeing a subset of the data - so any auto-decision at this level will just introduce indeterminism. @@ -4644,10 +4644,10 @@ tcl::namespace::eval punk::ansi { #some codes have additional parameters - e.g rgb colours so we need to jump forward in the parameter list sometimes. for {set i 0} {$i < [llength $plist]} {incr i} { set p [lindex $plist $i] - set paramsplit [split $p :] - #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters + set paramsplit [split $p :] + #for some cases we passthrough $p instead of just the number - in case another implementation uses the colon subparameters #e.g see https://github.com/mintty/mintty/wiki/Tips#text-attributes-and-rendering - #this may have originated with kitty? + #this may have originated with kitty? #windows terminal seems to be implementing it too #however, they can be completely repurposed - so we probably need to specifically support them.. REVIEW. @@ -4682,7 +4682,7 @@ tcl::namespace::eval punk::ansi { #REVIEW - merging extended (e.g 4:4) underline attributes suppresses all other SGR attributes on at least some terminals which don't support extended underlines #e.g hyper on windows if {[llength $paramsplit] == 1} { - tcl::dict::set codestate underline 4 + tcl::dict::set codestate underline 4 } else { switch -- [lindex $paramsplit 1] { 0 { @@ -4691,10 +4691,10 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate underextended 4:0 ;#will not turn off SGR standard underline if term doesn't support extended } 1 { - tcl::dict::set codestate underextended 4:1 + tcl::dict::set codestate underextended 4:1 } 2 { - tcl::dict::set codestate underextended 4:2 + tcl::dict::set codestate underextended 4:2 } 3 { tcl::dict::set codestate underextended "4:3" @@ -4716,7 +4716,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate reverse 7 } 8 { - tcl::dict::set codestate hide 8 + tcl::dict::set codestate hide 8 } 9 { tcl::dict::set codestate strike 9 @@ -4738,7 +4738,7 @@ tcl::namespace::eval punk::ansi { } 23 { #? wikipedia mentions blackletter - review - tcl::dict::set codestate italic 23 + tcl::dict::set codestate italic 23 } 24 { tcl::dict::set codestate underline 24 ;#off @@ -4766,11 +4766,11 @@ tcl::namespace::eval punk::ansi { 38 { #256 colour or rgb #check if subparams supplied as colon separated - if {[tcl::string::first : $p] < 0} { + if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate fg "38\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4780,9 +4780,9 @@ tcl::namespace::eval punk::ansi { } } } else { - #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space + #apparently subparameters can be left empty - and there are other subparams like transparency and colour-space #we should only need to pass it all through for the terminal to understand - #review + #review tcl::dict::set codestate fg $p } } @@ -4798,7 +4798,7 @@ tcl::namespace::eval punk::ansi { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate bg "48\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4818,7 +4818,7 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate proportional 50 ;#off - see 26 } 51 - 52 { - tcl::dict::set codestate frame_or_circle 51 + tcl::dict::set codestate frame_or_circle 51 } 53 { tcl::dict::set codestate overline 53 ;#not supported in terminals? pass through anyway @@ -4830,13 +4830,13 @@ tcl::namespace::eval punk::ansi { tcl::dict::set codestate overline 55; #off } 58 { - #nonstandard + #nonstandard #256 colour or rgb if {[tcl::string::first : $p] < 0} { switch -- [lindex $plist $i+1] { 5 { #256 - 1 more param - tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" + tcl::dict::set codestate underlinecolour "58\;5\;[lindex $plist $i+2]" incr i 2 } 2 { @@ -4905,11 +4905,11 @@ tcl::namespace::eval punk::ansi { } } - } + } default { lappend othercodes $c } - } + } } @@ -4920,7 +4920,7 @@ tcl::namespace::eval punk::ansi { #dict for {k v} $codestate {} tcl::dict::for {k v} $codestate { switch -- $v { - "" { + "" { } default { switch -- $k { @@ -5028,7 +5028,7 @@ tcl::namespace::eval punk::ansi { tcl::namespace::eval punk::ansi::ta { #*** !doctools #[subsection {Namespace punk::ansi::ta}] - #[para] text ansi functions + #[para] text ansi functions #[para] based on but not identical to the Perl Text Ansi module: #[para] https://github.com/perlancar/perl-Text-ANSI-Util/blob/master/lib/Text/ANSI/BaseUtil.pm #[list_begin definitions] @@ -5036,7 +5036,7 @@ tcl::namespace::eval punk::ansi::ta { variable PUNKARGS - #handle both 7-bit and 8-bit csi + #handle both 7-bit and 8-bit csi #review - does codepage affect this? e.g ebcdic has 8bit csi in different position #CSI @@ -5058,7 +5058,7 @@ tcl::namespace::eval punk::ansi::ta { #non-greedy by excluding ST terminators variable re_esc_osc1 {(?:\x1b\])(?:[^\007]*)\007} #variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\} ;#somewhat wrong - we want to exclude the ST - not other esc sequences - variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} + variable re_esc_osc2 {(?:\x1b\])(?:(?!\x1b\\).)*\x1b\\} variable re_esc_osc3 {(?:\u009d)(?:[^\u009c]*)?\u009c} variable re_osc_open {(?:\x1b\]|\u009d).*} @@ -5070,7 +5070,7 @@ tcl::namespace::eval punk::ansi::ta { #ESC Y move, ESC b foreground colour #ESC F - gr-on ESC G - gr-off variable re_vt52_open {(?:\x1bY|\x1bb|\x1bF)} - #\x1bc vt52 bgcolour conflict ?? + #\x1bc vt52 bgcolour conflict ?? #if we don't split on altgraphics too and separate them out - it's easy to get into a horrible mess variable re_g0_group {(?:\x1b\(0)(?:(?!\x1b\(B).)*\x1b\(B} @@ -5078,7 +5078,7 @@ tcl::namespace::eval punk::ansi::ta { variable re_g0_close {(?:\x1b\(B)} # DCS "ESC P" or "0x90" is also terminated by ST - set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} #ST terminators [list \007 \033\\ \u009c] #regex to capture the start of string/privacy message/application command block including the contents and string terminator (ST) @@ -5087,7 +5087,7 @@ tcl::namespace::eval punk::ansi::ta { #even if terminals generally don't support that - it's quite possible for an ansi code to get nested this way - and we'd prefer it not to break our splits #Just checking for \x1b will terminate the match too early #we also need to track the start of ST terminated code and not add it for replay (in the ansistring functions) - #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) + #variable re_ST {(?:\x1bX|\u0098|\x1b\^|\u009E|\x1b_|\u009F)(?:[^\x1b\007\u009c]*)(?:\x1b\\|\007|\u009c)} ;#downsides: early terminating with nests, mixes 7bit 8bit start/ends (does that exist in the wild?) #keep our 8bit/7bit start-end codes separate variable re_ST {(?:\x1bP|\x1bX|\x1b\^|\x1b_)(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007)|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)} @@ -5104,12 +5104,12 @@ tcl::namespace::eval punk::ansi::ta { #variable re_ansi_detect {(?:\x1b(?:\((?:0|B)|\[(?:[\x20-\x2f\x30-\x3f]*[\x40-\x7e])|\](?:(?:[^\007]*)\007|(?:(?!\x1b\\).)*\x1b\\)|(?:P|X|\^|_)(?:(?:(?!\x1b\\|\007).)*(?:\x1b\\|\007))|c|7|8|M|E|D|H|=|>|(?:#(?:3|4|5|6|8))))|(?:\u0090|\u0098|\u009E|\u009F)(?:(?!\u009c).)*(?:\u009c)|(?:\u009b)[\x20-\x2f\x30-\x3f]*[\x40-\x7e]|(?:\u009d)(?:[^\u009c]*)?\u009c} #NOTE - the literal # char can cause problems in expanded syntax - even though it's within a bracketed section. \# seems to work though. - #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| + #vt52 specific |<|A|B|C|I|J|K|L|M|Z|(?:Y(?:..))|(?:b(?:.)| #https://freemint.github.io/tos.hyp/en/VT_52_terminal.html #what to with ESC c vs vt52 ESC c (background colour) ??? #we probably need to use a separate re_ansi_detect for vt52 - #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes + #although it's stated later terminals are backwards compatible with vt52 - that doesn't seem to mean for example a vt100 will process vt52 codes at the same time as ansi codes #ie - when DECANM is on - VT52 codes are *not* processed #todo - ansi mode and cursor key mode set ? @@ -5129,8 +5129,8 @@ tcl::namespace::eval punk::ansi::ta { - variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" - + variable re_ansi_detect_open "${re_csi_open}|${re_osc_open}|${re_standalones}|${re_standalones_vt52}|${re_ST_open}|${re_g0_open}|${re_vt52_open}" + #may be same as detect - kept in case detect needs to diverge #variable re_ansi_split "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_esc_osc3}|${re_standalones}|${re_ST}|${re_g0_open}|${re_g0_close}" set re_ansi_split $re_ansi_detect @@ -5142,7 +5142,7 @@ tcl::namespace::eval punk::ansi::ta { } lappend PUNKARGS [list -dynamic 0 { - @id -id ::punk::ansi::ta::detect + @id -id ::punk::ansi::ta::detect @cmd -name punk::ansi::ta::detect -help\ "Return a boolean indicating whether Ansi codes were detected in text. Important caveat: @@ -5151,9 +5151,9 @@ tcl::namespace::eval punk::ansi::ta { (one example is if a list element contains an unbalanced brace) This can cause square brackets that form part of the ansi to be backslash escaped - and the function can fail to match it as an Ansi code. - " + " @values -min 1 - text -type string + text -type string } ] #*** !doctools @@ -5187,8 +5187,8 @@ tcl::namespace::eval punk::ansi::ta { proc detect_g0 {text} [string map [list [list $re_g0_group]] { regexp $text }] - #note - micro optimisation of inlining gives us *almost* nothing extra. - #left in place for a few such as detect/detect_g0 as we want them as fast as possible + #note - micro optimisation of inlining gives us *almost* nothing extra. + #left in place for a few such as detect/detect_g0 as we want them as fast as possible # in general the technique doesn't seem particularly worthwhile for this set of functions. #the performance is dominated by the complexity of the regexp proc detect2 {text} { @@ -5211,8 +5211,8 @@ tcl::namespace::eval punk::ansi::ta { #[call [fun detect_csi] [arg text]] #[para]Return a boolean indicating whether an Ansi Control Sequence Introducer (CSI) was detected in text #[para]The csi is often represented in code as \x1b or \033 followed by a left bracket [lb] - #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation - #[para]There is also a multi-byte escape sequence \u009b + #[para]The initial byte or escape is commonly referenced as ESC in Ansi documentation + #[para]There is also a multi-byte escape sequence \u009b #[para]This is less commonly used but is also detected here #[para](This function is not in perl ta) variable re_csi_open @@ -5240,7 +5240,7 @@ tcl::namespace::eval punk::ansi::ta { #*** !doctools #[call [fun length] [arg text]] #[para]Return the character length after stripping ansi codes - not the printing length - + #we can use ansistripraw to avoid g0 conversion - as the length should remain the same tcl::string::length [ansistripraw $text] } @@ -5259,11 +5259,11 @@ tcl::namespace::eval punk::ansi::ta { proc split_at_codes {str} [string map [list $re_ansi_split] { #variable re_ansi_split #punk::ansi::internal::splitx $str ${re_ansi_split} - punk::ansi::ta::Do_split_at_codes $str {} + punk::ansi::ta::Do_split_at_codes $str {} }] #it is faster to split this function out than to inline it into split_at_codes in tcl 8.7 - something to do with the use of the variable vs argument for the regexp #literal inlining of the re in the main proc-body was slower too - but inlining it into the wrapper seems to work (a tiny bit) - #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - + #the difference is not often apparent when comparing timerate results from split_at_codes vs split_at_codes2 - # - but in aggregate for something like textblock::periodic - we can get a bit over 5% faster (e.g 136ms vs 149ms) proc Do_split_at_codes {str regexp} { if {$str eq ""} { @@ -5342,12 +5342,12 @@ tcl::namespace::eval punk::ansi::ta { lappend list [tcl::string::range $str $start end] return $list }] - - # -- --- --- --- --- --- + + # -- --- --- --- --- --- #Split $text to a list containing alternating ANSI colour codes and text. #ANSI colour codes are always on the second element, fourth, and so on. #(ie plaintext on even list-indices ansi on odd indices) - #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) + #result of split on non-empty string always has an odd length - with indices 0 and end always being plaintext (possibly empty string) # Example: #split_codes "" # => "" #split_codes "a" # => "a" @@ -5361,7 +5361,7 @@ tcl::namespace::eval punk::ansi::ta { variable re_ansi_split_multi return [_perlish_split $re_ansi_split_multi $text] } - #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) + #micro optimisations on split_codes to avoid function calls and make re var local tend to yield very little benefit (sub uS diff on calls that commonly take 10s/100s of uSeconds) #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so even/odd indices for plain ansi still holds) #- the slightly simpler regex than split_codes means that it will be slightly faster than keeping the codes grouped. @@ -5413,16 +5413,16 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] - incr start + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchStart] + incr start } else { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] } if {$start >= [tcl::string::length $text]} { @@ -5437,20 +5437,20 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] - incr start + 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 $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] #? if {$start >= [tcl::string::length $text]} { @@ -5467,22 +5467,22 @@ tcl::namespace::eval punk::ansi::ta { } set list [list] set start 0 - + #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} { yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::index $text $matchStart] - incr start + yield [tcl::string::index $text $matchStart] + incr start if {$start >= [tcl::string::length $text]} { break } continue } yield [tcl::string::range $text $start $matchStart-1] - yield [tcl::string::range $text $matchStart $matchEnd] + yield [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] #? if {$start >= [tcl::string::length $text]} { @@ -5495,7 +5495,7 @@ tcl::namespace::eval punk::ansi::ta { proc _ws_split {text} { regexp -all -inline {(?:\S+)|(?:\s+)} $text } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #*** !doctools #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] @@ -5532,7 +5532,7 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- if {[llength $args] < 1} { error {usage: ?-width ? ?-height ? ?-autowrap_mode [1|0]? ?-overflow [1|0]? from_ansistring} @@ -5632,7 +5632,7 @@ tcl::namespace::eval punk::ansi::class { method rendernext {} { upvar ${o_ns_from}::o_ansisplits from_ansisplits upvar ${o_ns_from}::o_elements from_elements - upvar ${o_ns_from}::o_splitindex from_splitindex + upvar ${o_ns_from}::o_splitindex from_splitindex #if {![llength $from_ansisplits]} {$o_from_ansistring eval_in {my MakeSplit}} ;#!!todo - a better way to keep this method semi hidden but call from a 'friend' if {![llength $from_ansisplits]} { @@ -5658,7 +5658,7 @@ tcl::namespace::eval punk::ansi::class { set process_splitindex [lindex $from_splitindex $eidx] ;#which from_ansisplits index the first unrendered element belongs to set elementinfo [lindex $from_elements $eidx] - lassign $elementinfo type_rendered item + lassign $elementinfo type_rendered item #we don't expect type to change should be all graphemes (type 'g') or a single code (type 'sgr','other' etc) #review - we may want to store more info for graphemes e.g g0 g1 g2 for zero-wide 1-wide 2-wide ? #if so - we should report a list of the grapheme types that were rendered in a pt block @@ -5674,7 +5674,7 @@ tcl::namespace::eval punk::ansi::class { set e_splitindex $process_splitindex while {$e_splitindex == $process_splitindex && $eidx < [llength $from_elements]} { append newtext $item - lappend o_rendereditems $elementinfo + lappend o_rendereditems $elementinfo incr rendercount incr eidx @@ -5684,8 +5684,8 @@ tcl::namespace::eval punk::ansi::class { } } else { #while not g ? render however many ansi sequences are in a row? - set newtext $item - lappend o_rendereditems $elementinfo + set newtext $item + lappend o_rendereditems $elementinfo incr rendercount } @@ -5703,7 +5703,7 @@ tcl::namespace::eval punk::ansi::class { if {![tcl::string::length $overtext]} { continue } - #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] + #set rinfo [overtype::renderline -info 1 -insert_mode 0 -autowrap_mode 1 -width $o_width -overflow 0 -cursor_column $col -cursor_row $row $undertext $overtext] } } #renderspace equivalent? channel based? @@ -5714,7 +5714,7 @@ tcl::namespace::eval punk::ansi::class { } } - #name all with prefix class_ for rendertype detection + #name all with prefix class_ for rendertype detection oo::class create class_cp437 { superclass base_renderer } @@ -5733,7 +5733,7 @@ tcl::namespace::eval punk::ansi::class { #this is the main state we keep of the split apart string #we use the punk::ansi::ta::split_codes_single function which produces a list with zero, or an odd number elements always beginning and ending with plaintext - variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes + variable o_ptlist ;#plaintext as list of elements from ansisplits - will include empty elements from between adjacent ansi-codes variable o_ansisplits ;#store our plaintext/ansi-code splits so we don't keep re-running the regexp to split @@ -5750,7 +5750,7 @@ tcl::namespace::eval punk::ansi::class { variable o_elements ;#elements contains entry for each grapheme/control + each ansi code variable o_sgrstacks ;#list of ansi sgr codes that will be merged later. Entries deliberately repeat if no change from previous entry. Later scans look for difference between n and n-1 when deciding where to apply codes. variable o_gx0states ;#0|1 for alternate graphics gx0 - variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. + variable o_splitindex ;#entry for each element indicating the index of the split it belongs to. # -- -- constructor {string} { @@ -5763,7 +5763,7 @@ tcl::namespace::eval punk::ansi::class { if {"::punk::ansi::class" ni $nspath} { lappend nspath ::punk::ansi::class } - tcl::namespace::path $nspath + tcl::namespace::path $nspath #-- -- #we choose not to generate an internal split-state for the initial string - which may potentially be large. @@ -5772,7 +5772,7 @@ tcl::namespace::eval punk::ansi::class { set o_count "" ;#o_count first updated when string appended or a method causes MakeSplit to run (or by count method if constructor argument was empty string) - set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. + set o_ansisplits [list] ;#we get empty pt(plaintext) between each ansi code. Codes include cursor movements, resets,alt graphics modes, terminal mode settings etc. set o_ptlist [list] #o_ansisplits and o_ptlist should only remain empty if an empty string was passed to the contructor, or no methods have yet triggered the initial string to have it's internal state built. @@ -5786,7 +5786,7 @@ tcl::namespace::eval punk::ansi::class { #empty if no render methods used # -- - set o_renderer "" + set o_renderer "" set o_renderout "" ;#class_ansistring # -- @@ -5810,18 +5810,18 @@ tcl::namespace::eval punk::ansi::class { method show_state {{verbose 0}} { #show some state info - without updating anything - #only use 'my' methods that don't update the state e.g has_ansi + #only use 'my' methods that don't update the state e.g has_ansi set result "" if {![llength $o_ansisplits]} { append result "No internal splits. " append result \n "has ansi : [my has_ansi]" - append result \n "Tcl string length raw string: [tcl::string::length $o_string]" + append result \n "Tcl string length raw string: [tcl::string::length $o_string]" } else { append result \n "has ansi : [my has_ansi]" - append result \n "ansisplit list len: [llength $o_ansisplits]" + append result \n "ansisplit list len: [llength $o_ansisplits]" append result \n "plaintext list len: [llength $o_ptlist]" append result \n "cached count : $o_count" - append result \n "Tcl string length raw string : [tcl::string::length $o_string]" + append result \n "Tcl string length raw string : [tcl::string::length $o_string]" append result \n "Tcl string length plaintext parts: [tcl::string::length [join $o_ptlist ""]]" if {[llength $o_ansisplits] %2 == 0} { append result \n -------------------------------------------------- @@ -5860,10 +5860,10 @@ tcl::namespace::eval punk::ansi::class { #private method method MakeSplit {} { #The split with each code as it's own element is more generally useful. - set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; + set o_ansisplits [punk::ansi::ta::split_codes_single $o_string]; set o_ptlist [list] set codestack [list] - set gx0_state 0 ;#default off + set gx0_state 0 ;#default off set current_split_index 0 ;#incremented for each pt block, incremented for each code if {$o_count eq ""} { set o_count 0 @@ -5878,7 +5878,7 @@ tcl::namespace::eval punk::ansi::class { incr o_count } #after handling the pt block - incr the current_split_index - incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry + incr current_split_index ;#increment for each pt block - whether empty string or not. Indices corresponding to empty PT blocks will therefore not be present in o_splitindex as there were no elements in that ansisplit entry #we will only get an empty code at the very end of ansisplits (ansisplits is length 0 or odd length - always with pt at start and pt at end) if {$code ne ""} { lappend o_sgrstacks $codestack @@ -5914,7 +5914,7 @@ tcl::namespace::eval punk::ansi::class { } } #assertion every grapheme and every individual code has been added to o_elements - #every element has an entry in o_sgrstacks + #every element has an entry in o_sgrstacks #every element has an entry in o_gx0states assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} } @@ -5925,7 +5925,7 @@ tcl::namespace::eval punk::ansi::class { method strippedlength {} { if {![llength $o_ansisplits]} {my MakeSplit} #review - return [string length [join $o_ptlist ""]] + return [string length [join $o_ptlist ""]] } #returns the ansiless string - doesn't affect the stored state other than initialising it's internal state if it wasn't already method stripped {} { @@ -5938,13 +5938,13 @@ tcl::namespace::eval punk::ansi::class { method DoCount {plaintext} { #- combiners/diacritics just map them away here - but for consistency we need to combine unicode grapheme clusters too. #todo - joiners 200d? zwnbsp - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs + normal controls such as newline.. not screen width. Has to be consistent with index function return [tcl::string::length [regsub -all $re_diacritics $plaintext ""]] } - #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! + #This is the count of visible graphemes + non-ansi control chars. Not equal to column width or to the Tcl string length of the ansistripped string!!! method count {} { if {$o_count eq ""} { #only initial string present @@ -5977,7 +5977,7 @@ tcl::namespace::eval punk::ansi::class { #channels for stream in/out.. these are vaguely analogous to the input/output between a shell and a PTY Slave - but this is not intended to be a full pseudoterminal #renderstream_to_render (private?) - # write end held by outer ansistring? read end by inner render ansistring ? + # write end held by outer ansistring? read end by inner render ansistring ? #renderstream_from_render (public?) method rendertypes {} { @@ -5991,7 +5991,7 @@ tcl::namespace::eval punk::ansi::class { } set rtypes [my rendertypes] if {$rtype ni $rtypes} { - error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" + error "unknown rendertype '$rtype' - known types: $rtypes (punk::ansi::class::renderer::class_*)" } #if {$o_renderout eq ""} { # set o_renderout [punk::ansi::class::class_ansistring new ""] @@ -6022,7 +6022,7 @@ tcl::namespace::eval punk::ansi::class { } if {$rw eq $o_renderwidth} { return $o_renderwidth - } + } #re-render if needed? puts stderr "renderwidth todo? re-render?" @@ -6034,7 +6034,7 @@ tcl::namespace::eval punk::ansi::class { method render_state {} { #? report state of render.. we will primarily be using plaintext/ansisequence as the chunk/operation boundary #but - as we can append char sequences directly to the tail split - it's not enough to track which split element we have rendered - but we also need how many graphemes or code sequences we are into the last split. - #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work + #A single number representing the count of graphemes and individual ANSI codes (from the input ansistring) rendered might work } method renderbuf {} { #get the underlying renderobj - if any @@ -6071,7 +6071,7 @@ tcl::namespace::eval punk::ansi::class { return [dict create graphemes $grapheme_count other $other_count] } method rendernext {} { - #render next available pt/code chunk only - not to end of available input + #render next available pt/code chunk only - not to end of available input if {$o_renderer eq ""} { my rendertype $o_rendertype ;#review - proper way to initialise rendering } @@ -6111,7 +6111,7 @@ tcl::namespace::eval punk::ansi::class { } #analagous to Tcl string append - #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient + #MAINTENANCE: we need to be very careful to account for unsplit initial state - which exists to make certain operations that don't require an ansi split more efficient method append {args} { set catstr [join $args ""] if {$catstr eq ""} { @@ -6122,19 +6122,19 @@ tcl::namespace::eval punk::ansi::class { #ansi-free additions #if no initial internal-split - generate it without first appending our additions - as we can more efficiently append them to the internal state if {![llength $o_ansisplits]} { - #initialise o_count because we need to add to it. + #initialise o_count because we need to add to it. #The count method will do this by calling Makesplit only if it needs to. (which will create ansisplits for anything except empty string) my count } append o_string $catstr;# only append after updating using my count above if {![llength $o_ptlist]} { - #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits + #If the object was initialised with empty string - we can still have empty lists for o_ptlist and o_ansisplits #even though we can use lset to add to a list - we can't for empty lappend o_ptlist $catstr #assertion - if o_ptlist is empty so is o_ansisplits lappend o_ansisplits $catstr } else { - lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] + lset o_ptlist end [tcl::string::cat [lindex $o_ptlist end] $catstr] lset o_ansisplits end [tcl::string::cat [lindex $o_ansisplits end] $catstr] } set last_codestack [lindex $o_sgrstacks end] @@ -6156,16 +6156,16 @@ tcl::namespace::eval punk::ansi::class { #set combined_plaintext [join $o_ptlist ""] #set o_count [my DoCount $combined_plaintext] assert {[llength $o_elements] == [llength $o_sgrstacks] && [llength $o_elements] == [llength $o_gx0states] && [llength $o_elements] == [llength $o_splitindex]} - return $o_string + return $o_string } else { - #update each element of internal state incrementally without reprocessing what is already there. + #update each element of internal state incrementally without reprocessing what is already there. append o_string $catstr - set newsplits [punk::ansi::ta::split_codes_single $catstr] + set newsplits [punk::ansi::ta::split_codes_single $catstr] set ptnew "" set codestack [lindex $o_sgrstacks end] set gx0_state [lindex $o_gx0states end] - set current_split_index [lindex $o_splitindex end] - #first pt must be merged with last element of o_ptlist + set current_split_index [lindex $o_splitindex end] + #first pt must be merged with last element of o_ptlist set new_pt_list [list] foreach {pt code} $newsplits { lappend new_pt_list $pt @@ -6216,7 +6216,7 @@ tcl::namespace::eval punk::ansi::class { #if {$o_count eq ""} { # #we have splits - but didn't count graphemes? - # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts + # set o_count [my DoCount [join $o_ptlist ""]] ;#o_ptlist already has ptnew parts #} else { # incr o_count [my DoCount $ptnew] #} @@ -6227,7 +6227,7 @@ tcl::namespace::eval punk::ansi::class { return $o_string } - #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. + #we are currently assuming that the component strings have complete graphemes ie no split clusters - and therefore we don't attempt to check for and combine at the string catenation points. #This is 'often'? likely to be true - We don't have grapheme cluster support yet anyway. review. method appendobj {args} { if {![llength $o_ansisplits]} { @@ -6272,7 +6272,7 @@ tcl::namespace::eval punk::ansi::class { set firstnewidx [lindex $new_splitindex 0] set diffidx [expr {$lastidx - $firstnewidx}] ;#may be negative foreach v $new_splitindex { - lappend o_splitindex [expr {$v + $diffidx}] + lappend o_splitindex [expr {$v + $diffidx}] } incr o_count $new_count @@ -6323,7 +6323,7 @@ tcl::namespace::eval punk::ansi::class { set arrow_lr \u2194 set arrow_du \u2195 #2024 - there is no 4-arrow symbol or variations (common cursor and window icon) in unicode - despite requests and argument from the community that this has been in use for decades. - #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. + #They are probably too busy with stupid emoji additions to add this or c1 visualization glyphs. #don't split into lines first - \n is valid within ST sections set output "" @@ -6338,7 +6338,7 @@ tcl::namespace::eval punk::ansi::class { set c1 [tcl::string::index $code 0] set c1c2 [tcl::string::range $code 0 1] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} + #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[ 7CSI\ \x9b 8CSI\ @@ -6346,9 +6346,9 @@ tcl::namespace::eval punk::ansi::class { \x1b\( 7GFX\ \x9d 8OSC\ \x1b 7ESC\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - #we leave the tail of the code unmapped for now + #we leave the tail of the code unmapped for now switch -- $leadernorm { 7CSI - 7OSC { set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] @@ -6401,7 +6401,7 @@ tcl::namespace::eval punk::ansi::class { H - f { set params [tcl::string::range $codenorm 4 end-1] lassign [split $params {;}] row col - #lassign $matchinfo _match row col + #lassign $matchinfo _match row col set displaycode [ansistring VIEW $code] if {$col eq ""} { #row only move @@ -6423,7 +6423,7 @@ tcl::namespace::eval punk::ansi::class { append output ${unk}[ansistring VIEW -lf 1 $code]$RST } } - } + } 7GFX { switch -- [tcl::string::index $codenorm 4] { "0" { @@ -6456,7 +6456,7 @@ tcl::namespace::eval punk::ansi::class { #set splits [punk::ansi::ta::split_codes_single $string] set output "" set codestack [list] - set gx_stack [list] ;#not actually a stack + set gx_stack [list] ;#not actually a stack set cursor_saved "" foreach {pt code} $o_ansisplits { if {[llength $args]} { @@ -6482,13 +6482,13 @@ tcl::namespace::eval punk::ansi::class { #cursor_restore set codestack [list $cursor_saved] } else { - #leave SGR stack as is + #leave SGR stack as is if {[punk::ansi::codetype::is_gx_open $code]} { set gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess } elseif {[punk::ansi::codetype::is_gx_close $code]} { set gx_stack [list] - } - } + } + } } } return $output @@ -6500,24 +6500,24 @@ tcl::namespace::eval punk::ansi { proc stripansi3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - #using detect costs us a couple of uS - but saves time on plain text + #using detect costs us a couple of uS - but saves time on plain text #we should probably leave this for caller - otherwise it ends up being called more than necessary - #if {![::punk::ansi::ta::detect $text]} { + #if {![::punk::ansi::ta::detect $text]} { # return $text #} #alternate graphics codes are not the norm - # - so save a few uS in the common case by only calling convert_g0 if we detect + # - so save a few uS in the common case by only calling convert_g0 if we detect if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters } - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] proc stripansiraw3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { #join [::punk::ansi::ta::split_at_codes $text] "" - punk::ansi::ta::Do_split_at_codes_join $text {} + punk::ansi::ta::Do_split_at_codes_join $text {} }] } @@ -6533,7 +6533,7 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::namespace::ensemble create tcl::namespace::export length trim trimleft trimright INDEX COUNT VIEW VIEWCODES VIEWSTYLE INDEXABSOLUTE INDEXCOLUMNS COLUMNINDEX NEW #todo - expose _splits_ methods so caller can work efficiently with the splits themselves - #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single + #we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single #\UFFFD - replacement char or \U2426 @@ -6647,7 +6647,7 @@ tcl::namespace::eval punk::ansi::ansistring { variable debug_visuals #modern (c0 seem to have more terminal/font support - C1 can show 8bit c1 codes - but also seems to be limited support) - + #Goal is not to map every control character? #Map of which elements we want to convert - done this way so we can see names of control's that are included: - ease of maintenance compared to just creating the tcl::string::map directly #ETX -ctrl-c @@ -6729,10 +6729,10 @@ tcl::namespace::eval punk::ansi::ansistring { #we'll hack in some stuff as needed - may override some of the visuals_c1 which is usually just empty/substitute glyphs #Being repurposed - these could potentially be confused with actual characters depending on the debugging context #To minimize potential confusion - we'll use a longer replacement sequence - which is not ideal from the perspective of terminal column layout debugging - #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator + #A single unique glyph would be better - although the bracketing for 8-bit codes is a useful visual indicator #(review - BOM should use different brackets to c1?) - #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. + #todo - regularly check if unicode has improved in this area - though with requests for c1 visuals dating back to at least 2011 - it's doubtful. #for 8-bit controls - we will standardize on a fixed width of 4 bracketing with: #\u2987 and \u2988 from Miscellaneous Mathematical Symbols-B (D or fractional-moon shaped brackets) #\u2987 - Z Notation Left Image Bracket @@ -6750,7 +6750,7 @@ tcl::namespace::eval punk::ansi::ansistring { #unicode Tags block brackets set obt \u2993 ;set cbt \u2994 - #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now + #this private range so rarely supported in fonts - and visuals are unknown, so we will make up some 2-letter codes for now #set visuals_c1 [tcl::dict::create\ # BPH [list \x82 "${ob8}\ue022 $cb8"]\ # NBH [list \x83 "${ob8}\ue023 $cb8"]\ @@ -6826,10 +6826,10 @@ tcl::namespace::eval punk::ansi::ansistring { set vis [format %c $asciidec] if {[dict exists $map_c0 $vis]} { set vis [dict get $map_c0 $vis] - } + } tcl::dict::set visuals_tags TAG$asciidec [list [format %c $i] "${obt}$vis${cbt}"] } - + set hack [tcl::dict::create] tcl::dict::set hack BOM1 [list \uFEFF "${obm}\U1f4a3$cbm"] ;#byte order mark/ ZWNBSP (ZWNBSP usage generally deprecated) - a picture of a bomb(2wide glyph) @@ -6840,13 +6840,13 @@ tcl::namespace::eval punk::ansi::ansistring { tcl::dict::set hack SOS [list \x98 "${ob8}\u2380 $cb8"] ;#Insertion Symbol from Miscellaneous Technical - 1 wide + pad tcl::dict::set hack ST [list \x9c "${ob8}\u2383 $cb8"] ;#Emphasis Symbol from Miscellaneous Technical - 1 wide + pad (graphically related to \u2380) tcl::dict::set hack CSI [list \x9b "${ob8}\u2386 $cb8"] ;#Enter Symbol from Miscellaneous Technical - 1 wide + pad - tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) + tcl::dict::set hack OSC [list \x9d "${ob8}\u2b55$cb8"] ;#bright red ring from Miscellaneous Symbols and Arrows - 2 wide (OSC could be used for clipboard or other potentially security sensitive functions) tcl::dict::set hack PM [list \x9e "${ob8}PM$cb8"] tcl::dict::set hack APC [list \x9f "${ob8}\U1f534$cb8"] ;#bright red ball from Miscellaneoust Symbols and Pictographs - 2 wide (APC also noted as a potential security risk) set debug_visuals [tcl::dict::merge $visuals_c0 $visuals_c1 $hack $visuals_tags] - #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient + #for repeated interaction with the same ANSI string - a mechanism to store state is more efficient proc NEW {string} { punk::ansi::class::class_ansistring new $string } @@ -6894,8 +6894,8 @@ tcl::namespace::eval punk::ansi::ansistring { # -lf 2, -vt 2 and -ff 2 are useful for CRM mode (Show Control Character Mode) in the terminal - where a newline is expected to display after the character. - set visuals_opt $debug_visuals - set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] + set visuals_opt $debug_visuals + set visuals_opt [dict remove $visuals_opt CR ESC LF VT FF HT BS SP] if {$opt_esc} { tcl::dict::set visuals_opt ESC [list \x1b \u241b] @@ -6949,7 +6949,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #The implementation of viewcodes,viewstyle is more efficiently done in an object for the case where repeated calls of various methods can re-use the internal splits. - #for oneshots here - there is only minor overhead to use and destroy the object here. + #for oneshots here - there is only minor overhead to use and destroy the object here. proc VIEWCODES {args} { set string [lindex $args end] if {$string eq ""} { @@ -6961,7 +6961,7 @@ tcl::namespace::eval punk::ansi::ansistring { $ansistr destroy return $result } - #an attempt to show the codes and colour/style of the *input* + #an attempt to show the codes and colour/style of the *input* #ie we aren't looking at the row/column positioning - but we do want to keep track of cursor attribute saves and restores proc VIEWSTYLE {args} { set string [lindex $args end] @@ -6993,16 +6993,16 @@ tcl::namespace::eval punk::ansi::ansistring { #stripping diacritics only makes sense if we are counting them as combiners and also treating unicode grapheme combinations as single entities. #as Our ansistring INDEX function returns the character with diacritics, and will ultimately return grapheme clusters as a single element - we strip theme here as not counted. #todo - combiners/diacritics? just map them away here? - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set string [regsub -all $re_diacritics $string ""] - #we want length to return number of glyphs.. not screen width. Has to be consistent with index function + #we want length to return number of glyphs.. not screen width. Has to be consistent with index function tcl::string::length [ansistrip $string] } #included as a test/verification - slightly slower. #grapheme split version may end up being used once it supports unicode grapheme clusters proc count2 {string} { - #we want count to return number of glyphs.. not screen width. Has to be consistent with index function + #we want count to return number of glyphs.. not screen width. Has to be consistent with index function return [llength [punk::char::grapheme_split [ansistrip $string]]] } @@ -7077,7 +7077,7 @@ tcl::namespace::eval punk::ansi::ansistring { } #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc - #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. + #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. proc trimleft {string args} { set intext 0 set out "" @@ -7103,19 +7103,19 @@ tcl::namespace::eval punk::ansi::ansistring { } proc trim {string} { #make sure we do our ansi-scanning split only once - so use list-based trim operations - #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length + #order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length #we save a single function call by calling both here rather than _splits_trim join [_splits_trimright [_splits_trimleft [split_codes $string]]] "" } - #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index + #Capitalised because it's the clustered grapheme/controlchar index - not the tcl string index proc INDEX {string index} { #*** !doctools #[call [fun index] [arg string] [arg index]] #[para]Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes) #[para]Returns the character (with applied ansi effect) at position index #[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output. - #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) + #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) #[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them. #[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards. #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index. @@ -7194,8 +7194,8 @@ tcl::namespace::eval punk::ansi::ansistring { } #any pt could be empty if using split_codes_single (or just first and last pt if split_codes) - set low -1 - set high -1 + set low -1 + set high -1 set pt_index -2 set pt_found -1 set char "" @@ -7209,8 +7209,8 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { set graphemes [punk::char::grapheme_split $pt] - set low [expr {$high + 1}] ;#last high - #incr high [tcl::string::length $pt] + set low [expr {$high + 1}] ;#last high + #incr high [tcl::string::length $pt] incr high [llength $graphemes] } @@ -7220,14 +7220,14 @@ tcl::namespace::eval punk::ansi::ansistring { set char [lindex $graphemes $index-$low] break } - + if {[punk::ansi::codetype::is_sgr_reset $code]} { - #we can throw away previous codestack + #we can throw away previous codestack set codestack [list] } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { set codestack [list $code] } else { - #may have partial resets + #may have partial resets #sgr_merge_list will handle at end #we don't apply non SGR codes to our output. This is probably what is wanted - but should be reviewed. #Review - consider if any other types of code make sense to retain in the output in this context. @@ -7244,8 +7244,8 @@ tcl::namespace::eval punk::ansi::ansistring { } } - #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi - #return empty string for each index that is out of range + #helper to convert indices (possibly of form x+y end-x etc) to numeric values within the payload range i.e without ansi + #return empty string for each index that is out of range #review - this is possibly too slow to be very useful as is. # consider converting to oo and maintaining state of ansisplits so we don't repeat relatively expensive operations for same string #see also punk::lindex_resolve / punk::lindex_get for ways to handle tcl list/string indices without parsing them. @@ -7326,11 +7326,11 @@ tcl::namespace::eval punk::ansi::ansistring { #we now have numeric or empty string indices - but haven't fully checked they are within the underlying payload length if {[join $testindices ""] eq ""} { - #don't calc ansistring length if no indices to check + #don't calc ansistring length if no indices to check return $testindices } if {$payload_len == -1} { - set payload_len [punk::ansi::ansistring::length $string] + set payload_len [punk::ansi::ansistring::length $string] } set indices [list] foreach ti $testindices { @@ -7356,7 +7356,7 @@ tcl::namespace::eval punk::ansi::ansistring { #single-width grapheme will return pair of integers of equal value #doulbe-width grapheme will return a pair of consecutive indices proc INDEXCOLUMNS {string idx} { - #There is an index per grapheme - whether it is 1 or 2 columns wide + #There is an index per grapheme - whether it is 1 or 2 columns wide set index [lindex [INDEXABSOLUTE $string $idx] 0] if {$index eq ""} { return "" @@ -7377,7 +7377,7 @@ tcl::namespace::eval punk::ansi::ansistring { foreach ptline $ptlines { set graphemes [punk::char::grapheme_split $ptline] if {$ptlineindex > 0} { - #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column + #todo - account for previous \n as a grapheme .. what column? It should theoretically be in the rightmost column #zero width set low [expr {$high + 1}] set lowc [expr {$highc + 1}] @@ -7393,7 +7393,7 @@ tcl::namespace::eval punk::ansi::ansistring { set lowc 0 set highc 0 } - set low [expr {$high + 1}] ;#last high + set low [expr {$high + 1}] ;#last high set lowc [expr {$highc + 1}] set high [expr {$low + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $ptline] -1}] @@ -7435,7 +7435,7 @@ tcl::namespace::eval punk::ansi::ansistring { if {$pt ne ""} { if {[tcl::string::last \n $pt] < 0} { set graphemes [punk::char::grapheme_split $pt] - set lowindex [expr {$highindex + 1}] ;#last high + set lowindex [expr {$highindex + 1}] ;#last high set lowc [expr {$highc + 1}] set highindex [expr {$lowindex + [llength $graphemes] -1}] set highc [expr {$lowc + [punk::char::ansifreestring_width $pt] -1}] @@ -7527,7 +7527,7 @@ namespace eval punk::ansi::colour { #https://sourceforge.net/p/irrational-numbers/code/HEAD/tree/pkgs/Colors/trunk/colors.tcl#l159 - # classic formula for luminance (0.0 .. 100.0) + # classic formula for luminance (0.0 .. 100.0) proc luminance {R G B} { return [expr {(0.3*$R + 0.59*$G + 0.11*$B)/255.0}] } @@ -7536,9 +7536,9 @@ namespace eval punk::ansi::colour { proc contrasting {R G B} { set lum [luminance $R $G $B] if {$lum < 0.597} { - set lum 0.9 + set lum 0.9 } else { - set lum 0.2 + set lum 0.2 } lassign [RGB2hsl $R $G $B] h s l return [hsl2RGB $h $s $lum] @@ -7569,11 +7569,11 @@ namespace eval punk::ansi::colour { } foreach c {R G B} { - if {$T($c) < [expr {1.0/6.0}]} { + if {$T($c) < (1.0/6.0)} { set T($c) [expr {$P+($Q-$P)*6.0*$T($c)}] } elseif {$T($c) < 0.5} { set T($c) $Q - } elseif {$T($c) < [expr {2.0/3.0}]} { + } elseif {$T($c) < (2.0/3.0)} { set T($c) [expr {$P+($Q-$P)*(2.0/3.0-$T($c))*6.0}] } else { set T($c) $P @@ -7585,7 +7585,7 @@ namespace eval punk::ansi::colour { } proc RGB2hsl { R G B } { set r [expr {$R/255.0}] - set g [expr {$G/255.0}] + set g [expr {$G/255.0}] set b [expr {$B/255.0}] set max $r @@ -7611,7 +7611,7 @@ namespace eval punk::ansi::colour { } set L [expr {($max+$min)/2}] - + if { $L == 0.0 || $max == $min } { set S 0.0 } elseif { $L <= 0.5 } { @@ -7651,7 +7651,7 @@ namespace eval punk::ansi::colour { set Bmax 1 } set L [expr {($min + $max) / 2.0}] - set H 0.0 + set H 0.0 set S 0.0 #REVIEW - java allows floating point division by 0.0 - producing positive infinity, negative infinity or NaN #This makes the original java algorithm a little more obscure @@ -7757,9 +7757,9 @@ tcl::namespace::eval punk::ansi::internal { } proc printing_length_addchar {i c} { - upvar outchars outc + upvar outchars outc upvar outsizes outs - set nxt [llength $outc] + set nxt [llength $outc] if {$i < $nxt} { lset outc $i $c } else { @@ -7801,10 +7801,10 @@ namespace eval ::punk::args::register { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::ansi [tcl::namespace::eval punk::ansi { variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm index 74a3ffc8..25b01d81 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args-0.1.0.tm @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::args 0 0.1.0] #[copyright "2024"] #[titledesc {args parsing}] [comment {-- Name section and table of contents description --}] -#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] +#[moddesc {args to nested dict of opts and values}] [comment {-- Description at end of page heading --}] #[require punk::args] #[keywords module proc args arguments parse] #[description] -#[para]Utilities for parsing proc args +#[para]Utilities for parsing proc args # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -53,8 +53,8 @@ # @cmd -help "do some stuff with files e.g dofilestuff " # @opts -type string # #comment lines ok -# -directory -default "" -# -translation -default binary +# -directory -default "" +# -translation -default binary # #setting -type none indicates a flag that doesn't take a value (solo flag) # -nocomplain -type none # @values -min 1 -max -1 @@ -62,26 +62,26 @@ # # puts "translation is [dict get $opts -translation]" # foreach f [dict values $values] { -# puts "doing stuff with file: $f" +# puts "doing stuff with file: $f" # } # } #}] #[para]The lines beginning with * are optional in most cases and can be used to set defaults and some extra controls -#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values +#[para] - the above example would work just fine with only the - lines, but would allow zero filenames to be supplied as no -min value is set for @values #[para]valid @ lines being with @cmd @leaders @opts @values -#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. +#[para]lines beginning with a dash define options - a name can optionally be given to each trailing positional argument. #[para]If no names are defined for positional arguments, they will end up in the values key of the dict with numerical keys starting at zero. #[para]e.g the result from the punk::args call above may be something like: #[para] opts {-translation binary -directory "" -nocomplain 0} values {0 file1.txt 1 file2.txt 2 file3.txt} -#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments +#[para]Here is an example that requires the number of values supplied to be exactly 2 and names the positional arguments #[para]It also demonstrates an inital argument 'category' that is outside of the scope for punk::args processing - allowing leading and trailing positional arguments #[example { # proc dofilestuff {category args} { # lassign [dict values [punk::args::get_dict { -# -directory -default "" -# -translation -default binary +# -directory -default "" +# -translation -default binary # -nocomplain -type none -# @values -min 2 -max 2 +# @values -min 2 -max 2 # fileA -type existingfile 1 # fileB -type existingfile 1 # } $args]] leaders opts values @@ -89,16 +89,16 @@ # puts "$category fileB: [dict get $values fileB]" # } #}] -#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 +#[para]By using standard tcl proc named arguments prior to args, and setting @values -min 0 -max 0 #[para]a Tk-style ordering can be acheived, where punk::args is only handling the trailing flags and the values element of the returned dict can be ignored -#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, +#[para]This use of leading positional arguments means the type validation features can't be applied to them. It can be done manually as usual, #[para] or an additional call could be made to punk::args e.g #[example { # punk::args::get_dict { -# category -choices {cat1 cat2 cat3} +# category -choices {cat1 cat2 cat3} # another_leading_arg -type boolean # } [list $category $another_leading_arg] -#}] +#}] #*** !doctools #[subsection Notes] @@ -111,8 +111,8 @@ # proc test_switch {args} { # set opts [dict create\\ # -return "object"\\ -# -frametype "heavy"\\ -# -show_edge 1\\ +# -frametype "heavy"\\ +# -show_edge 1\\ # -show_seps 0\\ # -x a\\ # -y b\\ @@ -173,12 +173,12 @@ #[enum]The tcllib set of TEPAM modules (pure tcl) #[para]TEPAM requires an alternative procedure declaration syntax instead of proc - but has support for Tk and documentation generation. #[list_end] -#[para] (* c implementation planned/proposed) +#[para] (* c implementation planned/proposed) #[para]punk::args was designed initially without specific reference to TEPAM - and to handle some edge cases in specific projects where TEPAM wasn't suitable. #[para]In subsequent revisions of punk::args - some features were made to operate in a way that is similar to TEPAM - to avoid gratuitous differences where possible, but of course there are differences #[para]and those used TEPAM or mixing TEPAM and punk::args should take care to assess the differences. #[para]TEPAM is a mature solution and is widely available as it is included in tcllib. -#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. +#[para]Serious consideration should be given to using TEPAM or one of the other packages, if suitable for your project. #[para]punk::args is relatively performant for a pure-tcl package solution - with the parsing of the argument specification block occuring only on the first run - after which a cached version of the spec is used. #[para]punk::args is not limited to procs. It can be used in apply or coroutine situations for example. @@ -188,7 +188,7 @@ #All ensemble commands are slower in a safe interp as they aren't compiled the same way -#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 +#https://core.tcl-lang.org/tcl/tktview/1095bf7f75 #as this is needed in safe interps too, and the long forms tcl::dict::for tcl::string::map are no slower in a normal interp - we use the long form here. #(As at 2024-06 There are many tcl8.6/8.7 interps in use which are affected by this and it's unknown when/whether it will be fixed) #ensembles: array binary clock dict info namespace string @@ -221,7 +221,7 @@ package require Tcl 8.6- tcl::namespace::eval punk::args::register { #*** !doctools #[subsection {Namespace punk::args}] - #[para] cooperative namespace punk::args::register + #[para] cooperative namespace punk::args::register #[para] punk::args aware packages may add their own namespace to the public list variable NAMESPACES before or after punk::args is loaded #[para] The punk::args package will then test for a public list variable ::PUNKARGS containing argument definitions when it needs to. #[list_begin definitions] @@ -257,15 +257,15 @@ tcl::namespace::eval punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::args { - + variable PUNKARGS ;#list of our own punk::args function argument definitions - loaded with punk::args::define at the end. - tcl::namespace::export {[a-z]*} + tcl::namespace::export {[a-z]*} variable rawdef_cache [tcl::dict::create] ;#key on rawdef list - return dict of {-id -dynamic 0|1} variable id_cache_rawdef [tcl::dict::create] variable id_cache_spec [tcl::dict::create] - variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) + variable argdefcache_unresolved [tcl::dict::create] ;#key = original template list supplied to 'define', value = 2-element list: (tstr-parsed split of template) & (unresolved params) variable argdata_cache [tcl::dict::create] @@ -273,7 +273,7 @@ tcl::namespace::eval punk::args { #*** !doctools #[subsection {Namespace punk::args}] - #[para] Core API functions for punk::args + #[para] Core API functions for punk::args #[list_begin definitions] #todo - some sort of punk::args::cherrypick operation to get spec from an existing set @@ -283,10 +283,10 @@ tcl::namespace::eval punk::args { #todo? -synonym/alias ? (applies to opts only not values) - #e.g -background -aliases {-bg} -default White - #review - how to make work with trie prefix + #e.g -background -aliases {-bg} -default White + #review - how to make work with trie prefix #e.g - # -corner -aliases {-corners} + # -corner -aliases {-corners} # -centre -aliases {-center -middle} #We mightn't want the prefix to be longer just because of an alias #we should get -co -ce and -m from the above as abbreviations @@ -301,10 +301,10 @@ tcl::namespace::eval punk::args { Returns a dictionary representing the argument specifications. The return result can generally be ignored, as the record is stored keyed on the - @id -id value from the supplied definition. + @id -id value from the supplied definition. This specifications dictionary is structured for (optional) use within commands to - parse and validate the arguments - and is also used when retrieving definitions - (or parts thereof) for re-use. + parse and validate the arguments - and is also used when retrieving definitions + (or parts thereof) for re-use. This can be used purely for documentation or called within a function to parse a mix of leading values, switches/flags and trailing values. @@ -325,7 +325,7 @@ tcl::namespace::eval punk::args { text if they are properly braced or double quoted and Tcl escaping for inner quotes or unbalanced braces is maintained. The line continuation character - (\\ at the end of the line) can be used to continue the set of arguments for + (\\ at the end of the line) can be used to continue the set of arguments for a leading word. Leading words beginning with the @ character are directives controlling argument parsing and help display. @@ -347,13 +347,13 @@ tcl::namespace::eval punk::args { -body (text to replace autogenerated arg info) %B%@doc%N% ?opt val...? options: -name -url - %B%@seealso%N% ?opt val...? + %B%@seealso%N% ?opt val...? options: -name -url (for footer - unimplemented) Some other options normally present on custom arguments are available - to use with the @leaders @opts @values directives to set defaults + to use with the @leaders @opts @values directives to set defaults for subsequent lines that represent your custom arguments. - These directives should occur in exactly this order - but can be + These directives should occur in exactly this order - but can be repeated with custom argument lines interspersed. An @id line can only appear once and should be the first item. @@ -365,17 +365,17 @@ tcl::namespace::eval punk::args { Custom arguments are defined by using any word at the start of a line that doesn't begin with @ or - - (except that adding an additionl @ escapes this restriction so + (except that adding an additionl @ escapes this restriction so that @@somearg becomes an argument named @somearg) custom leading args, switches/options (names starting with -) and trailing values also take options: - -type + -type defaults to string. If no other restrictions - are specified, choosing string does the least validation. + are specified, choosing string does the least validation. recognised types: - none + none (used for switches only. Indicates this is a 'solo' flag ie accepts no value) int|integer @@ -400,14 +400,14 @@ tcl::namespace::eval punk::args { -default -multiple (for leaders & values defines whether subsequent received values are stored agains the same - argument name - only applies to final leader or value) + argument name - only applies to final leader or value) (for options/flags this allows the opt-val pair or solo - flag to appear multiple times - no necessarily contiguously) + flag to appear multiple times - no necessarily contiguously) -choices {} A list of allowable values for an argument. The -default value doesn't have to be in the list. If a -type is specified - it doesn't apply to choice members. - It will only be used for validation if the -choicerestricted + It will only be used for validation if the -choicerestricted option is set to false. -choicerestricted Whether values not specified in -choices or -choicegroups are @@ -421,7 +421,7 @@ tcl::namespace::eval punk::args { These choices should match exactly a choice entry in one of the settings -choices or -choicegroups. These will still be used in prefix calculation - but the full - choice argument must be entered to select the choice. + choice argument must be entered to select the choice. -choicegroups {} Generally this would be used instead of -choices to allow usage display of choices grouped by some name. @@ -446,7 +446,7 @@ tcl::namespace::eval punk::args { " -dynamic -type boolean -default 0 -help\ - "If -dynamic is true, tstr interpolations of the form \$\{\$var\} + "If -dynamic is true, tstr interpolations of the form \$\{\$var\} are re-evaluated on each call. If the definition is being used not just as documentation, but is also used within the function to parse args, e.g using punk::args::get_by_id, @@ -463,7 +463,7 @@ tcl::namespace::eval punk::args { Using multiple text arguments may be useful to mix curly-braced and double-quoted strings to have finer control over interpolation when defining arguments. (this can also be handy for sections that pull resolved definition lines - from existing definitions (by id) for re-use of argument specifications and help text) + from existing definitions (by id) for re-use of argument specifications and help text) e.g the following definition passes 2 blocks as text arguments definition { @@ -486,7 +486,7 @@ tcl::namespace::eval punk::args { #Items that don't begin with * or - are value definitions v1 -type integer -default 0 thinglist -type string -multiple 1 - } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" + } \"*doc -name Manpage: -url \[myfunc_manpage_geturl myns::myfunc]\" " }]] @@ -519,7 +519,7 @@ tcl::namespace::eval punk::args { -multiple 0\ -regexprepass {}\ -validationtransform {}\ - ] + ] set valspec_defaults [tcl::dict::create\ -type string\ -optional 0\ @@ -618,7 +618,7 @@ tcl::namespace::eval punk::args { variable argdefcache_unresolved - set cache_key $args + set cache_key $args #ideally we would use a fast hash algorithm to produce a short key with low collision probability. #something like md5 would be ok (this is non cryptographic) - but md5 uses open and isn't usable by default in a safe interp. (sha1 often faster on modern cpus) #review - check if there is a built-into-tcl way to do this quickly @@ -668,8 +668,8 @@ tcl::namespace::eval punk::args { foreach a $textargs { lappend normargs [tcl::string::map {\r\n \n} $a] } - set optionspecs [join $normargs \n] - #REVIEW - join also serves to unescape things such as \$\{$x\} \$\{[cmd]\} without subst'ing or evaling (?) + set optionspecs [join $normargs \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 @@ -692,7 +692,7 @@ tcl::namespace::eval punk::args { #we need -choiceprefix and -choicerestricted defaults even though they often don't apply so we can look them up to display in Help if there are -choices #default to 1 for convenience - #checks with no default + #checks with no default #-minsize -maxsize -range @@ -729,13 +729,13 @@ tcl::namespace::eval punk::args { #ansi colours can stop info complete from working (contain square brackets) #review - when exactly are ansi codes allowed/expected in record lines. # - we might reasonably expect them in default values or choices or help strings - # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. - # - eg set line "set x \"a[a+ red]red[a]\"" + # - square brackets in ansi aren't and can't be escaped if they're to work as literals in the data. + # - eg set line "set x \"a[a+ red]red[a]\"" # - 'info complete' will report 0, and subst would require -nocommand option or it will complain of missing close-bracket if {$has_punkansi} { set test_complete [punk::ansi::ansistrip $recordsofar] } else { - #review + #review #we only need to strip enough to stop interference with 'info complete' set test_complete [string map [list \x1b\[ ""] $recordsofar] } @@ -743,7 +743,7 @@ tcl::namespace::eval punk::args { #append linebuild [string trimleft $rawline] \n if {$in_record} { #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left - #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. + #this allows alignment of multiline help strings to left margin whilst maintaining a visual indent in source form. #Aligning subsequent lines with the record, or aligning 4 spaces in are equivalent. #ie to indent lines further - whitespace should be added 4+ columns in from the record-line start position. #(this leaves an oddity if indenting is only 1 2 or 3 spaces mixed with longer indents as we don't check for it.. REVIEW) @@ -761,7 +761,7 @@ tcl::namespace::eval punk::args { set in_record 1 regexp {(\s*).*} $rawline _all lastindent #puts "indent: [ansistring VIEW -lf 1 $lastindent]" - #puts "indent from rawline:$rawline " + #puts "indent from rawline:$rawline " append linebuild $rawline \n } } else { @@ -769,14 +769,14 @@ tcl::namespace::eval punk::args { #trim only the whitespace corresponding to last record indent or lastindent + 4 spaces - not all whitespace on left if {[tcl::string::first "$lastindent " $rawline] == 0} { set trimmedline [tcl::string::range $rawline [tcl::string::length "$lastindent "] end] - append linebuild $trimmedline + append linebuild $trimmedline } elseif {[tcl::string::first $lastindent $rawline] == 0} { set trimmedline [tcl::string::range $rawline [tcl::string::length $lastindent] end] - append linebuild $trimmedline + append linebuild $trimmedline } else { append linebuild $rawline } - lappend records $linebuild + lappend records $linebuild set linebuild "" } } @@ -793,7 +793,7 @@ tcl::namespace::eval punk::args { #(common case of no leaders specified) set opt_any 0 set val_min 0 - set val_max -1 ;#-1 for no limit + set val_max -1 ;#-1 for no limit set DEF_definition_id $id #form_defs @@ -805,14 +805,14 @@ tcl::namespace::eval punk::args { set refs [dict create] set record_type "" - set record_number -1 ;# + set record_number -1 ;# foreach rec $records { set trimrec [tcl::string::trim $rec] switch -- [tcl::string::index $trimrec 0] { "" - # {continue} } incr record_number - set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict + set record_values [lassign $trimrec firstword] ;#after first word, the remaining list elements up to the first newline that isn't inside a value, form a dict if {[llength $record_values] % 2 != 0} { #todo - avoid raising an error - store invalid defs keyed on id error "punk::args::define - bad optionspecs line for record '$firstword' Remaining items on line must be in paired option-value format - received '$record_values' id:$DEF_definition_id" @@ -853,19 +853,19 @@ tcl::namespace::eval punk::args { set F [dict create [lindex $record_form_ids 0] [dict get $F _default]] #assert - _default must be only entry in form_ids_active - since there's only 1 record in $F #we are only setting active because of the rename - @form is the way to change active forms list - set form_ids_active [lindex $record_form_ids 0] + set form_ids_active [lindex $record_form_ids 0] } } foreach fid $record_form_ids { if {![dict exists $F $fid]} { if {$firstword eq "@form"} { - #only @form directly supplies keys + #only @form directly supplies keys dict set F $fid [dict merge [New_command_form $fid] [dict remove $record_values -form]] } else { dict set F $fid [New_command_form $fid] } } else { - #update form with current record opts, except -form + #update form with current record opts, except -form if {$firstword eq "@form"} { dict set F $fid [dict merge [dict get $F $fid] [dict remove $record_values -form]] } } } @@ -912,7 +912,7 @@ tcl::namespace::eval punk::args { #global reference dict - independent of forms #ignore refs without an -id #store all keys except -id - #complete overwrite if refid repeated later on + #complete overwrite if refid repeated later on if {[dict exists $at_specs -id]} { dict set refs [dict get $at_specs -id] [dict remove $at_specs -id] } @@ -938,7 +938,7 @@ tcl::namespace::eval punk::args { set doc_info [dict get $copyfrom doc_info] } foreach fid $record_form_ids { - #only use elements with matching form id? + #only use elements with matching form id? #probably this feature mainly useful for _default anyway so that should be ok #cooperative doc sets specified in same file could share via known form ids too #todo argdisplay_info by fid @@ -964,7 +964,7 @@ tcl::namespace::eval punk::args { # {4 anykeys {3 by}} # {5 anykeys {1 .. 1 to 3 by}} # }\ - # -fallback 1 + # -fallback 1 # ... # @parser -synopsis "start 'count' count ??'by'? step?"\ # -arities { @@ -976,7 +976,7 @@ tcl::namespace::eval punk::args { # 1 # {3 anykeys {1 by}} # } - # + # # see also after manual # @form -arities {1} # @form -arities { @@ -990,9 +990,9 @@ tcl::namespace::eval punk::args { if {[dict exists $at_specs -form]} { set idlist [dict get $at_specs -form] if {$idlist eq "*"} { - #* only applies to form ids that exist at the time + #* only applies to form ids that exist at the time set idlist [dict keys $F] - } + } set form_ids_active $idlist } #new form keys already created if they were needed (done for all records that have -form ) @@ -1001,7 +1001,7 @@ tcl::namespace::eval punk::args { set package_info [dict merge $package_info $at_specs] } cmd { - #allow arbitrary - review + #allow arbitrary - review set cmd_info [dict merge $cmd_info $at_specs] } doc { @@ -1009,7 +1009,7 @@ tcl::namespace::eval punk::args { } argdisplay { #override the displayed argument table. - #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing + #The opts,values etc are still parsed and used if they exist and if the definition is actually used in parsing set argdisplay_info [dict merge $argdisplay_info $at_specs] } opts { @@ -1063,8 +1063,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1154,8 +1154,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1246,8 +1246,8 @@ tcl::namespace::eval punk::args { -allow_ansi - -validate_ansistripped - -strip_ansi - - -regexprepass - - -regexprefail - + -regexprepass - + -regexprefail - -regexprefailmsg - -validationtransform - -multiple { @@ -1315,12 +1315,12 @@ tcl::namespace::eval punk::args { foreach fid $record_form_ids { if {[dict get $F $fid argspace] eq "leaders"} { set record_type leader - tcl::dict::set argdef_values -ARGTYPE leader + tcl::dict::set argdef_values -ARGTYPE leader #lappend leader_names $argname set temp_leadernames [tcl::dict::get $F $fid LEADER_NAMES] if {$argname ni $temp_leadernames} { lappend temp_leadernames $argname - tcl::dict::set F $fid LEADER_NAMES $temp_leadernames + tcl::dict::set F $fid LEADER_NAMES $temp_leadernames } else { error "punk::args::define - arg $argname already present as leader in '$rec' (command form:'$fid') @id:$DEF_definition_id" } @@ -1330,7 +1330,7 @@ tcl::namespace::eval punk::args { } } else { set record_type value - tcl::dict::set argdef_values -ARGTYPE value + tcl::dict::set argdef_values -ARGTYPE value set temp_valnames [tcl::dict::get $F $fid VAL_NAMES] lappend temp_valnames $argname tcl::dict::set F $fid VAL_NAMES $temp_valnames @@ -1370,7 +1370,7 @@ tcl::namespace::eval punk::args { tcl::dict::set spec_merged -type int } bool - boolean { - tcl::dict::set spec_merged -type bool + tcl::dict::set spec_merged -type bool } char - character { tcl::dict::set spec_merged -type char @@ -1386,7 +1386,7 @@ tcl::namespace::eval punk::args { } lappend opt_solos $argname } else { - #-solo only valid for flags + #-solo only valid for flags error "punk::args::define - invalid -type 'none' for positional argument positional argument '$argname' @id:$DEF_definition_id" } } @@ -1444,7 +1444,7 @@ tcl::namespace::eval punk::args { set spec_merged [tcl::dict::merge $spec_merged [dict get $refs $specval]] ;#everything in @ref line except the -id } else { if {[tcl::dict::exists $refs $specval $targetswitch]} { - tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] + tcl::dict::set spec_merged $targetswitch [tcl::dict::get $refs $specval $targetswitch] } else { puts stderr "punk::args::define argument '$argname' attempt to reference non-existing subelement $targetswitch in @ref -id $specval (with $spec)" } @@ -1464,10 +1464,10 @@ tcl::namespace::eval punk::args { if {$is_opt} { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } else { tcl::dict::set F $fid ARG_CHECKS $argname\ - [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + [tcl::dict::remove $spec_merged -form -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } tcl::dict::set F $fid ARG_INFO $argname $spec_merged #review existence of -default overriding -optional @@ -1496,7 +1496,7 @@ tcl::namespace::eval punk::args { } } } - } ;# end foreach fid record_form_ids + } ;# end foreach fid record_form_ids } ;# end foreach rec $records @@ -1527,9 +1527,9 @@ tcl::namespace::eval punk::args { #todo - do some checks for obvious bad definitions involving a mix of @leaders and @values (e.g with optional options) - dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize - dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid LEADER_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata leaderspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid OPT_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata optspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize + dict set F $fid VAL_CHECKS_DEFAULTS [tcl::dict::remove [dict get $formdata valspec_defaults] -type -default -multiple -strip_ansi -validate_ansistripped -allow_ansi] ;#leave things like -range -minsize } @@ -1547,17 +1547,17 @@ tcl::namespace::eval punk::args { #for arguments taking opts - total_arity generally unlimited (usually repeats allowed - they just override if not -multiple) - #in the above case we have no unique total_arity + #in the above case we have no unique total_arity #we would also want to consider values when selecting - #e.g given the invalid command "after cancel" + #e.g given the invalid command "after cancel" # we should be selecting forms 3 & 4 rather than the exact arity match given by 1. - + set firstformid [lindex $F 0] ;#temporarily treat first form as special - as we can initially only parse single-form commands - #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use + #todo - for now: add -form flag to parse (get_dict etc) and require calling func to decide which form(s) to use #even if we do eventually get automated multi-form parsing - it is useful to be able to restrict via -form flag, the parsing and doc generation to a specific form - #e.g commandline completion could show list of synopsis entries to select from + #e.g commandline completion could show list of synopsis entries to select from set form_info [dict create] dict for {fid fdict} $F { @@ -1619,7 +1619,7 @@ tcl::namespace::eval punk::args { #return raw definition list as created with 'define' # - possibly with unresolved dynamic parts proc raw_def {id} { - variable id_cache_rawdef + variable id_cache_rawdef set realid [real_id $id] if {![dict exists $id_cache_rawdef $realid]} { return "" @@ -1632,8 +1632,8 @@ tcl::namespace::eval punk::args { variable resolved_def_TYPE_CHOICES {* @id @package @cmd @ref @doc @argdisplay @seealso @leaders @opts @values leaders opts values} variable resolved_def_TYPE_CHOICEGROUPS { directives {@id @package @cmd @ref @doc @argdisplay @seealso} - argumenttypes {leaders opts values} - remaining_defaults {@leaders @opts @values} + argumenttypes {leaders opts values} + remaining_defaults {@leaders @opts @values} } lappend PUNKARGS [list [string map [list %TYPECHOICES% $resolved_def_TYPE_CHOICES %TYPECHOICEGROUPS% $resolved_def_TYPE_CHOICEGROUPS] { @@ -1643,35 +1643,35 @@ tcl::namespace::eval punk::args { uses the 'spec' form to build a response in definition format. Pulling argument definition data from another function is a form - of tight coupling to the other function that should be done with + of tight coupling to the other function that should be done with care. Note that the directives @leaders @opts @values may appear multiple times in a source definition - applying defaults for arguments that - follow. When retrieving these - there is only a single result for + follow. When retrieving these - there is only a single result for each that represents the defaults after all have been applied. - When retrieving -types * each of these will be positioned before + When retrieving -types * each of these will be positioned before the arguments of that type - but this doesn't mean there was a single leading directive for this argument type in the source definition. Each argument has already had its complete specification recorded in its own result. - + When manually specifying -types, the order @leaders then @opts then @values must be maintained - but if they are placed before their corresponding arguments, they will not affect the retrieved arguments as these arguments are already fully spec'd. The defaults from the source can be removed by adding @leaders, @opts @values to the -antiglobs list, but again - this won't affect the existing arguments. - Each argument can have members of its spec overridden using the + Each argument can have members of its spec overridden using the -override dictionary. " @leaders -min 0 -max 0 @opts -form -default 0 -help\ - "Ordinal index or name of command form" + "Ordinal index or name of command form" #no restriction on number of types/repetitions? - -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} + -types -default * -choices {%TYPECHOICES%} -choicegroups {%TYPECHOICEGROUPS%} -choiceprefix 0 -choicemultiple {0 -1} -antiglobs -default {} -type list -help\ "Glob patterns for directive or argument/flags to be suppressed" @@ -1687,7 +1687,7 @@ tcl::namespace::eval punk::args { path for a command name" pattern -type string -optional 1 -default * -multiple 1 -help\ "glob-style patterns for retrieving value or switch - definitions. + definitions. If -type is * and pattern is * the entire definition including directive lines will be returned in line form. @@ -1698,8 +1698,8 @@ tcl::namespace::eval punk::args { will be returned. if -type is another directive such as @id, @doc etc the - patterns are ignored. - + patterns are ignored. + " }]] } @@ -1718,7 +1718,7 @@ tcl::namespace::eval punk::args { return } set patterns [list] - + #a definition id must not begin with "-" ??? review for {set i 0} {$i < [llength $args]} {incr i} { set a [lindex $args $i] @@ -1730,7 +1730,7 @@ tcl::namespace::eval punk::args { dict set opts $a [lindex $args $i] } else { set id [lindex $args $i] - set patterns [lrange $args $i+1 end] + set patterns [lrange $args $i+1 end] break } if {$i == [llength $args]-1} { @@ -1781,7 +1781,7 @@ tcl::namespace::eval punk::args { #set arg_info [dict get $specdict ARG_INFO] set arg_info [dict get $specdict FORMS $formname ARG_INFO] set argtypes [dict create leaders leader opts option values value] - + set opt_antiglobs [dict get $opts -antiglobs] set directives [lsearch -all -inline -exact -not $::punk::args::argdoc::resolved_def_TYPE_CHOICES *] set suppressed_directives [list] @@ -1822,7 +1822,7 @@ tcl::namespace::eval punk::args { } } foreach directive {@package @cmd @doc @seealso @argdisplay} { - set dshort [string range $directive 1 end] + set dshort [string range $directive 1 end] if {"$directive" in $included_directives} { if {[dict exists $opt_override $directive]} { append result \n "$directive [dict merge [dict get $specdict ${dshort}_info] [dict get $opt_override $directive]]" @@ -1832,8 +1832,8 @@ tcl::namespace::eval punk::args { } } #output ordered by leader, option, value - foreach pseudodirective {leaders opts values} tp {leader option value} { - set directive "@$pseudodirective" + foreach pseudodirective {leaders opts values} tp {leader option value} { + set directive "@$pseudodirective" switch -- $directive { @leaders {set defaults_key leaderspec_defaults} @opts {set defaults_key optspec_defaults} @@ -1925,7 +1925,7 @@ tcl::namespace::eval punk::args { } proc resolved_def_values {id {patternlist *}} { - variable id_cache_rawdef + variable id_cache_rawdef set realid [real_id $id] if {$realid ne ""} { set speclist [tcl::dict::get $id_cache_rawdef $realid] @@ -1971,7 +1971,7 @@ tcl::namespace::eval punk::args { set deflist [raw_def $id] if {[dict exists $rawdef_cache $deflist -dynamic]} { return [dict get $rawdef_cache $deflist -dynamic] - } + } return [rawdef_is_dynamic $deflist] #@dynamic only has meaning as 1st element of a def in the deflist } @@ -2042,7 +2042,7 @@ tcl::namespace::eval punk::args { if {[tcl::dict::exists $aliases $id]} { return 1 } - variable id_cache_rawdef + variable id_cache_rawdef tcl::dict::exists $id_cache_rawdef $id } proc set_alias {alias id} { @@ -2061,7 +2061,7 @@ tcl::namespace::eval punk::args { } proc real_id {id} { - variable id_cache_rawdef + variable id_cache_rawdef variable aliases if {[tcl::dict::exists $aliases $id]} { set id [tcl::dict::get $aliases $id] @@ -2126,7 +2126,7 @@ tcl::namespace::eval punk::args { } append result "[format %-${widest}s $ns] [format %${width_c2}s $ids] [format %${width_c3}s $scan_us] [format %${width_c4}s $ldefs] [format %${width_c5}s $load_us]" \n } - append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" + append result "\nPackages - Registered: [llength $registered] Loaded: $count_loaded Unloaded: $count_unloaded" return $result } @@ -2136,7 +2136,7 @@ tcl::namespace::eval punk::args { if {[set gposn [lsearch $nslist {}]] >= 0} { lset nslist $gposn :: } - upvar ::punk::args::register::NAMESPACES registered ;#list + upvar ::punk::args::register::NAMESPACES registered ;#list upvar ::punk::args::register::loaded_packages loaded_packages ;#list upvar ::punk::args::register::loaded_info loaded_info ;#dict upvar ::punk::args::register::scanned_packages scanned_packages ;#list @@ -2149,7 +2149,7 @@ tcl::namespace::eval punk::args { #e.g - gets called for each subcommand of an ensemble (could be many) # It needs to get called in each arginfo call as we don't know what namespace origins or aliases may be involved in resolving a command. #we could possibly get away with not calling it for nested calls (such as with ensemble subcommands) but the code to avoid calls is probably more complex/slow than any gain avoiding the fast-path below. - # -- --- --- --- --- --- + # -- --- --- --- --- --- # common-case fast-path if {[llength $loaded_packages] == [llength $registered]} { @@ -2157,7 +2157,7 @@ tcl::namespace::eval punk::args { #assert - if all are registered - then all have been scanned ( return {} } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set unscanned [punklib_ldiff $registered $scanned_packages] if {[llength $unscanned]} { @@ -2191,7 +2191,7 @@ tcl::namespace::eval punk::args { dict lappend namespace_docpackages $documentedns $pkgns } lappend seen_documentedns $documentedns - } + } } } set ts_end [clock microseconds] @@ -2218,7 +2218,7 @@ tcl::namespace::eval punk::args { set docns ${pkgns}::argdoc if {[namespace exists $docns]} { if {($pkgns in $registered || $docns in $registered) && $docns ni $needed && $docns ni $loaded_packages} { - lappend needed $docns + lappend needed $docns } } if {[dict exists $namespace_docpackages $pkgns]} { @@ -2247,7 +2247,7 @@ tcl::namespace::eval punk::args { set epath [namespace path] set pkgns [namespace parent] if {$pkgns ni $epath} { - namespace path [list {*}$epath $pkgns] ;#add to tail + namespace path [list {*}$epath $pkgns] ;#add to tail } } @@ -2259,7 +2259,7 @@ tcl::namespace::eval punk::args { namespace eval $evalns [list punk::args::define {*}$definitionlist] incr def_count } - } + } #process list of 2-element lists if {[info exists ${pkgns}::PUNKARGS_aliases]} { @@ -2322,7 +2322,7 @@ tcl::namespace::eval punk::args { # -------------------------------------- - #test of Get_caller + #test of Get_caller lappend PUNKARGS [list { @id -id ::punk::args::test1 @values -min 0 -max 0 @@ -2357,16 +2357,16 @@ tcl::namespace::eval punk::args { @cmd -name punk::args::arg_error -help\ "Generates a table (by default) of usage information for a command. A trie system is used to create highlighted prefixes for command - switches and for subcommands or argument/switch values that accept + switches and for subcommands or argument/switch values that accept a defined set of choices. These prefixes match the mechanism used to validate arguments (based on tcl::prefix::match). - This function is called during the argument parsing process + This function is called during the argument parsing process (if the definition is not only being used for documentation) It is also called by punk::args::usage which is in turn called by the punk::ns introspection facilities which creates on the fly definitions for some commands such as ensembles and - oo objects where a manually defined one isn't present. + oo objects where a manually defined one isn't present. " @leaders -min 2 -max 2 msg -type string -help\ @@ -2399,21 +2399,21 @@ tcl::namespace::eval punk::args { proc arg_error {msg spec_dict args} { #todo - test a configurable flag (in the CALLER) for whether to do a faster return on the unhappy path. #accept an option here so that we can still use full output for usage requests. - #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args + #This may be desired for codebases where tests based on 'catch' are used on procs that parse with punk::args #Development/experimentation may be done with full table-based error reporting - but for production release it - #may be desirable to reduce overhead on catches. + #may be desirable to reduce overhead on catches. #consider per-namespace or namespace-tree configurability. #In general - errors raised by this mechanism represent programming errors (or data sanity issues) rather than underlying errors due - #to resource availability etc - so the slower error generation time may not always be a problem. + #to resource availability etc - so the slower error generation time may not always be a problem. #Contrary to that reasoning - validation options such as 'existingfile' are the sort of thing that might bubble up to a catch in calling #code which has no use for the enhanced error info. #The use of punk::args for arg parsing/validation is probably best suited for code close to an interactive user. - #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system + #consider also (erlang/elixer style?) message passing - to quickly hand off enhanced errors to another thread/system #todo #investigate options - e.g we return our errorcode {TCL WRONGARGS PUNK} quickly - and process the enhanced error - #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) + #asynchronously for later retrieval. (subcodes? e.g usage vs parameter validation fail) - #todo - document unnamed leaders and unnamed values where -min and/or -max specified + #todo - document unnamed leaders and unnamed values where -min and/or -max specified #e.g punk::args::get_dict {@leaders -min 1 -max 1} -x {@values -min 1 -max 2} {} #only |?-x?|string|... is shown in the output table. #should be something like: @@ -2435,7 +2435,7 @@ tcl::namespace::eval punk::args { namespace import ::punk::ansi::a ::punk::ansi::a+ } } - #limit colours to standard 16 so that themes can apply to help output + #limit colours to standard 16 so that themes can apply to help output variable arg_error_isrunning if {$arg_error_isrunning} { error "arg_error already running - error in arg_error?\n triggering errmsg: $msg" @@ -2448,7 +2448,7 @@ tcl::namespace::eval punk::args { set arg_error_isrunning 1 set badarg "" - set returntype table ;#table as string + set returntype table ;#table as string set as_error 1 ;#usual case is to raise an error set scheme error dict for {k v} $args { @@ -2487,14 +2487,14 @@ tcl::namespace::eval punk::args { } info - error {} default { - set scheme na + set scheme na } } #hack some basics for now. #for coloured schemes - use bold as well as brightcolour in case colour off. array set CLR {} set CLR(errormsg) [a+ brightred] - set CLR(title) "" + set CLR(title) "" set CLR(check) [a+ brightgreen] set CLR(solo) [a+ brightcyan] set CLR(choiceprefix) [a+ underline] @@ -2503,20 +2503,20 @@ tcl::namespace::eval punk::args { set CLR(cmdname) [a+ brightwhite] set CLR(groupname) [a+ bold] set CLR(ansiborder) [a+ bold] - set CLR(ansibase_header) [a+ bold] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ bold] + set CLR(ansibase_body) [a+ white] switch -- $scheme { nocolour { set CLR(errormsg) [a+ bold] - set CLR(title) [a+ bold] + set CLR(title) [a+ bold] set CLR(check) "" set CLR(solo) "" set CLR(badarg) [a+ reverse] ;#? experiment - set CLR(cmdname) [a+ bold] + set CLR(cmdname) [a+ bold] set CLR(linebase_header) "" set CLR(linebase) "" - set CLR(ansibase_body) "" + set CLR(ansibase_body) "" } info { set CLR(errormsg) [a+ brightred bold] @@ -2525,8 +2525,8 @@ tcl::namespace::eval punk::args { set CLR(choiceprefix) [a+ brightgreen bold] set CLR(groupname) [a+ cyan bold] set CLR(ansiborder) [a+ brightcyan bold] - set CLR(ansibase_header) [a+ cyan] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ cyan] + set CLR(ansibase_body) [a+ white] } error { set CLR(errormsg) [a+ brightred bold] @@ -2535,8 +2535,8 @@ tcl::namespace::eval punk::args { set CLR(choiceprefix) [a+ brightgreen bold] set CLR(groupname) [a+ cyan bold] set CLR(ansiborder) [a+ brightyellow bold] - set CLR(ansibase_header) [a+ yellow] - set CLR(ansibase_body) [a+ white] + set CLR(ansibase_header) [a+ yellow] + set CLR(ansibase_body) [a+ white] } na { } @@ -2547,7 +2547,7 @@ tcl::namespace::eval punk::args { set RST "\x1b\[m" set t "" ;#possible oo table object - may be tested for objectiness at the end so needs to exist. - #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error + #REVIEW - risk of accidental indefinite recursion if functions used here also use punk::args::get_dict and there is an argument error #e.g list_as_table # use basic colours here to support terminals without extended colours @@ -2629,8 +2629,8 @@ tcl::namespace::eval punk::args { } if {$use_table} { set t [textblock::class::table new "$CLR(title)Usage$RST"] - $t add_column -headers $blank_header_col -minwidth 3 - $t add_column -headers $blank_header_col + $t add_column -headers $blank_header_col -minwidth 3 + $t add_column -headers $blank_header_col if {!$is_custom_argdisplay} { lappend blank_header_col "" @@ -2708,9 +2708,9 @@ tcl::namespace::eval punk::args { $t add_row [list "" $argdisplay_body] } else { if {$argdisplay_header ne ""} { - lappend errlines $argdisplay_header + lappend errlines $argdisplay_header } - lappend errlines {*}$argdisplay_body + lappend errlines {*}$argdisplay_body } } else { @@ -2719,18 +2719,18 @@ tcl::namespace::eval punk::args { set A_BADARG $CLR(badarg) set greencheck $CLR(check)\u2713$RST ;#green tick set soloflag $CLR(solo)\u2690$RST ;#flag - may be replacement char in old dos prompt (?) - set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply + set A_PREFIX $CLR(choiceprefix) ;#use a+ so colour off can apply if {$A_PREFIX eq "" || $A_PREFIX eq [a+ underline]} { #A_PREFIX can resolve to empty string if colour off #we then want to display underline instead set A_PREFIX [a+ underline] - set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space + set A_PREFIXEND [a+ nounderline]\u200B ;#padding will take ANSI from last char - so add a zero width space } else { - set A_PREFIXEND $RST + set A_PREFIXEND $RST } set opt_names [list] - set opt_names_display [list] + set opt_names_display [list] if {[llength [dict get $spec_dict OPT_NAMES]]} { if {![catch {package require punk::trie}]} { set trie [punk::trie::trieclass new {*}[dict get $spec_dict OPT_NAMES]] @@ -2752,14 +2752,14 @@ tcl::namespace::eval punk::args { lappend opt_names_display $A_PREFIX$prefix$A_PREFIXEND$tail #lappend opt_names_display $M[ansistring VIEW $prefix]$RST[ansistring VIEW $tail] lappend opt_names $c - } + } } else { set opt_names [dict get $spec_dict OPT_NAMES] - set opt_names_display $opt_names + set opt_names_display $opt_names } } set leading_val_names [dict get $spec_dict LEADER_NAMES] - set trailing_val_names [dict get $spec_dict VAL_NAMES] + set trailing_val_names [dict get $spec_dict VAL_NAMES] #dict for {argname info} [tcl::dict::get $spec_dict arg_info] { # if {![string match -* $argname]} { @@ -2773,8 +2773,8 @@ tcl::namespace::eval punk::args { # set trailing_val_names $leading_val_names # set leading_val_names {} #} - set leading_val_names_display $leading_val_names - set trailing_val_names_display $trailing_val_names + set leading_val_names_display $leading_val_names + set trailing_val_names_display $trailing_val_names #display options first then values foreach argumentset [list [list $leading_val_names_display $leading_val_names] [list $opt_names_display $opt_names] [list $trailing_val_names_display $trailing_val_names]] { @@ -2788,7 +2788,7 @@ tcl::namespace::eval punk::args { set default "" } set help [Dict_getdef $arginfo -help ""] - set allchoices_originalcase [list] + set allchoices_originalcase [list] set choices [Dict_getdef $arginfo -choices {}] set choicegroups [Dict_getdef $arginfo -choicegroups {}] set choicemultiple [dict get $arginfo -choicemultiple] @@ -2799,7 +2799,7 @@ tcl::namespace::eval punk::args { set choicecolumns [Dict_getdef $arginfo -choicecolumns 4] set choiceprefixdenylist [Dict_getdef $arginfo -choiceprefixdenylist {}] if {[Dict_getdef $arginfo -multiple 0]} { - set multiple $greencheck + set multiple $greencheck set is_multiple 1 } else { set multiple "" @@ -2865,11 +2865,11 @@ tcl::namespace::eval punk::args { set idents [dict get [$trie shortest_idents ""] scanned] if {[dict get $arginfo -nocase]} { #idents were calculated on lcase - remap keys in idents to original casing - set actual_idents $idents + set actual_idents $idents foreach ch $allchoices_originalcase { if {![dict exists $idents $ch]} { #don't need to adjust the capitalisation in the value to match the key -as only length is used for highlighting - #The actual testing is done in get_dict + #The actual testing is done in get_dict dict set actual_idents $ch [dict get $idents [string tolower $ch]] } } @@ -2899,12 +2899,12 @@ tcl::namespace::eval punk::args { append cdisplay \n [dict get $choicelabeldict $c] } dict lappend formattedchoices $groupname $cdisplay - } + } } } errM]} { #this failure can happen if -nocase is true and there are ambiguous entries #e.g -nocase 1 -choices {x X} - puts stderr "prefix marking failed\n$errM" + puts stderr "prefix marking failed\n$errM" #append help "\n " [join [dict get $arginfo -choices] "\n "] if {[dict size $choicelabeldict]} { dict for {groupname clist} $choicegroups { @@ -2917,9 +2917,9 @@ tcl::namespace::eval punk::args { } } } else { - set formattedchoices $choicegroups + set formattedchoices $choicegroups } - + } } set choicetable_objects [list] @@ -2932,7 +2932,7 @@ tcl::namespace::eval punk::args { } if {$numcols > 0} { if {$use_table} { - #risk of recursing + #risk of recursing #TODO -title directly in list_as_table set choicetableobj [textblock::list_as_table -return tableobject -show_hseps 1 -show_edge 1 -columns $numcols $formatted] lappend choicetable_objects $choicetableobj @@ -3053,7 +3053,7 @@ tcl::namespace::eval punk::args { -ansibase_body $CLR(ansibase_body)\ -ansibase_header $CLR(ansibase_header)\ -ansiborder_header $CLR(ansiborder)\ - -ansiborder_body $CLR(ansiborder) + -ansiborder_body $CLR(ansiborder) $t configure -maxwidth 80 ;#review if {$returntype ne "tableobject"} { @@ -3073,7 +3073,7 @@ tcl::namespace::eval punk::args { } set arg_error_isrunning 0 - #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. + #add PUNK to the tail end of the more usual -errorcode {TCL WRONGARGS} so we maintain reasonable compat with things looking for TCL WRONGARGS - but also differentiate it. #Also, we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) if {$use_table} { #assert returntype is one of table, tableobject @@ -3081,7 +3081,7 @@ tcl::namespace::eval punk::args { if {$returntype eq "tableobject"} { if {[info object isa object $t]} { set result $t - } + } } } else { set result $errmsg @@ -3109,8 +3109,8 @@ tcl::namespace::eval punk::args { IDs for autogenenerated help are prefixed e.g (autodef)::myensemble. Generally punk::ns::arginfo (aliased as i in the punk shell) should - be used in preference - as it will search for a documentation - mechanism and call punk::args::usage as necessary. + be used in preference - as it will search for a documentation + mechanism and call punk::args::usage as necessary. " -return -default table -choices {string table tableobject} } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { @@ -3136,7 +3136,7 @@ tcl::namespace::eval punk::args { @values -min 1 id arglist -type list -help\ - "list containing arguments to be parsed as per the + "list containing arguments to be parsed as per the argument specification identified by the supplied id." }] @@ -3154,7 +3154,7 @@ tcl::namespace::eval punk::args { #consider #require eopts indicator -- ? (because first or only arg in arglist could be flaglike and match our own) - #parse ?-flag val?... -- $arglist withid $id + #parse ?-flag val?... -- $arglist withid $id #parse ?-flag val?... -- $arglist withdef $def ?$def?... #an experiment.. ideally we'd like arglist at the end? @@ -3179,15 +3179,15 @@ tcl::namespace::eval punk::args { form1: parse $arglist ?-flag val?... withid $id form2: parse $arglist ?-flag val?... withdef $def ?$def? see punk::args::define" - @form -form {withid withdef} + @form -form {withid withdef} @leaders -min 1 -max 1 arglist -type list -optional 0 -help\ "Arguments to parse - supplied as a single list" - @opts + @opts -form -type list -default * -help\ "Restrict parsing to the set of forms listed. - Forms are the orthogonal sets of arguments a + Forms are the orthogonal sets of arguments a command can take - usually described in 'synopsis' entries." #default to enhanced errorstyle despite slow 'catch' (unhappy path) performance @@ -3206,16 +3206,16 @@ tcl::namespace::eval punk::args { @form -form withdef -synopsis "parse arglist ?-form {int|...}? ?-errorstyle ? withdef $def ?$def?" withdef -type literal -help\ "The literal value 'withdef'" - + #todo - make -dynamic obsolete - use @dynamic directive instead def -type string -multiple 1 -optional 0 -help\ "Each remaining argument is a block of text defining argument definitions. - As a special case, -dynamic may be + As a special case, -dynamic may be specified as the 1st 2 arguments. These are treated as an indicator to punk::args about how to process the definition." - + }] proc parse {args} { set tailtype "" ;#withid|withdef @@ -3225,7 +3225,7 @@ tcl::namespace::eval punk::args { set parseargs [lindex $args 0] set tailargs [lrange $args 1 end] - set split [lsearch -exact $tailargs withid] + set split [lsearch -exact $tailargs withid] if {$split < 0} { set split [lsearch -exact $tailargs withdef] if {$split < 0} { @@ -3240,7 +3240,7 @@ tcl::namespace::eval punk::args { set opts [lrange $tailargs 0 $split-1] ;#repeated flags will override earlier. That's ok here. if {[llength $opts] % 2} { - error "punk::args::parse Even number of -flag val pairs required after arglist" + error "punk::args::parse Even number of -flag val pairs required after arglist" } set defaultopts [dict create\ -form {*}\ @@ -3253,7 +3253,7 @@ tcl::namespace::eval punk::args { } default { #punk::args::usage $args withid ::punk::args::parse ?? - error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" + error "punk::args::parse unrecognised option $k. Known options [dict keys $defaultopts]" } } } @@ -3312,7 +3312,7 @@ tcl::namespace::eval punk::args { } else { set arglist $a set got_arglist 1 - set tailtype [lindex $args $i+1] + set tailtype [lindex $args $i+1] if {$tailtype eq "withid"} { if {[llength $args] != $i+3} { error "punk::args::parse - invalid call. Expected exactly one argument after 'withid'" @@ -3335,7 +3335,7 @@ tcl::namespace::eval punk::args { } #assert tailtype eq withid|withdef if {$tailtype eq "withid"} { - #assert $id was provided + #assert $id was provided return "parse [llength $arglist] args withid $id, options:$opts" } else { #assert llength deflist >=1 @@ -3356,8 +3356,8 @@ tcl::namespace::eval punk::args { #see arg_error regarding considerations around unhappy-path performance #consider a better API - # - e.g punk::args::parse ?-flag val?... $arglist withid $id - # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? + # - e.g punk::args::parse ?-flag val?... $arglist withid $id + # - e.g punk::args::parse ?-flag val?... $arglist withdef $def ?$def...? #can the above be made completely unambiguous for arbitrary arglist?? #e.g what if arglist = withdef and the first $def is also withdef ? @@ -3373,11 +3373,11 @@ tcl::namespace::eval punk::args { #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values #[para]Each optionspec line defining a flag must be of the form: #[para]-optionname -key val -key2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices -optional + #[para]where the valid keys for each option specification are: -default -type -range -choices -optional #[para]Each optionspec line defining a positional argument is of the form: #[para]argumentname -key val -ky2 val2... - #[para]where the valid keys for each option specification are: -default -type -range -choices - #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value + #[para]where the valid keys for each option specification are: -default -type -range -choices + #[para]comment lines begining with # are ignored and can be placed anywhere except within a multiline value where it would become part of that value #[para]lines beginning with @cmd @leaders @opts or @values also take -key val pairs and can be used to set defaults and control settings. #[para]@opts or @values lines can appear multiple times with defaults affecting flags/values that follow. #[arg_def list rawargs] @@ -3386,13 +3386,13 @@ tcl::namespace::eval punk::args { #[list_end] #[para] - #consider line-processing example below for which we need info complete to determine record boundaries + #consider line-processing example below for which we need info complete to determine record boundaries #punk::args::get_dict { # @opts # -opt1 -default {} # -opt2 -default { # etc - # } + # } # @values -multiple 1 #} $args @@ -3402,7 +3402,7 @@ tcl::namespace::eval punk::args { #if definition has been seen before, #define will either return a permanently cached argspecs (-dynamic 0) - or - # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. + # use a cached pre-split definition with parameters to dynamically generate a new (or limitedly cached?) argspecs. set argspecs [uplevel 1 [list ::punk::args::resolve {*}$definition_args]] # ----------------------------------------------- @@ -3415,7 +3415,7 @@ tcl::namespace::eval punk::args { set flagsreceived [list] ;#for checking if required flags satisfied #secondary purpose: #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. - #-default value must not be appended to if argname not yet in flagsreceived + #-default value must not be appended to if argname not yet in flagsreceived #todo: -minmultiple -maxmultiple ? @@ -3440,9 +3440,9 @@ tcl::namespace::eval punk::args { } if {$ridx == [llength $LEADER_NAMES]-1} { #at last named leader - set leader_posn_name [lindex $LEADER_NAMES $ridx] + set leader_posn_name [lindex $LEADER_NAMES $ridx] if {[dict exists $ARG_INFO $leader_posn_name -multiple] && [dict get $ARG_INFO $leader_posn_name -multiple]} { - set is_multiple 1 + set is_multiple 1 } } elseif {$ridx > [llength $LEADER_NAMES]-1} { #beyond names - retain name if -multiple was true @@ -3468,7 +3468,7 @@ tcl::namespace::eval punk::args { if {$leader_posn_name ne ""} { #there is a named leading positional for this position #The flaglooking value doesn't match an option - so treat as a leader - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name incr ridx continue @@ -3480,7 +3480,7 @@ tcl::namespace::eval punk::args { #for each branch - break or lappend if {$leader_posn_name ne ""} { if {$leader_posn_name ni $LEADER_REQUIRED} { - #optional leader + #optional leader #most adhoc arg processing will allocate based on number of args rather than matching choice values first #(because a choice value could be a legitimate data value) @@ -3501,19 +3501,19 @@ tcl::namespace::eval punk::args { if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { break } else { - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { #required if {[dict exists $leader_posn_names_assigned $leader_posn_name]} { - #already accepted at least one value - requirement satisfied - now equivalent to optional + #already accepted at least one value - requirement satisfied - now equivalent to optional if {$val_min > 0 && [llength $rawargs] <= $val_min || [llength $rawargs] <= [llength $val_required]} { break - } + } } #if we didn't break - requirement is not yet satisfied, or is satisfied but stil enough rawargs for required values - lappend pre_values [lpop rawargs 0] + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -3522,8 +3522,8 @@ tcl::namespace::eval punk::args { if {$ridx > $LEADER_MIN} { break } else { - #haven't reached LEADER_MIN - lappend pre_values [lpop rawargs 0] + #haven't reached LEADER_MIN + lappend pre_values [lpop rawargs 0] dict incr leader_posn_names_assigned $leader_posn_name } } else { @@ -3553,7 +3553,7 @@ tcl::namespace::eval punk::args { #assert - rawargs has been reduced by leading positionals set leaders [list] - set arglist {} + set arglist {} set post_values {} #val_min, val_max #puts stderr "rawargs: $rawargs" @@ -3565,7 +3565,7 @@ tcl::namespace::eval punk::args { set vals_total_possible [llength $rawargs] set vals_remaining_possible $vals_total_possible } else { - set vals_total_possible $val_max + set vals_total_possible $val_max set vals_remaining_possible $vals_total_possible } for {set i 0} {$i <= $maxidx} {incr i} { @@ -3573,7 +3573,7 @@ tcl::namespace::eval punk::args { set remaining_args_including_this [expr {[llength $rawargs] - $i}] #lowest val_min is 0 if {$remaining_args_including_this <= $val_min} { - # if current arg is -- it will pass through as a value here + # if current arg is -- it will pass through as a value here set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] break @@ -3586,7 +3586,7 @@ tcl::namespace::eval punk::args { if {$val_max != -1} { #finite max number of vals if {$remaining_args_including_this == $val_max} { - #assume it's a value. + #assume it's a value. set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] } else { @@ -3626,7 +3626,7 @@ tcl::namespace::eval punk::args { tcl::dict::lappend opts $fullopt $flagval } } else { - tcl::dict::set opts $fullopt $flagval + tcl::dict::set opts $fullopt $flagval } #incr i to skip flagval incr vals_remaining_possible -2 @@ -3664,21 +3664,21 @@ tcl::namespace::eval punk::args { } if {$opt_any} { set newval [lindex $rawargs $i+1] - #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option + #opt was unspecified but is allowed due to @opts -any 1 - 'adhoc/passthrough' option tcl::dict::set argstate $a $optspec_defaults ;#use default settings for unspecified opt tcl::dict::set arg_checks $a $OPT_CHECKS_DEFAULTS if {[tcl::dict::get $argstate $a -type] ne "none"} { if {[tcl::dict::get $argstate $a -multiple]} { tcl::dict::lappend opts $a $newval } else { - tcl::dict::set opts $a $newval + tcl::dict::set opts $a $newval } if {[incr i] > $maxidx} { arg_error "punk::args::get_dict bad options for [Get_caller]. No value supplied for last adhoc option $a at index [expr {$i-1}] which is not marked with -type none" $argspecs -badarg $a } incr vals_remaining_possible -2 } else { - #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none + #review -we can't provide a way to allow unspecified -type none flags through reliably/unambiguously unless all remaining unspecified options are -type none if {[tcl::dict::get $argstate $a -multiple]} { if {![tcl::dict::exists $opts $a]} { tcl::dict::set opts $a 1 @@ -3702,7 +3702,7 @@ tcl::namespace::eval punk::args { } } } else { - #not flaglike + #not flaglike set arglist [lrange $rawargs 0 $i-1] set post_values [lrange $rawargs $i end] break @@ -3759,9 +3759,9 @@ tcl::namespace::eval punk::args { } set validx 0 - set in_multiple "" + set in_multiple "" set valnames_received [list] - set values_dict $val_defaults + set values_dict $val_defaults set num_values [llength $values] foreach valname $VAL_NAMES val $values { if {$validx+1 > $num_values} { @@ -3775,9 +3775,9 @@ tcl::namespace::eval punk::args { } else { tcl::dict::lappend values_dict $valname $val } - set in_multiple $valname + set in_multiple $valname } else { - tcl::dict::set values_dict $valname $val + tcl::dict::set values_dict $valname $val } lappend valnames_received $valname } else { @@ -3826,14 +3826,14 @@ tcl::namespace::eval punk::args { } } - #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options + #assertion - opts keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options #opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call) #however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call #We SHOULD? always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW #The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function. - #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level + #without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true #safe interp note - struct::set difference ensemble could be c or tcl implementation and we don't have an option to call directly? @@ -3841,10 +3841,10 @@ tcl::namespace::eval punk::args { #struct::set difference {x} {a b} #normal interp 0.18 u2 vs safe interp 9.4us #if {[llength [set missing [struct::set difference $opt_required $flagsreceived]]]} { - # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" + # error "Required option missing for [Get_caller]. missing flags $missing are marked with -optional false - so must be present in full-length form" #} #if {[llength [set missing [struct::set difference $val_required $valnames_received]]]} { - # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" + # error "Required value missing for [Get_caller]. missing values $missing marked with -optional false - so must be present" #} #for now (2024-06) punk::lib::ldiff is a better compromise across normal/safe interps e.g 0.7/0.8us if {[llength [set missing [punklib_ldiff $LEADER_REQUIRED $leadernames_received]]]} { @@ -3907,7 +3907,7 @@ tcl::namespace::eval punk::args { } #reduce our validation requirements by removing values which match defaultval or match -choices - #(could be -multiple with -choicerestriction 0 where some selections match and others don't) + #(could be -multiple with -choicerestriction 0 where some selections match and others don't) if {$has_choices} { #-choices must also work with -multiple #todo -choicelabels @@ -3930,7 +3930,7 @@ tcl::namespace::eval punk::args { } #note we can legitimately have dups in allchoices - if a choice should be documented to display in multiple groups #This means we have to be dedup for testing with tcl::prefix::match - or the duped entries won't accept prefixes - + switch -- [tcl::dict::get $thisarg -ARGTYPE] { leader { @@ -3973,7 +3973,7 @@ tcl::namespace::eval punk::args { if {$choicemultiple_max != -1 && [llength $c_list] > $choicemultiple_max} { set msg "Option $argname for [Get_caller] requires at most $choicemultiple_max choices. Received [llength $c_list] choices." return -options [list -code error -errorcode [list PUNKARGS VALIDATION [list choicecount [llength $c_list] minchoices $choicemultiple_min maxchoices $choicemultiple_max] -badarg $argname]] $msg - } + } #----------------------------------- set choice_idx 0 ;#we need to overwrite raw-choice (which may be prefix) with a value from the choice list @@ -3997,14 +3997,14 @@ tcl::namespace::eval punk::args { set choice_exact_match 0 if {$c_check in $allchoices} { #for case when there are case-differenced duplicates - allow exact match to avoid selecting earlier match of another casing - set chosen $c_check + set chosen $c_check set choice_in_list 1 set choice_exact_match 1 } elseif {$v_test in $choices_test} { #assert - if we're here, nocase must be true #we know choice is present as full-length match except for case #now we want to select the case from the choice list - not the supplied value - #we don't set choice_exact_match - because we will need to override the optimistic existing val below + #we don't set choice_exact_match - because we will need to override the optimistic existing val below #review foreach avail [lsort -unique $allchoices] { if {[string match -nocase $c $avail]} { @@ -4014,7 +4014,7 @@ tcl::namespace::eval punk::args { #assert chosen will always get set set choice_in_list 1 } else { - #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. + #PREFIX check required - any 'chosen' here is not an exact match or it would have matched above. #assert - if empty string was a provided choice and empty string was a provided arg - we would have matched above. #in this block we can treat empty result from prefix match as a non-match if {$nocase} { @@ -4033,7 +4033,7 @@ tcl::namespace::eval punk::args { set chosen [tcl::prefix::match -error "" [lsort -unique $choices_test] $v_test] #now pick the earliest match in the actually defined list so that case of chosen always matches a defined entry with casing set chosen [lsearch -inline -nocase $allchoices $chosen] - set choice_in_list [expr {$chosen ne ""}] + set choice_in_list [expr {$chosen ne ""}] } else { set chosen $bestmatch set choice_in_list 1 @@ -4057,7 +4057,7 @@ tcl::namespace::eval punk::args { } #override the optimistic existing val - if {$choice_in_list && !$choice_exact_match} { + if {$choice_in_list && !$choice_exact_match} { if {$choicemultiple_max != -1 && $choicemultiple_max < 2} { if {$is_multiple} { set existing [tcl::dict::get [set $dname] $argname] @@ -4091,7 +4091,7 @@ tcl::namespace::eval punk::args { # lset existing $idx $v_test # tcl::dict::set $dname $argname $existing #} else { - # tcl::dict::set $dname $argname $v_test + # tcl::dict::set $dname $argname $v_test #} lappend vlist_validate $c lappend vlist_check_validate $c_check @@ -4186,10 +4186,10 @@ tcl::namespace::eval punk::args { string - ansistring - globstring { #we may commonly want exceptions that ignore validation rules - most commonly probably the empty string #we possibly don't want to always have to regex on things that don't pass the other more basic checks - # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) + # -regexprefail -regexprepass (short-circuiting fail/pass run before all other validations) # -regexpostfail -regexpostpass (short-circuiting fail/pass run after other toplevel validations - but before the -validationtransform) # in the comon case there should be no need for a tentative -regexprecheck - just use a -regexpostpass instead - # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function + # however - we may want to run -regexprecheck to restrict the values passed to the -validationtransform function # -regexpostcheck is equivalent to -regexpostpass at the toplevel if there is no -validationtransform (or if it is in the -validationtransform) # If there is a -validationtransform, then -regexpostcheck will either progress to run the -validationtransform if matched, else produce a fail @@ -4197,7 +4197,7 @@ tcl::namespace::eval punk::args { set pass_quick_list_e [list] set pass_quick_list_e_check [list] set remaining_e $vlist - set remaining_e_check $vlist_check + set remaining_e_check $vlist_check #review - order of -regexprepass and -regexprefail in original rawargs significant? #for now -regexprepass always takes precedence if {$regexprepass ne ""} { @@ -4225,7 +4225,7 @@ tcl::namespace::eval punk::args { } switch -- $type { ansistring { - #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi + #we need to respect -validate_ansistripped for -minsize etc, but the string must contain ansi #.. so we need to look at the original values in $vlist not $vlist_check #REVIEW - difference between string with mixed plaintext and ansi and one required to be ansicodes only?? @@ -4271,7 +4271,7 @@ tcl::namespace::eval punk::args { } } int { - #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive + #-range can be expressed as two integers or an integer and an empty string e.g {0 ""} >= 0 or {"" 10} <=10 or {-1 10} -1 to 10 inclusive if {[tcl::dict::exists $thisarg -range]} { lassign [tcl::dict::get $thisarg -range] low high if {"$low$high" ne ""} { @@ -4290,7 +4290,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } - #highside unspecified - check only low + #highside unspecified - check only low if {$e_check < $low} { arg_error "Option $argname for [Get_caller] must be integer greater than or equal to $low. Received: '$e'" $argspecs -badarg $argname } @@ -4300,7 +4300,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e'" $argspecs -badarg $argname } - #high and low specified + #high and low specified if {$e_check < $low || $e_check > $high} { arg_error "Option $argname for [Get_caller] must be integer between $low and $high inclusive. Received: '$e'" $argspecs -badarg $argname } @@ -4312,7 +4312,7 @@ tcl::namespace::eval punk::args { if {![tcl::string::is integer -strict $e_check]} { arg_error "Option $argname for [Get_caller] requires type 'integer'. Received: '$e_check'" $argspecs -badarg $argname } - } + } } } double { @@ -4465,7 +4465,7 @@ tcl::namespace::eval punk::args { set receivednames [list {*}$leadernames_received {*}$flagsreceived {*}$valnames_received] if {[llength $receivednames]} { #flat zip of names with overall posn, including opts - #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] + #set received_posns [concat {*}[lmap a $receivednames b [zero_based_posns [llength $receivednames]] {list $a $b}]] set i -1 set received_posns [concat {*}[lmap a $receivednames {list $a [incr i]}]] } else { @@ -4474,15 +4474,15 @@ tcl::namespace::eval punk::args { #Note that $received_posns is often tested as if a dict by functions to determine quickly if a variable was received (versus just having a default value) #(e.g using 'dict exists $received -flag') # - but it can have duplicate keys when args/opts have -multiple 1 - #It is actually a list of paired elements + #It is actually a list of paired elements return [tcl::dict::create leaders $leaders_dict opts $opts values $values_dict received $received_posns] } #proc sample1 {p1 args} { # #*** !doctools # #[call [fun sample1] [arg p1] [opt {?option value...?}]] - # #[para]Description of sample1 - # return "ok" + # #[para]Description of sample1 + # return "ok" #} @@ -4513,14 +4513,14 @@ tcl::namespace::eval punk::args::lib { tcl::namespace::path [list [tcl::namespace::parent]] #*** !doctools #[subsection {Namespace punk::args::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 + # #[para]Description of utility1 + # return 1 #} proc flatzip {l1 l2} { @@ -4540,8 +4540,8 @@ tcl::namespace::eval punk::args::lib { lsearch -all [lrepeat $count 0] * } } - - + + #experiment with equiv of js template literals with ${expression} in templates #e.g tstr {This is the value of x in calling scope ${$x} !} #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} @@ -4552,7 +4552,7 @@ tcl::namespace::eval punk::args::lib { "A rough equivalent of js template literals Substitutions: - \$\{$varName\} + \$\{$varName\} \$\{[myCommand]\} (when -allowcommands flag is given)" -allowcommands -default 0 -type none -help\ @@ -4569,7 +4569,7 @@ tcl::namespace::eval punk::args::lib { -paramindents -default line -choices {none line position} -choicelabels { line\ " Use leading whitespace in - the line in which the + the line in which the placeholder occurs." position\ " Use the position in @@ -4578,21 +4578,21 @@ tcl::namespace::eval punk::args::lib { none\ " No indents applied to subsequent placeholder value - lines. This will usually - result in text awkwardly + lines. This will usually + result in text awkwardly ragged unless the source code has also been aligned with the left margin or the value has been manually padded." } -help\ - "How indenting is done for subsequent lines in a + "How indenting is done for subsequent lines in a multi-line placeholder substitution value. The 1st line or a single line value is always placed at the placeholder. - paramindents are performed after the main + paramindents are performed after the main template has been indented/undented. (indenting by position does not calculate - unicode double-wide or grapheme cluster widths) + unicode double-wide or grapheme cluster widths) " #choicelabels indented by 1 char is clearer for -return string - and reasonable in table -return -default string -choices {dict list string args}\ @@ -4603,7 +4603,7 @@ tcl::namespace::eval punk::args::lib { 'errors'" string\ " Return a single result - being the string with + being the string with placeholders substituted." list\ " Return a 2 element list. @@ -4636,7 +4636,7 @@ tcl::namespace::eval punk::args::lib { For a string return, -eval 0 will result in the raw contents of \$\{\} being substituted. contained variables in that case should be braced or whitespace separated, or the variable name is likely to collide with surrounding text. - e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" + e.g tstr -return string -eval 0 {plaintext\$\{\$\{var\}\}plaintext} -> plaintext\$\{var\}plaintext" @values -min 0 -max 1 templatestring -help\ "This argument should be a braced string containing placeholders such as \$\{$var\} e.g {The value is \$\{$var\}.} @@ -4645,19 +4645,19 @@ tcl::namespace::eval punk::args::lib { It can contain commands in square brackets if -allowcommands is true e.g tstr -return string -allowcommands {Tcl Version:\$\{[info patch]\} etc} - Escape sequences such as \\n and unicode escapes are processed within placeholders. + Escape sequences such as \\n and unicode escapes are processed within placeholders. " }] proc tstr {args} { #Too hard to fully eat-our-own-dogfood from within punk::args package - # - we use punk::args within the unhappy path only + # - we use punk::args within the unhappy path only #set argd [punk::args::get_by_id ::punk::lib::tstr $args] #set templatestring [dict get $argd values templatestring] #set opt_allowcommands [dict get $argd opts -allowcommands] #set opt_return [dict get $argd opts -return] #set opt_eval [dict get $argd opts -eval] - + set templatestring [lindex $args end] set arglist [lrange $args 0 end-1] set opts [dict create\ @@ -4773,7 +4773,7 @@ tcl::namespace::eval punk::args::lib { } if {$opt_eval} { if {[catch [list uplevel 1 [list ::subst {*}$nocommands $expression]] result]} { - lappend params [string cat \$\{ $expression \}] + lappend params [string cat \$\{ $expression \}] dict set errors [expr {[llength $params]-1}] $result } else { set result [string map [list \n "\n$leader"] $result] @@ -4790,7 +4790,7 @@ tcl::namespace::eval punk::args::lib { if {$opt_return eq "dict"} { return [dict create template $textchunks params $params errors $errors] - } + } if {[dict size $errors]} { set einfo "" dict for {i e} $errors { @@ -4828,7 +4828,7 @@ tcl::namespace::eval punk::args::lib { set lastline [string range $pt $lastline_posn+1 end] } if {$opt_paramindents eq "line"} { - regexp {(\s*).*} $lastline _all lastindent + regexp {(\s*).*} $lastline _all lastindent } else { #position #TODO - detect if there are grapheme clusters @@ -4847,8 +4847,8 @@ tcl::namespace::eval punk::args::lib { } } else { append out $pt $param - } - append lastline $param + } + append lastline $param } } return $out @@ -4859,9 +4859,9 @@ tcl::namespace::eval punk::args::lib { proc tstr_test_one {args} { set argd [punk::args::get_dict { @cmd -name ::punk::args::lib::tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. - example: + example: set id 2 - tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] + tstr_test_one {*}[tstr -return args {Select * from table where id = \$\{$id\} and etc... ;}] } @values -min 2 -max 2 @@ -4882,8 +4882,8 @@ tcl::namespace::eval punk::args::lib { } set chars [split $templatestring ""] set in_placeholder 0 - set tchars "" - set echars "" + set tchars "" + set echars "" set parts [list] set i 0 foreach ch $chars { @@ -4912,7 +4912,7 @@ tcl::namespace::eval punk::args::lib { } else { append echars $ch } - } + } } incr i } @@ -4932,7 +4932,7 @@ tcl::namespace::eval punk::args::lib { } set list [list] set start 0 - #ideally re should allow curlies within but we will probably need a custom parser to do it + #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 {\$\{(?:(?!\$\{).)*\}} @@ -4945,14 +4945,14 @@ tcl::namespace::eval punk::args::lib { #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 + 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] + 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]} { @@ -4967,7 +4967,7 @@ tcl::namespace::eval punk::args::lib { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { - lappend result "" + lappend result "" } else { lappend result $prefix[string trimright $line] } @@ -5009,7 +5009,7 @@ tcl::namespace::eval punk::args::lib { #hacky proc undentleader {text leader} { - #leader usually whitespace - but doesn't have to be + #leader usually whitespace - but doesn't have to be if {$text eq ""} { return "" } @@ -5044,7 +5044,7 @@ tcl::namespace::eval punk::args::lib { } return [join $result \n] } - #A version of textutil::string::longestCommonPrefixList + #A version of textutil::string::longestCommonPrefixList proc longestCommonPrefix {items} { if {[llength $items] <= 1} { return [lindex $items 0] @@ -5061,9 +5061,9 @@ tcl::namespace::eval punk::args::lib { } set n [string length $min] set prefix "" - set i -1 + set i -1 while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c + append prefix $c } return $prefix } @@ -5099,7 +5099,7 @@ tcl::namespace::eval punk::args::package { " -package_about_namespace -type string -optional 0 -help\ "Namespace containing the package about procedures - Must contain " + Must contain " -return\ -type string\ -default table\ @@ -5140,7 +5140,7 @@ tcl::namespace::eval punk::args::package { set pkgname [${pkgns}::package_name] set opt_return [dict get $OPTS -return] - set all_topics [${pkgns}::about_topics] + set all_topics [${pkgns}::about_topics] if {![dict exists $received topic]} { set topics $all_topics } else { @@ -5214,7 +5214,7 @@ tcl::namespace::eval punk::args::package { #can't do this here? - as there is circular dependency with punk::lib #tcl::namespace::eval punk::args { # foreach deflist $PUNKARGS { -# punk::args::define {*}$deflist +# punk::args::define {*}$deflist # } # set PUNKARGS "" #} @@ -5227,7 +5227,7 @@ lappend ::punk::args::register::NAMESPACES ::punk::args::argdoc ::punk::args ::p tcl::namespace::eval punk::args::system { #*** !doctools #[subsection {Namespace punk::args::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #dict get value with default wrapper for tcl 8.6 if {[info commands ::tcl::dict::getdef] eq ""} { @@ -5240,11 +5240,11 @@ tcl::namespace::eval punk::args::system { } } } else { - #we pay a minor perf penalty for the wrap + #we pay a minor perf penalty for the wrap interp alias "" ::punk::args::system::Dict_getdef "" ::tcl::dict::getdef } - #name to reflect maintenance - home is punk::lib::ldiff + #name to reflect maintenance - home is punk::lib::ldiff proc punklib_ldiff {fromlist removeitems} { if {[llength $removeitems] == 0} {return $fromlist} set result {} @@ -5260,12 +5260,12 @@ tcl::namespace::eval punk::args::system { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::args [tcl::namespace::eval punk::args { tcl::namespace::path {::punk::args::lib ::punk::args::system} variable pkg punk::args variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm index 7a4a899e..0dc1a37f 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::args::tclcore 0 0.1.0] #[copyright "2025"] #[titledesc {punk::args definitions for tcl core commands}] [comment {-- Name section and table of contents description --}] -#[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}] +#[moddesc {tcl core argument definitions}] [comment {-- Description at end of page heading --}] #[require punk::args::tclcore] #[keywords module] #[description] @@ -117,7 +117,7 @@ tcl::namespace::eval punk::args::tclcore { # set A_RST "\x1b\[0m" #} - #we can't just strip ansi as there are non colour codes such as hyperlink that should be maintained whether color is on or off. + #we can't just strip ansi as there are non colour codes such as hyperlink that should be maintained whether color is on or off. #for now we can use reverse - (like underline, is a non-colour attribute that remains effective when color off in punk::ansi) set A_WARN \x1b\[7m set A_RST \x1b\[0m @@ -145,7 +145,7 @@ tcl::namespace::eval punk::args::tclcore { tcl::namespace::import ::punk::ansi::a+ # -- --- --- --- --- #non colour SGR codes - # we can use these directly via ${$I} etc without marking a definition with @dynamic + # we can use these directly via ${$I} etc without marking a definition with @dynamic #This is because they don't need to change when colour switched on and off. set I [a+ italic] set NI [a+ noitalic] @@ -168,9 +168,9 @@ tcl::namespace::eval punk::args::tclcore { by groupname. Each groupname forms the title of a subtable in the choices list. Subcommands not assigned to a groupname will appear first - in an untitled subtable." + in an untitled subtable." -columns -default 4 -type integer -help\ - "Max number of columns for all subtables in the choices + "Max number of columns for all subtables in the choices display area" @values -min 1 -max 1 ensemble -optional 0 -help\ @@ -249,7 +249,7 @@ tcl::namespace::eval punk::args::tclcore { puts -------------------- } - set opt_groupdict $checked_groupdict + set opt_groupdict $checked_groupdict # ---------------------------------------------- set allgrouped [list] dict for {g members} $opt_groupdict { @@ -271,7 +271,7 @@ tcl::namespace::eval punk::args::tclcore { } append argdef " \} -choicecolumns $opt_columns" \n - #todo -choicelabels + #todo -choicelabels #detect subcommand further info available e.g if oo or ensemble or punk::args id exists.. #consider a different mechanism to add a label on rhs of same line as choice (for (i) marker) @@ -318,7 +318,7 @@ tcl::namespace::eval punk::args::tclcore { "milliseconds" @values -form {delay} -min 1 -max 1 @values -form {schedule_ms} -min 2 - script -form {schedule_ms} -multiple 1 -optional 1 ref-help common_script_help + script -form {schedule_ms} -multiple 1 -optional 1 ref-help common_script_help @form -form {cancelid} -synopsis "after cancel id" @@ -330,7 +330,7 @@ tcl::namespace::eval punk::args::tclcore { @form -form {cancelscript} -synopsis "after cancel script ?script...?" @values -min 2 cancel -choices {cancel} - script -multiple 1 -optional 0 ref-help common_script_help + script -multiple 1 -optional 0 ref-help common_script_help @form -form {schedule_idle} -synopsis "after idle script ?script...?" @@ -365,13 +365,13 @@ tcl::namespace::eval punk::args::tclcore { "Information about the state of the Tcl interpreter" @leaders -min 1 -max 1 ${[punk::args::tclcore::argdoc::info_subcommands]} - @values -min 0 + @values -min 0 } "@doc -name Manpage: -url [manpage_tcl array]" ] - #An idiom for sharing common features - incomplete - todo work out what happens with (default)::id that has leaders,opts,values + #An idiom for sharing common features - incomplete - todo work out what happens with (default)::id that has leaders,opts,values #todo @cmd -help+ text (append to existing help that came from a default?) lappend PUNKARGS [list { @id -id "(default)::tcl::binary::*::base64" @@ -416,14 +416,14 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id "::tcl::binary::encode::hex" @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" + @cmd -name "binary encode hex" @values -min 1 -max 1 data -type string } ] lappend PUNKARGS [list { @id -id "::tcl::binary::decode::hex" @default -id (default)::tcl::binary::*::hex - @cmd -name "binary encode hex" + @cmd -name "binary encode hex" -strict -type none -help\ "Instructs the decoder to throw an error if it encounters whitespace characters. Otherwise it ignores them." @@ -445,10 +445,10 @@ tcl::namespace::eval punk::args::tclcore { @id -id "::tcl::binary::encode::uuencode" @default -id (default)::tcl::binary::*::uuencode #todo @cmd -help+ "Changing the options may produce files that other implementations of decoders cannot process" - @cmd -name "binary encode uuencode" + @cmd -name "binary encode uuencode" -maxlen -type integer -default 61 -range {5 85} -help\ "Indicates the maximum number of characters to produce for each encoded line. - The valid range is 5 to 85. Line lengths outside that range cannot be + The valid range is 5 to 85. Line lengths outside that range cannot be accommodated by the encoding format." -wrapchar -type string -default \n -help\ "Indicates the character(s) to use to mark the end of each encoded line. @@ -464,7 +464,7 @@ tcl::namespace::eval punk::args::tclcore { lappend PUNKARGS [list { @id -id "::tcl::binary::decode::uuencode" @default -id (default)::tcl::binary::*::uuencode - @cmd -name "binary decode uuencode" + @cmd -name "binary decode uuencode" -strict -type none -help\ "Instructs the decoder to throw an error if it encounters anything outside of the standard encoding format. Without this option, the decoder tolerates @@ -540,14 +540,14 @@ tcl::namespace::eval punk::args::tclcore { ${$B}import${$N} ${$I}commandName${$NI} was created by 'namespace import'. ${$B}native${$N} - ${$I}commandName${$NI} was created by the 'Tcl_CreateObjCommand' interface + ${$I}commandName${$NI} was created by the 'Tcl_CreateObjCommand' interface directly without further registration of the type of command. ${$B}object${$N} ${$I}commandName${$NI} is the public comand that represents an instance of oo::object or one of its subclasses. ${$B}privateObject${$N} ${$I}commandName${$NI} is the private command, my by default, - that represents an instance of oo::object or one of its subclasses. + that represents an instance of oo::object or one of its subclasses. ${$B}proc${$N} ${$I}commandName${$NI} was created by 'proc'. ${$B}interp${$N} @@ -583,7 +583,7 @@ tcl::namespace::eval punk::args::tclcore { If namespaceList is specified as a list of named namespaces, the current namespace's command resolution path is set to those namespaces and returns the empty list. The default command resolution path is always empty. - See the section NAME_RESOLUTION in the manpage for an explanation of the + See the section NAME_RESOLUTION in the manpage for an explanation of the rules regarding name resolution." @values -min 0 -max 1 namespaceList -type list -optional 1 -help\ @@ -618,10 +618,10 @@ tcl::namespace::eval punk::args::tclcore { regarding name resolution. " @opts - -command + -command -variable @values -min 1 -max 1 - name + name } "@doc -name Manpage: -url [manpage_tcl namespace]" ] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -631,9 +631,9 @@ tcl::namespace::eval punk::args::tclcore { "Returns a dictionary mapping subprocess PIDs to their respective status. If ${$I}pids${$NI} is specified as a list of PIDs then the command only returns the status of the matching subprocesses if they exist. - For active processes, the status is an empty value. For terminated + For active processes, the status is an empty value. For terminated processes, the status is a list with the following format: - {code ?msg errorCode?} + {code ?msg errorCode?} where: ${$I}code${$NI} is a standard Tcl return code, ie., @@ -642,12 +642,12 @@ tcl::namespace::eval punk::args::tclcore { is the human readable error message, ${$I}errorCode${$NI} uses the same format as the errorCode global variable - Note that msg and errorCode are only present for abnormally + Note that msg and errorCode are only present for abnormally terminated processes (i.e. those where the code is nonzero). Under the hood this command calls Tcl_WaitPid with the WNOHANG flag set for non-blocking behaviour, unless the -wait switch is set (see below). - + " -wait -type none -optional 1 -help\ "By default the command returns immediately (the underlying Tcl_WaitPid @@ -680,7 +680,7 @@ tcl::namespace::eval punk::args::tclcore { ############################################################################################################################################################ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # COMMANDS A-H + # COMMANDS A-H # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ############################################################################################################################################################ @@ -699,7 +699,7 @@ tcl::namespace::eval punk::args::tclcore { return [ensemble_subcommands_definition -groupdict $groups -columns 4 array] } } - + lappend PUNKARGS [list { @dynamic @id -id ::array @@ -720,7 +720,7 @@ tcl::namespace::eval punk::args::tclcore { This command is normally used within a procedure body (or method body, or lambda term) to create a constant within that procedure, or within a - namespace eval body to create a constant within that namespace. The + namespace eval body to create a constant within that namespace. The constant is an unmodifiable variable, called varName, that is initialised with value. The result of const is always the empty string on success. If a variable varname does not exist, it is create with its value set to @@ -733,7 +733,7 @@ tcl::namespace::eval punk::args::tclcore { The varName may not be a qualified name or reference an element of an array by any means. If the variable exists and is an array, that is an error. Constants are normally only removed by their containing procedure - exiting or their namespace being deleted. + exiting or their namespace being deleted. " @values -min 1 -max 2 varName -help "" @@ -778,7 +778,7 @@ tcl::namespace::eval punk::args::tclcore { @cmd -name "builtin: lappend" -help\ "Append list elements onto a variable. " - @values -min 1 -max -1 + @values -min 1 -max -1 varName -type string -help\ "variable name" value -type any -optional 1 -multiple 1 @@ -787,11 +787,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { - @id -id ::ledit + @id -id ::ledit @cmd -name "builtin: ledit" -help\ "Replace elements of a list stored in variable " - @values -min 3 -max -1 + @values -min 3 -max -1 listVar -type string -help\ "Existing list variable name" first -type indexexpression @@ -804,7 +804,7 @@ tcl::namespace::eval punk::args::tclcore { punk::args::define { @id -id ::lremove @cmd -name "builtin: lremove" -help\ - "Remove elements from a list by index + "Remove elements from a list by index lremove returns a new list formed by simultaneously removing zero or more elements of list at each of the indices given by an arbitrary number of index arguments. The indices may be in any order and may be @@ -813,7 +813,7 @@ tcl::namespace::eval punk::args::tclcore { 'string index', supporting simple index arithmetic and indices relative to the end of the list. 0 refers to the first element of the list, and end refers to the last element of the list." - @values -min 1 -max -1 + @values -min 1 -max -1 list -type list -help\ "tcl list as a value" index -type indexexpression -multiple 1 -optional 1 @@ -824,11 +824,11 @@ tcl::namespace::eval punk::args::tclcore { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- punk::args::define { - @id -id ::lpop + @id -id ::lpop @cmd -name "builtin: lpop" -help\ "Get and remove an element in a list " - @values -min 1 -max -1 + @values -min 1 -max -1 varName -type string -help\ "Existing list variable name" index -type indexexpression -default end -optional 1 -multiple 1 -help\ @@ -866,7 +866,7 @@ tcl::namespace::eval punk::args::tclcore { ############################################################################################################################################################ # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # COMMANDS M-Z + # COMMANDS M-Z # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ############################################################################################################################################################ @@ -882,19 +882,19 @@ tcl::namespace::eval punk::args::tclcore { then set the value of varName to value, creating a new variable if one does not already exist, and return its value. If varName contains an open parenthesis and ends with a close parenthesis, - then it refers to an array element: the characters before the - first open parenthesis are the name of the array, and the + then it refers to an array element: the characters before the + first open parenthesis are the name of the array, and the characters between the parentheses are the index within the array. Otherwise varName refers to a scalar variable. If varName includes namespace qualifiers (in the array name if it refers to an array element), or if varName is unqualified (does not include the names of any containing namespaces) but no - procedure is active, varName refers to a namespace variable + procedure is active, varName refers to a namespace variable resolved according to the rules described under NAME RESOLUTION in the namespace manual page. If a procedure is active and varName is unqualified, then varName refers to a parameter or local variable of the procedure, unless - varName was declared to resolve differently through one of the + varName was declared to resolve differently through one of the global, variable, or upvar commands. " @values -min 1 -max 2 @@ -924,7 +924,7 @@ tcl::namespace::eval punk::args::tclcore { @cmd -name "builtin: tcl::string::cat" -help\ "Concatenate the given strings just like placing them directly next to each other and - return the resulting compound string. If no strings are present, the result is an + return the resulting compound string. If no strings are present, the result is an empty string. This primitive is occasionally handier than juxtaposition of strings when mixed quoting is wanted, or when the aim is to return the result of a concatentation without resorting @@ -981,7 +981,7 @@ tcl::namespace::eval punk::args::tclcore { in needleString. If found, return the index of the first character in the first such match within haystackString. If there is no match, then return -1. If startIndex is specified (in any of the forms described in STRING_INDICES), then the search is - constrained to start with the character in haystackString specified by the index. + constrained to start with the character in haystackString specified by the index. " @values -min 2 -max 3 needleString -type string @@ -1002,7 +1002,7 @@ tcl::namespace::eval punk::args::tclcore { prepended to the string. If index is at or after the end of the string (e.g., index is end), insertString is appended to string." - + @values -min 3 -max 3 string -type string index -type indexexpression -help\ @@ -1156,7 +1156,7 @@ tcl::namespace::eval punk::args::tclcore { dict\ " Any proper dict structure, with optional surrounding - whitespace. In case of + whitespace. In case of improper dict structure, 0 is returned and the varname will contain the index of @@ -1254,7 +1254,7 @@ tcl::namespace::eval punk::args::tclcore { "If -strict is specified, then an empty string returns 0, otherwise an empty string will return 1 on any class" -failindex -type variablename -help\ - "If -failindex is specified, then if the function returns 0, + "If -failindex is specified, then if the function returns 0, the index in the string where the class was no longer valid will be stored in the variable named." @values -min 1 -max 1 @@ -1329,7 +1329,7 @@ tcl::namespace::eval punk::args::tclcore { " Invoke commandPrefix when the traced command is deleted. Commands can be deleted explicitly using the rename command to rename the command to an empty string. Commands are also deleted - when the interpreter is deleted, but traces will not be invoked + when the interpreter is deleted, but traces will not be invoked because there is no interpreter in which to execute them." }\ -help\ @@ -1363,7 +1363,7 @@ tcl::namespace::eval punk::args::tclcore { whenever command name is executed, with traces occurring at the points indicated by the list ops. Name will be resolved using the usual namespace resolution ruls used by commands. If the command does not exist, and error - will be thrown" + will be thrown" name -type string -help\ "Name of command" # --------------------------------------------------------------- @@ -1411,7 +1411,7 @@ tcl::namespace::eval punk::args::tclcore { (the traced command for a enter operation, an arbitrary command for an enterstep operation), including all arguments in their fully expanded form. Op indicates what operation is being performed - on the command execution, and is on of enter or enterstep as + on the command execution, and is on of enter or enterstep as defined above. The trace operation can be used to stop the command from executing, by deleting the command in question. Of course when the command is subsequently executed, an \"invalid command\" error @@ -1434,10 +1434,10 @@ tcl::namespace::eval punk::args::tclcore { traces. CommandPrefix executes in the same context as the code that invoked - the traced operation: thus the commandPrefix, if invoked from a + 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 - the trace was created. If commandPrefix invokes a procedure (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 invoked the trace operation. @@ -1463,13 +1463,13 @@ tcl::namespace::eval punk::args::tclcore { @cmd -name "builtin: trace remove command" -help\ "If there is a trace set on command name with the operations and command given by opList and commandPrefix, then the trace is removed, so that - commandPrefix will never again be invoked. Returns an empty string. If + commandPrefix will never again be invoked. Returns an empty string. If name does not exist, the command will throw an error" @values name -type string -help\ "Name of command" opList -type list -help\ - "A list of one or more of the following items: + "A list of one or more of the following items: rename delete" commandPrefix @@ -1483,25 +1483,25 @@ tcl::namespace::eval punk::args::tclcore { "Create and initialise a namespace variable. " @form -form "setvalues" -synopsis "variable ?name value...? ?name?" - @values -min 2 -max -1 + @values -min 2 -max -1 #todo - #In this case - we don't want name_value to display - as this is only used for documenting a builtin + #In this case - we don't want name_value to display - as this is only used for documenting a builtin #For the case where an @argroups is used also for parsing - the help should display the synopsis form #and also the name of the var in which it is placed. # e.g - # ?{name value}...? + # ?{name value}...? # (name_value) #The second line giving an indication the resulting list of pairs can be accessed with something like: # dict get $argd values name_value #@arggroup -name name_value -min 1 -max 2 -optional 1 -multiple 1 -args { - # name + # name # value # } @form -form "declare" -synopsis "variable name" - @values -min 1 -max 1 - name -optional 0 + @values -min 1 -max 1 + name -optional 0 } "@doc -name Manpage: -url [manpage_tcl variable]" # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -1514,7 +1514,7 @@ tcl::namespace::eval punk::args::tclcore { } } punk::args::define { - @id -id ::zlib + @id -id ::zlib @cmd -name "builtin: ::zlib" -help\ "zlib - compression and decompression operations zlib version: ${$::punk::args::tclcore::argdoc::ZLIBVERSION}" @@ -1549,7 +1549,7 @@ tcl::namespace::eval punk::args::tclcore { @id -id "::zlib adler32" @cmd -name "builtin: ::zlib adler32" -help\ "Compute a checksum of binary string ${$I}string${$NI} using the Adler32 - algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. + algorithm. If given, ${$I}initValue${$NI} is used to initialize the checksum engine. " @values -min 1 -max 2 string -type string @@ -1561,7 +1561,7 @@ tcl::namespace::eval punk::args::tclcore { #*** !doctools #[subsection {Namespace punk::args::tclcore}] - #[para] Core API functions for punk::args::tclcore + #[para] Core API functions for punk::args::tclcore #[list_begin definitions] @@ -1569,13 +1569,13 @@ tcl::namespace::eval punk::args::tclcore { #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" #} @@ -1595,14 +1595,14 @@ tcl::namespace::eval punk::args::tclcore::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::args::tclcore::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 + # #[para]Description of utility1 + # return 1 #} @@ -1620,7 +1620,7 @@ tcl::namespace::eval punk::args::tclcore::lib { #tcl::namespace::eval punk::args::tclcore::system { #*** !doctools #[subsection {Namespace punk::args::tclcore::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API @@ -1632,11 +1632,11 @@ namespace eval ::punk::args::register { lappend ::punk::args::register::NAMESPACES ::punk::args::tclcore ::punk::args::tclcore::argdoc } -## Ready +## Ready package provide punk::args::tclcore [tcl::namespace::eval punk::args::tclcore { variable pkg punk::args::tclcore variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/assertion-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/assertion-0.1.0.tm index 8ad0af62..80f4b14d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/assertion-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/assertion-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::assertion 0 0.1.0] #[copyright "2024"] #[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] -#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] +#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] #[require punk::assertion] #[keywords module assertion assert debug] #[description] @@ -99,9 +99,9 @@ tcl::namespace::eval punk::assertion::class { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin +#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin tcl::namespace::eval punk::assertion::primary { - #tcl::namespace::export {[a-z]*} + #tcl::namespace::export {[a-z]*} tcl::namespace::export assertActive assertInactive proc assertActive {expr args} { @@ -112,7 +112,7 @@ tcl::namespace::eval punk::assertion::primary { if {![tcl::string::is boolean -strict $res]} { return -code error "invalid boolean expression: $expr" } - + if {$res} {return} if {[llength $args]} { @@ -130,9 +130,9 @@ tcl::namespace::eval punk::assertion::primary { } tcl::namespace::eval punk::assertion::secondary { - tcl::namespace::export * + tcl::namespace::export * #we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want. - proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] + proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] proc assertInactive args {} } @@ -151,7 +151,7 @@ tcl::namespace::eval punk::assertion { } do_ns_import #puts --------BBB - rename assertActive assert + rename assertActive assert } @@ -162,20 +162,20 @@ tcl::namespace::eval punk::assertion { #*** !doctools #[subsection {Namespace punk::assertion}] - #[para] Core API functions for punk::assertion + #[para] Core API functions for punk::assertion #[list_begin definitions] #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] - # #[para]Description of sample1 + # #[para]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" #} #like tcllib's control::assert - we are limited to the same callback for all namespaces. @@ -218,7 +218,7 @@ tcl::namespace::eval punk::assertion { if {$on_off} { #Enable it in calling namespace if {"assert" eq $info_command} { - #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) + #There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] @@ -243,7 +243,7 @@ tcl::namespace::eval punk::assertion { } return 1 } else { - #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace + #assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace tcl::namespace::eval $nscaller { set assertorigin [tcl::namespace::origin assert] if {[tcl::string::match ::punk::assertion::* $assertorigin]} { @@ -303,8 +303,8 @@ tcl::namespace::eval punk::assertion { return 0 } } else { - #no assert command reachable - #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path + #no assert command reachable + #If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" return 0 } @@ -327,14 +327,14 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::assertion::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 + # #[para]Description of utility1 + # return 1 #} @@ -352,7 +352,7 @@ tcl::namespace::eval punk::assertion::lib { tcl::namespace::eval punk::assertion::system { #*** !doctools #[subsection {Namespace punk::assertion::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #Maintenance - snarfed from punk::ns to reduce dependencies - punk::ns::nsprefix is the master version #nsprefix/nstail are string functions - they do not concern themselves with what namespaces are present in the system @@ -375,7 +375,7 @@ tcl::namespace::eval punk::assertion::system { proc nstail {nspath args} { #normalize the common case of :::: set nspath [tcl::string::map [list :::: ::] $nspath] - set mapped [tcl::string::map [list :: \u0FFF] $nspath] + set mapped [tcl::string::map [list :: \u0FFF] $nspath] set parts [split $mapped \u0FFF] set defaults [list -strict 0] @@ -411,11 +411,11 @@ tcl::namespace::eval punk::assertion::system { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::assertion [tcl::namespace::eval punk::assertion { variable pkg punk::assertion variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm index fc72e607..b510df36 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/basictelnet-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell::basictelnet 0 0.1.0] #[copyright "2024"] #[titledesc {basic telnet client - DKF/Wiki}] [comment {-- Name section and table of contents description --}] -#[moddesc {basic telnet client}] [comment {-- Description at end of page heading --}] +#[moddesc {basic telnet client}] [comment {-- Description at end of page heading --}] #[require punk::basictelnet] #[keywords module telnet protocol console terminal] #[description] @@ -106,16 +106,16 @@ namespace eval punk::basictelnet { #todo - use these as defaults - provide a way to configure/listen to local events and notify server (sigwinch unix, unknown windows) set window_cols 80 - set window_rows 25 + set window_rows 25 #Some modern(?) telnet servers seem to just pump out utf-8 encoded graphics by default - without negotiating or confirming binary etc? review - variable encoding_guess utf-8 - #we will experimentally assume utf-8 - which should handle ascii fine - and flip to cp437 when data encountered that cannot be valid utf-8 + variable encoding_guess utf-8 + #we will experimentally assume utf-8 - which should handle ascii fine - and flip to cp437 when data encountered that cannot be valid utf-8 #todo - proper charset negotiation variable debug - set debug 0 + set debug 0 proc debug {{on_off ""}} { variable debug if {$on_off eq ""} { @@ -125,9 +125,9 @@ namespace eval punk::basictelnet { error "punk::basictelnet::debug on_off must be empty string to query, or a boolean value" } set debug [expr {$on_off}] - } + } - variable can_debug + variable can_debug set can_debug 1 if {[catch { package require textblock @@ -152,10 +152,10 @@ namespace eval punk::basictelnet { #*** !doctools #[subsection {Namespace punk::basictelnet}] - #[para] Core API functions for punk::basictelnet + #[para] Core API functions for punk::basictelnet #[list_begin definitions] - variable optioncodes + variable optioncodes dict set optioncodes 0 [list name "Binary Transmission" short "bin"] dict set optioncodes 1 [list name "Echo" short "echo"] dict set optioncodes 2 [list name "Reconnection" short "recon"] @@ -216,8 +216,8 @@ namespace eval punk::basictelnet { dict set optioncodes 255 [list name "Extended-Options-List"] #we are assuming we initiated the connection, and are in some sense the 'client' - variable server_option_state - variable client_option_state + variable server_option_state + variable client_option_state variable client_option_declined #not all these will make sense as a boolean? review. #we use this also to support the Status option @@ -231,7 +231,7 @@ namespace eval punk::basictelnet { set encoding_guess utf-8 dict for {k _v} $optioncodes { - dict set server_option_state $k 0 ;#DO from our perspective + dict set server_option_state $k 0 ;#DO from our perspective dict set client_option_state $k 0 ;#WILL from our perspective } variable client_option_declined ;#record explicit negative responses (won'ts) to DO requests from server @@ -290,7 +290,7 @@ namespace eval punk::basictelnet { # A rudimentary hardcoded configuration for options/negotiation # The way in which features are enabled/disabled and what goes together needs refinement & better understanding # todo - review - #Note: further logic required, for example even something as supposedly simple as echo shouldn't be active on both ends at once or we get a loop. + #Note: further logic required, for example even something as supposedly simple as echo shouldn't be active on both ends at once or we get a loop. # Can't necessarily rely on other end not to allow us to do something insane. # Probably also.. some options should be under direct user ability to initiate/control - not just a configuration # For that to work fully we may need a separate punk::telnet package that has a pseudoterminal in front of the real console (scrolling sub-area), allowing a custom repl, custom status display etc. @@ -299,16 +299,16 @@ namespace eval punk::basictelnet { #Passively enabled server features - ie those we don't initiate but will accept #default response to WILL is WON'T #define our positive responses here for those that we will do - variable respond_will_do - set respond_will_do [list] + variable respond_will_do + set respond_will_do [list] lappend respond_will_do 0 ;#binary lappend respond_will_do 1 ;#echo lappend respond_will_do 3 ;#suppress go-ahead lappend respond_will_do 5 ;#status - by agreeing to this we should be able to read unsolicited "IAC SB STATUS IS ... IAC SE" reports and compare to our perception of state. (and do something if mismatches?) lappend respond_will_do 24 ;#remote is letting us know they are willing to send terminal-type - but we would still have to request it - #passively enabled client features - requests for our own behaviours we will respond positively - variable respond_do_will + #passively enabled client features - requests for our own behaviours we will respond positively + variable respond_do_will set respond_do_will [list] lappend respond_do_will 0 ;#binary lappend respond_do_will 3 ;#Suppress go-ahead @@ -333,13 +333,13 @@ namespace eval punk::basictelnet { #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" #} @@ -402,28 +402,28 @@ namespace eval punk::basictelnet { set client_declined "CLI-WONT:[a+ red bold][get_client_option_declined_summary][a]" set info $server_summary\n$client_summary\n$client_declined\n$info - #set existing_handler [fileevent stdin readable] - set RST "\x1b\[m" + #set existing_handler [chan event stdin readable] + set RST "\x1b\[m" set debug_width 80 set infoframe [textblock::frame -checkargs 0 -width $debug_width -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug $terminal_type (encoding guess:$encoding_guess)$RST" $info] #set w [textblock::width $infoframe] set spacepatch "$RST[textblock::block $debug_width 4 { }]" #puts -nonewline [punk::ansi::cursor_off] - #use non cursorsave version - slower - but less likely to interfere with cursor operations in data + #use non cursorsave version - slower - but less likely to interfere with cursor operations in data - set existing_input_handler [fileevent $inputchannel readable] ;#stdin - fileevent $inputchannel readable {} + set existing_input_handler [chan event $inputchannel readable] ;#stdin + chan event $inputchannel readable {} if {[string length $outputchannel]} { - set existing_output_handler [fileevent $outputchannel readable] ;#sock - fileevent $outputchannel readable {} + set existing_output_handler [chan event $outputchannel readable] ;#sock + chan event $outputchannel readable {} } - if {[catch { + if {[catch { #90 set debug_offset [expr {$consolewidth - $debug_width}] - punk::console::move_emitblock_return 6 $debug_offset $spacepatch + punk::console::move_emitblock_return 6 $debug_offset $spacepatch flush stdout punk::console::move_emitblock_return 10 $debug_offset $infoframe flush stdout @@ -432,11 +432,11 @@ namespace eval punk::basictelnet { puts stderr "debug_frame error: $errM" } - #todo - try? finally? + #todo - try? finally? set writing_debug_frame 0 - fileevent $inputchannel readable $existing_input_handler + chan event $inputchannel readable $existing_input_handler if {[string length $outputchannel]} { - fileevent $outputchannel readable $existing_output_handler + chan event $outputchannel readable $existing_output_handler } return } @@ -446,7 +446,7 @@ namespace eval punk::basictelnet { variable debug variable can_debug variable debug_buffer - if {!$can_debug} {return} + if {!$can_debug} {return} append debug_buffer $newlines set lines [split $debug_buffer \n] set lines [lrange $lines end-40 end] @@ -469,7 +469,7 @@ namespace eval punk::basictelnet { server -type string -help\ "Hostname or IP address" port -type integer -range {1 65535} -default 23 -help\ - "TCP port" + "TCP port" } proc telnet {args} { set argd [punk::args::get_by_id ::punk::basictelnet::telnet $args] @@ -513,11 +513,11 @@ namespace eval punk::basictelnet { catch {set consolewidth [dict get [punk::console::get_size] columns]} if {$consolewidth eq ""} { #vt52? - set consolewidth 80 + set consolewidth 80 } if {$debug && $consolewidth-$::punk::basictelnet::window_cols < 80} { - puts stderr "Terminal width '$consolewidth' not wide enough for debug_window width: 80 + telnet window_cols:$::punk::basictelnet::window_cols" + puts stderr "Terminal width '$consolewidth' not wide enough for debug_window width: 80 + telnet window_cols:$::punk::basictelnet::window_cols" puts stderr "Turn off debug, or make terminal window wider" return } elseif {$consolewidth < $::punk::basictelnet::window_cols} { @@ -525,17 +525,17 @@ namespace eval punk::basictelnet { puts stderr "Ensure terminal is greater than or equal to punk::basictelnet::window_cols" return } - + #todo - allow telnet with channels other than stdin/stdout - and multiple sessions - per session option_states reset_option_states set sock [socket $server $port] - #fconfigure $sock -buffering none -blocking 0 -encoding binary -translation crlf -eofchar {} - #fconfigure $sock -buffering none -blocking 0 -encoding binary -translation binary -eofchar {} - fconfigure $sock -buffering none -blocking 0 -encoding iso8859-1 -translation binary -eofchar {} - fconfigure stdout -buffering none - fileevent $sock readable [list [namespace current]::fromServer $sock] + #chan configure $sock -buffering none -blocking 0 -encoding binary -translation crlf -eofchar {} + #chan configure $sock -buffering none -blocking 0 -encoding binary -translation binary -eofchar {} + chan configure $sock -buffering none -blocking 0 -encoding iso8859-1 -translation binary -eofchar {} + chan configure stdout -buffering none + chan event $sock readable [list [namespace current]::fromServer $sock] chan configure stdin -blocking 0 - fileevent stdin readable [list [namespace current]::toServer $sock] + chan event stdin readable [list [namespace current]::toServer $sock] variable closed vwait ::punk::basictelnet::closed($sock) unset closed($sock) @@ -563,12 +563,12 @@ namespace eval punk::basictelnet { upvar ::punk::console::input_chunks_waiting input_chunks_waiting set nextwaiting "" - if {[info exists input_chunks_waiting(stdin)] && [llength $input_chunks_waiting(stdin)]} { - set nextwaiting [lindex $input_chunks_waiting(stdin) 0] + if {[info exists input_chunks_waiting(stdin)] && [llength $input_chunks_waiting(stdin)]} { + set nextwaiting [lindex $input_chunks_waiting(stdin) 0] set input_chunks_waiting(stdin) [lrange $input_chunks_waiting(stdin) 1 end] } - fileevent stdin readable {} + chan event stdin readable {} if {$nextwaiting eq ""} { set chunk [read stdin] } else { @@ -610,19 +610,19 @@ namespace eval punk::basictelnet { puts stderr "Failed to write to socket $socket: data: [ansistring VIEW -lf 1 $chunk]" set wrote_sock 0 } - + if {$wrote_sock && ![eof $sock]} { ################################################################################## #Re-enable channel read handler only if no waiting chunks - must process in order ################################################################################## if {![llength $input_chunks_waiting(stdin)]} { - fileevent stdin readable [list [namespace current]::toServer $sock] + chan event stdin readable [list [namespace current]::toServer $sock] } else { #after idle [list [namespace current]::toServer $sock] tailcall [namespace current]::toServer $sock } #################################################### - #fileevent stdin readable [list [namespace current]::toServer $sock] + #chan event stdin readable [list [namespace current]::toServer $sock] } else { disconnect sock } @@ -642,24 +642,24 @@ namespace eval punk::basictelnet { variable encoding_guess variable debug variable fromserver_unprocessed - fileevent $sock readable {} + chan event $sock readable {} variable in_sb set chunksize 4096 ;#No choice of chunksize can avoid the possibility of splitting a token such as a Telnet protocol command or an ANSI sequence. #in theory, a split ANSI sequence won't cause a problem - except if we have debug on which could emit a request on stdout (e.g get_cursor_pos) - #as a byte oriented supposedly ascii-by-default protocol - we shouldn't expect to get utf-8 without having negotiated it - but it looks suspiciously like this is the sort of thing that happens (2024) review? Examples? mapscii.me 1984.ws? Test. + #as a byte oriented supposedly ascii-by-default protocol - we shouldn't expect to get utf-8 without having negotiated it - but it looks suspiciously like this is the sort of thing that happens (2024) review? Examples? mapscii.me 1984.ws? Test. #randomly chosen chunk boundaries - whether due to size or a combination of network speed and event scheduling can mean we get some utf8 characters split too. set last_unprocessed $fromserver_unprocessed - set data $fromserver_unprocessed + set data $fromserver_unprocessed set fromserver_unprocessed "" append data [read $sock $chunksize] #repeatedly appending when not fblocked - will somewhat reduce the risk of splitting both ANSI and TELNET commands - but at the cost of starving the output processing #somewhat conveniently? - the IAC \xFF byte is not valid in utf-8 or ascii - #this whole mechanism may need to be reviewed/modified if/when Telnet binary mode and/or charset changing is implemented/understood by the author. + #this whole mechanism may need to be reviewed/modified if/when Telnet binary mode and/or charset changing is implemented/understood by the author. #The current basic system is tested on the few available public telnet servers. - todo - test on some old industrial equipment, read more RFCs. - #for now we'll use punk::lib::get_utf8_leading as a hack way to determine if we should throw some trailing data aside for next loop to process? + #for now we'll use punk::lib::get_utf8_leading as a hack way to determine if we should throw some trailing data aside for next loop to process? #while {![fblocked $sock] && ![eof $sock]} { # add_debug "[a+ red bold]RE-READ[a]\n" stdin $sock @@ -685,16 +685,16 @@ namespace eval punk::basictelnet { } } - #mini debug buffer for each fromServer call - render using add_debug each loop + #mini debug buffer for each fromServer call - render using add_debug each loop set debug_info "" if {$debug} { #only do this text-processing work if debug is on append debug_info "------raw data [string length $data]---prev unprocessed:[string length $last_unprocessed]---" \n #append debug_info [ansistring VIEW -lf 1 -vt 1 [encoding convertfrom utf-8 $data]] \n - #set rawview [ansistring VIEW -lf 1 -vt 1 [encoding convertfrom $encoding_guess $data]] - set rawview [ansistring VIEW -lf 1 -vt 1 $data] - #set viewblock [overtype::left -wrap 1 -width 78 -height 4 "" $rawview] - set viewblock [overtype::renderspace -cp437 1 -wrap 1 -width 78 -height 4 "" $rawview] + #set rawview [ansistring VIEW -lf 1 -vt 1 [encoding convertfrom $encoding_guess $data]] + set rawview [ansistring VIEW -lf 1 -vt 1 $data] + #set viewblock [overtype::left -wrap 1 -width 78 -height 4 "" $rawview] + set viewblock [overtype::renderspace -cp437 1 -wrap 1 -width 78 -height 4 "" $rawview] set lines [split $viewblock \n] if {[llength $lines] > 4} { append debug_info [join [list {*}[lrange $lines 0 1] "...<[expr {[llength $lines] -4}] lines undisplayed>..." {*}[lrange $lines end-1 end]] \n] @@ -711,7 +711,7 @@ namespace eval punk::basictelnet { #--------------- #TODO - fix possible chunk boundary that gives us an incomplete IAC sequence. #As it stands - we won't properly handle it - possible it will cause intermittent telnet protocol bugs! - #will need a mechanism within protocol function and loop to abort and throw back to next fromServer event + #will need a mechanism within protocol function and loop to abort and throw back to next fromServer event #--------------- while 1 { if {!$in_sb} { @@ -732,20 +732,20 @@ namespace eval punk::basictelnet { if {$post_IAC_byte < "\xef"} { #?? #write \xf0$post_IAC_byte ;#from wiki code. purpose not understood. - puts stderr "unexpected - byte less than EF following IAC" + puts stderr "unexpected - byte less than EF following IAC" set data [string range $data $idx+1 end] incr idx } elseif {$post_IAC_byte == "\xff"} { #write \xf0 ;#?? This came from wiki code - intention unclear.. latin small letter Eth #RFC indicates double up of \xff is treated as literal - #this can't be part of utf-8 - + #this can't be part of utf-8 - puts -nonewline stdout \xff set data [string range $data $idx+2 end] incr idx 2 } else { incr idx 2 set ophex "" - #telnet commands are at least 2 bytes + #telnet commands are at least 2 bytes binary scan $post_IAC_byte H2 cmdhex switch -- $cmdhex { fb - fc - fd - fe { @@ -773,7 +773,7 @@ namespace eval punk::basictelnet { binary scan $opbyte H2 ophex } default { - + } } protocol $sock $cmdhex $ophex @@ -789,7 +789,7 @@ namespace eval punk::basictelnet { ff { #expecting SE next - but will pass to protocol as if it's the 'cmd' for handling/verification set expectedSE [string index $data 1] - binary scan $expectedSE H2 expectedSEhex + binary scan $expectedSE H2 expectedSEhex protocol $sock $expectedSEhex "" } default { @@ -826,14 +826,14 @@ namespace eval punk::basictelnet { puts -nonewline stdout [encoding convertfrom $encoding_guess $prefix] } else { set fromserver_unprocessed "" - #look for incomplete ansi sequences - #REVIEW - encoding ? - set ansisplits [punk::ansi::ta::split_codes_single $prefix] - set last_pt [lindex $ansisplits end] ;#last part is supposed to be plaintext - if it looks like it contains a partial ansi - throw it to fromserver_unprocessed for next fromServer call + #look for incomplete ansi sequences + #REVIEW - encoding ? + set ansisplits [punk::ansi::ta::split_codes_single $prefix] + set last_pt [lindex $ansisplits end] ;#last part is supposed to be plaintext - if it looks like it contains a partial ansi - throw it to fromserver_unprocessed for next fromServer call if {[string first "\x1b" $last_pt] >= 0} { set complete [join [lrange $ansisplits 0 end-1] ""] puts -nonewline stdout [encoding convertfrom $encoding_guess $complete] - set fromserver_unprocessed $last_pt + set fromserver_unprocessed $last_pt } else { puts -nonewline stdout [encoding convertfrom $encoding_guess $prefix] } @@ -872,24 +872,24 @@ namespace eval punk::basictelnet { - #after idle [list fileevent $sock readable [list [namespace current]::fromServer $sock]] + #after idle [list chan event $sock readable [list [namespace current]::fromServer $sock]] if {[string length $fromserver_unprocessed]} { #review - by throwing to another loop without waiting for readable event - we could spin on same data...? #after idle [list [namespace current]::fromServer $sock] - fileevent $sock readable [list [namespace current]::fromServer $sock] + chan event $sock readable [list [namespace current]::fromServer $sock] } else { - fileevent $sock readable [list [namespace current]::fromServer $sock] + chan event $sock readable [list [namespace current]::fromServer $sock] } } proc disconnect {sock} { variable closed puts stdout "local disconnect" - catch {fileevent $sock readable {}} + catch {chan event $sock readable {}} catch {close $sock} set closed($sock) 1 - fileevent stdin readable {} + chan event stdin readable {} } proc write string { @@ -927,12 +927,12 @@ namespace eval punk::basictelnet { } proc protocol {sock cmdhex ophex} { variable in_sb - variable sb_state - variable optioncodes + variable sb_state + variable optioncodes variable respond_will_do variable respond_do_will variable client_option_state ;#WILLs - variable client_option_declined ;#WON'Ts - but only those that were actually requested by server - not our default won'ts + variable client_option_declined ;#WON'Ts - but only those that were actually requested by server - not our default won'ts variable server_option_state ;#DOs upvar 1 debug_info debug_info @@ -952,7 +952,7 @@ namespace eval punk::basictelnet { } flush stderr switch $cmdhex { - f0 {# SE - End of subnegoatiation parameters 240 + f0 {# SE - End of subnegoatiation parameters 240 #error to get when not in sb? puts stderr "Unexpected SE. We don't appear to be in SB!" flush stderr @@ -975,7 +975,7 @@ namespace eval punk::basictelnet { flush $sock } f7 {# EC - Erase Character 247 - write \u007f + write \u007f } f8 {# EL - Erase Line 248 write \u0019 @@ -989,7 +989,7 @@ namespace eval punk::basictelnet { if {[dict get $client_option_state $opdec] || [dict get $server_option_state $opdec]} { incr idx #action for many subnegotiations is SEND=1 or IS=0 - set actionbyte [string index $data $idx] + set actionbyte [string index $data $idx] set actiondec [scan $actionbyte %c] incr idx ;#for action switch -- $opdec { @@ -998,8 +998,8 @@ namespace eval punk::basictelnet { switch -- $actiondec { 0 { #IS - #we should only get these reports if status is in our DO list - #keep in_sb as 1 and initialise sb_state + #we should only get these reports if status is in our DO list + #keep in_sb as 1 and initialise sb_state dict set sb_state opdec $opdec dict set sb_state actiondec 0 dict set sb_state data [dict create] @@ -1009,7 +1009,7 @@ namespace eval punk::basictelnet { #we should only get a request to send status if it is in our WILL list #expect the IAC SE to immediately follow if {[string range $data $idx $idx+1] ne "\xff\xf0"} { - error "malformed send status request" + error "malformed send status request" } incr idx 2 if {![dict get $client_option_state $opdec]} { @@ -1054,8 +1054,8 @@ namespace eval punk::basictelnet { switch -- $actiondec { 0 { #IS - #we should only get these reports if status is in our DO list - #as maximum + #we should only get these reports if status is in our DO list + #as maximum set nextSE [string first \xff\xf0 $data] if {$nextSE > 0} { set remote_terminal_type [string range $data $idx $nextSE-1] @@ -1064,7 +1064,7 @@ namespace eval punk::basictelnet { #could presumably happen.. todo error "didn't receive terminal-type in single chunk - review code" } - ##keep in_sb as 1 and initialise sb_state + ##keep in_sb as 1 and initialise sb_state #dict set sb_state opdec $opdec #dict set sb_state actiondec 0 #dict set sb_state data [dict create] @@ -1074,7 +1074,7 @@ namespace eval punk::basictelnet { #we should only get a request to send status if it is in our WILL list #expect the IAC SE to immediately follow if {[string range $data $idx $idx+1] ne "\xff\xf0"} { - error "malformed send status request" + error "malformed send status request" } incr idx 2 if {![dict get $client_option_state $opdec]} { @@ -1099,7 +1099,7 @@ namespace eval punk::basictelnet { } default { #if we've responded positively to supporting the option - it should have a switch-arm here - error "No switch handler for option '$opdec' [dict get $optioncodes $opdec]" + error "No switch handler for option '$opdec' [dict get $optioncodes $opdec]" } } } else { @@ -1108,7 +1108,7 @@ namespace eval punk::basictelnet { #todo - ignore? #we shouldn't get here if we are properly in sync with a well-behaved partner #if we do however.. we need to either abort immediately.. or ignore the subnegotiation by skipping ahead to SE as it may not even be an SB structure we understand. - #let's try the ignore option first.. + #let's try the ignore option first.. set next_SE [string first \xff\xf0 $data] if {$next_SE >=0} { set idx [expr {$next_SE +2}] @@ -1123,9 +1123,9 @@ namespace eval punk::basictelnet { variable respond_will_do set byte [string index $data $idx] if {$opdec in $respond_will_do} { - if {[dict get $server_option_state $opdec]} { - #already known DO - } else { + if {[dict get $server_option_state $opdec]} { + #already known DO + } else { append debug_info ">>>responding to server WILL declaration. DO $opdec [dict get $optioncodes $opdec]<<<" \n puts -nonewline $sock \xff\xfd$byte ;#respond DO dict set server_option_state $opdec 1 @@ -1201,7 +1201,7 @@ namespace eval punk::basictelnet { dict for {opt state} $server_option_state { if {$state} { if {![dict exists $reported_state will $opt]} { - lappend mismatches [list server $opt reported DON'T stored DO] + lappend mismatches [list server $opt reported DON'T stored DO] } } else { if {[dict exists $reported_state will $opt]} { @@ -1251,7 +1251,7 @@ namespace eval punk::basictelnet { dict set sb_state data $existing_data ;#updated } } - } + } } } @@ -1271,14 +1271,14 @@ namespace eval punk::basictelnet::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::basictelnet::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 + # #[para]Description of utility1 + # return 1 #} @@ -1296,17 +1296,17 @@ namespace eval punk::basictelnet::lib { namespace eval punk::basictelnet::system { #*** !doctools #[subsection {Namespace punk::basictelnet::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::basictelnet [namespace eval punk::basictelnet { variable pkg punk::basictelnet variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/cap-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/cap-0.1.0.tm index 68d3252e..2ede3723 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/cap-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/cap-0.1.0.tm @@ -26,7 +26,7 @@ #[para]punk::cap provides management of named capabilities and the provider packages and handler packages that implement a pluggable capability. #[para]see also [uri https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/pluginmgr/pluginmgr.md {tcllib pluginmgr}] for an alternative which uses safe interpreters #[subsection Concepts] -#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API +#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API # #[para][term {capability handler}] - a package/namespace which may provide validation and standardised ways of looking up provider data # registered (or not) using register_capabilityname @@ -49,7 +49,7 @@ package require oolib # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::cap { - variable pkgcapsdeclared [tcl::dict::create] + variable pkgcapsdeclared [tcl::dict::create] variable pkgcapsaccepted [tcl::dict::create] variable caps [tcl::dict::create] namespace eval class { @@ -71,8 +71,8 @@ tcl::namespace::eval punk::cap { #*** !doctools #[call class::interface_caphandler.registry [method pkg_register] [arg pkg] [arg capname] [arg capdict] [arg fullcapabilitylist]] #handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid - #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. - return 1 ;#default to permit + #overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. + return 1 ;#default to permit } method pkg_unregister {pkg} { #*** !doctools @@ -106,9 +106,9 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.registration { #*** !doctools # [enum] CLASS [class interface_cappprovider.registration] - # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. + # [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. # [para]If your package namespace is mypackages::providerpkg then the object command would be at mypackages::providerpkg::capsystem::capprovider.registration - # [para]Example code for your provider package to evaluate within its namespace: + # [para]Example code for your provider package to evaluate within its namespace: # [example { #namespace eval capsystem { # if {[info commands capprovider.registration] eq ""} { @@ -133,7 +133,7 @@ tcl::namespace::eval punk::cap { #[para] This method must be overridden by your provider using oo::objdefine cappprovider.registration as in the example above. # There must be at least one 2-element list in the result for the provider to be registerable. #[para]The first element of the list is the capabilityname - which can be custom to your provider/handler packages - or a well-known name that other authors may use/implement. - #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. + #[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. error "interface_capprovider.registration not implemented by provider" } #*** !doctools @@ -142,11 +142,11 @@ tcl::namespace::eval punk::cap { oo::class create ::punk::cap::class::interface_capprovider.provider { #*** !doctools - # [enum] CLASS [class interface_capprovider.provider] - # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] + # [enum] CLASS [class interface_capprovider.provider] + # [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] # [example { - # namespace eval mypackages::providerpkg { - # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg + # namespace eval mypackages::providerpkg { + # punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg # } # }] # [list_begin definitions] @@ -229,7 +229,7 @@ tcl::namespace::eval punk::cap { #Not all capability names have to be registered. #A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated handler. - #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. + #such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. #we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. proc register_capabilityname {capname capnamespace} { #puts stderr "REGISTER_CAPABILITYNAME $capname $capnamespace" @@ -243,10 +243,10 @@ tcl::namespace::eval punk::cap { } } #allow register of existing capname iff there is no current handler - #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package - #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers + #as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package + #we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers if {[set hdlr [capability_get_handler $capname]] ne ""} { - puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" + puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" return } #assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. @@ -295,14 +295,14 @@ tcl::namespace::eval punk::cap { if {$count == 0} { set pkgposn [lsearch $providers $pkg] if {$pkgposn >= 0} { - set updated_providers [lreplace $providers $posn $posn] + set updated_providers [lreplace $providers $posn $posn] tcl::dict::set caps $capname providers $updated_providers } } } } - + } } proc capability_exists {capname} { @@ -328,7 +328,7 @@ tcl::namespace::eval punk::cap { if {[tcl::dict::exists $caps $capname]} { return [tcl::dict::get $caps $capname handler] } - return "" + return "" } proc call_handler {capname args} { if {[set handler [capability_get_handler $capname]] eq ""} { @@ -461,7 +461,7 @@ tcl::namespace::eval punk::cap { #todo! proc unregister_package {pkg {capname *}} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { set pkg [string range $pkg 2 end] @@ -471,7 +471,7 @@ tcl::namespace::eval punk::cap { set capabilitylist [dict get $pkgcapsdeclared $pkg] foreach c $capabilitylist { set do_unregister 1 - lassign $c capname _capdict + lassign $c capname _capdict set cap_info [dict get $caps $capname] set pkglist [dict get $cap_info providers] set posn [lsearch $pkglist $pkg] @@ -479,9 +479,9 @@ tcl::namespace::eval punk::cap { if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { #review # it seems not useful to allow the callback to block this unregister action - #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter - #vetoing unregister would make this more complex for no particular advantage - #if per dataset deregistration required this should probably be a separate thing + #the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter + #vetoing unregister would make this more complex for no particular advantage + #if per dataset deregistration required this should probably be a separate thing $capreg pkg_unregister $pkg $capname } set pkglist [lreplace $pkglist $posn $posn] @@ -510,7 +510,7 @@ tcl::namespace::eval punk::cap { } } proc pkgcaps {} { - variable pkgcapsdeclared + variable pkgcapsdeclared variable pkgcapsaccepted set result [dict create] foreach {pkg capsdeclared} $pkgcapsdeclared { @@ -522,7 +522,7 @@ tcl::namespace::eval punk::cap { dict set result $pkg accepted $accepted } return $result - } + } proc capability {capname} { variable caps @@ -565,14 +565,14 @@ tcl::namespace::eval punk::cap { #[subsection {Namespace punk::cap::advanced}] #[para] punk::cap::advanced API. Functions here are generally not the preferred way to interact with punk::cap. #[para] In some cases they may allow interaction in less safe ways or may allow use of features that are unavailable in the base namespace. - #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. + #[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. #[list_begin definitions] proc promote_provider {pkg} { #*** !doctools # [call advanced::[fun promote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. #[para] #[para] promote/demote doesn't always make a lot of sense .. should preferably be configurable per capapbility for multicap provider pkgs #[para]The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded @@ -615,7 +615,7 @@ tcl::namespace::eval punk::cap { #*** !doctools # [call advanced::[fun demote_provider] [arg pkg]] #[para]Move the named provider package to the preferred end of the list (tail). - #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. + #[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. variable pkgcapsdeclared variable caps if {[string match ::* $pkg]} { @@ -677,11 +677,11 @@ tcl::namespace::eval punk::cap { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap [namespace eval punk::cap { variable version variable pkg punk::cap - set version 0.1.0 + set version 0.1.0 variable README.md [string map [list %pkg% $pkg %ver% $version] { # punk capabilities system ## pkg: %pkg% version: %ver% diff --git a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/caphandler-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/caphandler-0.1.0.tm index 8fdce944..4a19666b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/caphandler-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/caphandler-0.1.0.tm @@ -43,10 +43,10 @@ namespace eval punk::cap::handlers::caphandler { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { variable pkg punk::cap::handlers::caphandler variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm index 5624ec58..60764f07 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/cap/handlers/templates-0.1.0.tm @@ -23,7 +23,7 @@ package require punk::repo # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #register using: -# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates +# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates #By convention and for consistency, we don't register here during package loading - but require the calling app to do it. # (even if it tends to be done immediately after package require anyway) @@ -67,11 +67,11 @@ namespace eval punk::cap::handlers::templates { #for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called - #for template pathtype absolute - we can do the same. - #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. + #for template pathtype absolute - we can do the same. + #There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. #adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time. - #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - + #not all template item types will need projectbase information - as the item data may be self-contained within the template structure - #but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly. switch -- $pathtype { adhoc { @@ -95,7 +95,7 @@ namespace eval punk::cap::handlers::templates { } else { set tm_exists [file exists $tmfile] } - if {![file exists $tmfile]} { + if {!$tm_exists} { puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" flush stderr return 0 @@ -128,7 +128,7 @@ namespace eval punk::cap::handlers::templates { } set extended_capdict $capdict - dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? + dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? } currentproject { if {[file pathtype $path] ne "relative"} { @@ -140,7 +140,7 @@ namespace eval punk::cap::handlers::templates { set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor } shellproject { if {[file pathtype $path] ne "relative"} { @@ -150,7 +150,7 @@ namespace eval punk::cap::handlers::templates { set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review set projectinfo [punk::repo::find_repos $shellbase] set projectbase [dict get $projectinfo closest] - + set extended_capdict $capdict dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase @@ -170,7 +170,7 @@ namespace eval punk::cap::handlers::templates { set projectbase [dict get $projectinfo closest] set extended_capdict $capdict - dict set extended_capdict vendor $vendor + dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } absolute { @@ -188,7 +188,7 @@ namespace eval punk::cap::handlers::templates { #todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder set extended_capdict $capdict - dict set extended_capdict resolved_path $normpath + dict set extended_capdict resolved_path $normpath dict set extended_capdict vendor $vendor dict set extended_capdict projectbase $projectbase } @@ -199,7 +199,7 @@ namespace eval punk::cap::handlers::templates { } # -- --- --- --- --- --- --- ---- --- - # update package internal data + # update package internal data # -- --- --- --- --- --- --- ---- --- upvar ::punk::cap::handlers::templates::provider_info_$cname provider_info @@ -208,13 +208,13 @@ namespace eval punk::cap::handlers::templates { } if {![info exists provider_info] || $extended_capdict ni [dict get $provider_info $pkg]} { #this checks for duplicates from the same provider - but not if other providers already added the path - #review - + #review - dict lappend provider_info $pkg $extended_capdict } # -- --- --- --- --- --- --- ---- --- - # instantiation of api at punk::cap::handlers::templates::api_$capname + # instantiation of api at punk::cap::handlers::templates::api_$capname # -- --- --- --- --- --- --- ---- --- set apicmd "::punk::cap::handlers::templates::api_$capname" if {[info commands $apicmd] eq ""} { @@ -227,12 +227,12 @@ namespace eval punk::cap::handlers::templates { upvar ::punk::cap::handlers::templates::handled_caps hcaps foreach capname $hcaps { set cname [string map {. _} $capname] - upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info + upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info dict unset my_provider_info $pkg #destroy api objects? } } - } + } } } @@ -293,7 +293,7 @@ namespace eval punk::cap::handlers::templates { set found_paths_absolute [list] - foreach pkg $providerpkg { + foreach pkg $providerpkg { set found_paths [list] #set acceptedlist [dict get [punk::cap::pkgcap $pkg $capabilityname] accepted] @@ -314,13 +314,13 @@ namespace eval punk::cap::handlers::templates { set module_projectroot [dict get $capdecl_extended projectbase] dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] } elseif {$pathtype eq "currentproject_multivendor"} { - set searchbase $startdir + set searchbase $startdir set pathinfo [punk::repo::find_repos $searchbase] set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { set deckbase [file join $pwd_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -349,7 +349,7 @@ namespace eval punk::cap::handlers::templates { } } } elseif {$pathtype eq "currentproject"} { - set searchbase $startdir + set searchbase $startdir set pathinfo [punk::repo::find_repos $searchbase] set pwd_projectroot [dict get $pathinfo closest] if {$pwd_projectroot ne ""} { @@ -369,7 +369,7 @@ namespace eval punk::cap::handlers::templates { if {$shell_projectroot ne ""} { set deckbase [file join $shell_projectroot $path] if {![file exists $deckbase]} { - continue + continue } #add vendor/x folders first - earlier in list is lower priority set vendorbase [file join $deckbase vendor] @@ -471,19 +471,19 @@ namespace eval punk::cap::handlers::templates { return $folderdict } method get_itemdict_projectlayouts {args} { - set argd [punk::args::get_dict { + set argd [punk::args::get_dict { @id -id "::punk::cap::handlers::templates::class::api get_itemdict_projectlayouts" @opts -anyopts 1 #peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here -startdir -default "" @values -maxvalues -1 - } $args] + } $args] set opt_startdir [dict get $argd opts -startdir] if {$opt_startdir eq ""} { set searchbase [pwd] } else { - set searchbase $opt_startdir + set searchbase $opt_startdir } set refdict [my get_itemdict_projectlayoutrefs {*}$args] @@ -502,7 +502,7 @@ namespace eval punk::cap::handlers::templates { # e.g ref may be @vendor+punks+othersample@sample-0.1 or layoutalias-1.1@vendor+punk+othersample@sample-0.1 #there must always be an @ before vendor or custom . There is either a template-name alias or empty string before this first @ #trim off first @ part - set tailats [join [lrange $atparts 1 end] @] + set tailats [join [lrange $atparts 1 end] @] # @ parts after the first are part of the path within the project_layouts structure set subpathlist [split $tailats +] if {[dict exists $refinfo sourceinfo projectbase]} { @@ -553,7 +553,7 @@ namespace eval punk::cap::handlers::templates { if {$vendor ne "_project"} { set itemname $vendor.$itemname } - return $itemname + return $itemname }}} } set arglist [concat $config $args] @@ -623,7 +623,7 @@ namespace eval punk::cap::handlers::templates { }}}\ -command_get_item_name {apply {{vendor basefolder itempath} { - set relativepath [punk::path::relative $basefolder $itempath] + set relativepath [punk::path::relative $basefolder $itempath] set dirs [file dirname $relativepath] if {$dirs eq "."} { set dirs "" @@ -636,7 +636,7 @@ namespace eval punk::cap::handlers::templates { } if {$vendor ne "_project"} { set tname ${vendor}.$tname - } + } return $tname }}} } @@ -645,11 +645,11 @@ namespace eval punk::cap::handlers::templates { } #shared algorithm for get_itemdict_* methods - #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search + #requires a -templatefolder_subdir indicating a directory within each template base folder in which to search #and a file selection mechanism command -command_get_items_from_base #and a name determining command -command_get_item_name method _get_itemdict {args} { - set argd [punk::args::get_dict { + set argd [punk::args::get_dict { @id -id "::punk::cap::handlers::templates::class::api _get_itemdict" @cmd -name _get_itemdict @opts -anyopts 0 @@ -657,7 +657,7 @@ namespace eval punk::cap::handlers::templates { -templatefolder_subdir -optional 0 -command_get_items_from_base -optional 0 -command_get_item_name -optional 0 - -not -default "" -multiple 1 + -not -default "" -multiple 1 @values -maxvalues -1 globsearches -default * -multiple 1 } $args] @@ -697,12 +697,12 @@ namespace eval punk::cap::handlers::templates { set items_here [dict create] ;#maintain a list keyed on name for sorting within this base only foreach itempath $matches { set itemname [{*}$opt_command_get_item_name $vendor $basefolder $itempath] - dict set items_here $itemname [list item $itempath baseinfo $baseinfo] + dict set items_here $itemname [list item $itempath baseinfo $baseinfo] #lappend items [list item $itempath baseinfo $baseinfo] } set ordered_names [lsort [dict keys $items_here]] - #add to the outer items list - foreach nm $ordered_names { + #add to the outer items list + foreach nm $ordered_names { set iteminfo [dict get $items_here $nm] lappend items [list originalname $nm iteminfo $iteminfo] } @@ -715,8 +715,8 @@ namespace eval punk::cap::handlers::templates { set itempath [dict get $iteminfo item] set baseinfo [dict get $iteminfo baseinfo] if {![dict exists $seen_dict $oname]} { - dict set seen_dict $oname 1 - dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number + dict set seen_dict $oname 1 + dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number } else { set n [dict get $seen_dict $oname] incr n @@ -730,7 +730,7 @@ namespace eval punk::cap::handlers::templates { set result [dict create] set keys [lreverse [dict keys $itemdict]] foreach k $keys { - set maybe "" + set maybe "" foreach g $globsearches { if {[string match $g $k]} { set maybe $k @@ -745,7 +745,7 @@ namespace eval punk::cap::handlers::templates { break } } - } + } if {$maybe ne "" && $not eq ""} { dict set result $k [dict get $itemdict $k] } @@ -762,10 +762,10 @@ namespace eval punk::cap::handlers::templates { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { variable pkg punk::cap::handlers::templates variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file diff --git a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm index 43dcd6b5..675f42b0 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/char-0.1.0.tm @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_punk::char 0 0.1.0] #[copyright "2024"] #[titledesc {character-set and unicode utilities}] [comment {-- Name section and table of contents description --}] -#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] +#[moddesc {character-set nad unicode}] [comment {-- Description at end of page heading --}] #[require punk::char] #[keywords module encodings] #[description] @@ -49,11 +49,11 @@ #*** !doctools #[item] [package {overtype}] -#[para] - +#[para] - #[item] [package {textblock}] -#[para] - +#[para] - #[item] [package console] -#[para] - +#[para] - package require Tcl 8.6- #dependency on tcllib not ideal for bootstrapping as punk::char is core to many features.. (textutil::wcswidth is therefore included in bootsupport/include_modules.config) review @@ -92,20 +92,20 @@ tcl::namespace::eval punk::char { #just the 7-bit ascii. use [page ascii] for the 8-bit layout proc ascii {} {return { 00 NUL 01 SOH 02 STX 03 ETX 04 EOT 05 ENQ 06 ACK 07 BEL - 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI + 08 BS 09 HT 0a LF 0b VT 0c FF 0d CR 0e SO 0f SI 10 DLE 11 DC1 12 DC2 13 DC3 14 DC4 15 NAK 16 SYN 17 ETB - 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US - 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' - 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / - 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 - 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? - 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G - 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O - 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W - 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ - 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g - 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o - 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w + 18 CAN 19 EM 1a SUB 1b ESC 1c FS 1d GS 1e RS 1f US + 20 SP 21 ! 22 " 23 # 24 $ 25 % 26 & 27 ' + 28 ( 29 ) 2a * 2b + 2c , 2d - 2e . 2f / + 30 0 31 1 32 2 33 3 34 4 35 5 36 6 37 7 + 38 8 39 9 3a : 3b ; 3c < 3d = 3e > 3f ? + 40 @ 41 A 42 B 43 C 44 D 45 E 46 F 47 G + 48 H 49 I 4a J 4b K 4c L 4d M 4e N 4f O + 50 P 51 Q 52 R 53 S 54 T 55 U 56 V 57 W + 58 X 59 Y 5a Z 5b [ 5c \ 5d ] 5e ^ 5f _ + 60 ` 61 a 62 b 63 c 64 d 65 e 66 f 67 g + 68 h 69 i 6a j 6b k 6c l 6d m 6e n 6f o + 70 p 71 q 72 r 73 s 74 t 75 u 76 v 77 w 78 x 79 y 7a z 7b { 7c | 7d } 7e ~ 7f DEL }} @@ -124,7 +124,7 @@ tcl::namespace::eval punk::char { } elseif {[tcl::string::length $v] == 0} { set v " " } - append out "$k $v " + append out "$k $v " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -143,7 +143,7 @@ tcl::namespace::eval punk::char { set out "" append out [page dingbats] \n set unicode_dict [charset_dictget Dingbats] - + append out " " set i 1 tcl::dict::for {k charinfo} $unicode_dict { @@ -155,7 +155,7 @@ tcl::namespace::eval punk::char { } else { set displayv $char } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % 8 == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -205,7 +205,7 @@ tcl::namespace::eval punk::char { tcl::dict::lappend d $encname $mname } } - } + } foreach enc [lsort $encnames] { set mime_enc [${encmimens}::mapencoding $enc] if {$mime_enc ne ""} { @@ -236,7 +236,7 @@ tcl::namespace::eval punk::char { tailcall page $encname {*}$args } - #This will not display for example, c0 glyphs for cp437 + #This will not display for example, c0 glyphs for cp437 # we could use the punk::ansi::cp437_map dict - but while that might be what some expect to see - it would probably be too much magic for this function - which is intended to align more with what Tcl's encoding convertfrom/to actually does. # for nonprinting members of the page, 2 and 3 letter codes are used rather than unicode visualisation replacements or even unicode equivalent replacements known to be appropriate for the page proc page {encname args} { @@ -255,7 +255,7 @@ tcl::namespace::eval punk::char { #set d_ascii [pagedict_raw ascii] set d_ascii [basedict] - set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi + set d_asciiposn [lreverse $d_ascii] ;#values should be unique except for "???". We are mainly interested in which ones have display-names e.g cr csi #The results of this are best seen by comparing the ebcdic and ascii pages set d_page [pagedict_raw $encname] @@ -285,7 +285,7 @@ tcl::namespace::eval punk::char { set displayv $bytedisplay } else { if {[tcl::string::length $rawchar] == 0} { - set displayv " " + set displayv " " } else { #presumed 1 set displayv " $rawchar " @@ -294,7 +294,7 @@ tcl::namespace::eval punk::char { } } - append out "$k $displayv " + append out "$k $displayv " if {$i > 0 && $i % $cols == 0} { set out [tcl::string::range $out 0 end-2] append out \n " " @@ -318,7 +318,7 @@ tcl::namespace::eval punk::char { set outchar [encoding convertfrom $encpage $ch] } else { #here we will use \0xFFFD instead of our replacement string ??? - as the name pagechar implies always returning a single character. REVIEW. - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -348,7 +348,7 @@ tcl::namespace::eval punk::char { #set outchar [encoding convertto $encpage [format %c $num]] set outchar [format %c $num] } else { - set outchar $::punk::char::invalid_display_char + set outchar $::punk::char::invalid_display_char } return $outchar } @@ -381,7 +381,7 @@ tcl::namespace::eval punk::char { } proc pagedict_raw {encname} { - variable invalid ;# ="???" + variable invalid ;# ="???" set encname [encname $encname] set d [tcl::dict::create] for {set i 0} {$i < 256} {incr i} { @@ -409,7 +409,7 @@ tcl::namespace::eval punk::char { tcl::dict::set d $k [tcl::dict::get $a128 $k] } else { # - tcl::dict::set d $k $invalid + tcl::dict::set d $k $invalid } if {$i <=32} { @@ -457,7 +457,7 @@ tcl::namespace::eval punk::char { } return $d } - + proc basedict {} { #this gives same result independent of current value of 'encoding system' set d [tcl::dict::create] @@ -529,10 +529,10 @@ tcl::namespace::eval punk::char { return $d } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- # encoding convertfrom & encoding convertto can be somewhat confusing to think about. (Need to think in reverse.) # e.g encoding convertto dingbats will output something that doesn't look dingbatty on screen. - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- #must use Tcl instead of tcl (at least for 8.6) if {![package vsatisfies [package present Tcl] 8.7-]} { proc encodable "s {enc [encoding system]}" { @@ -574,7 +574,7 @@ tcl::namespace::eval punk::char { } } } - #-- --- --- --- --- --- --- --- + #-- --- --- --- --- --- --- --- proc test_japanese {{encoding jis0208}} { #A very basic test of 2char encodings such as jis0208 set yatbun 日本 ;# encoding convertfrom jis0208 F|K\\ @@ -584,7 +584,7 @@ tcl::namespace::eval punk::char { set ebun [encoding convertto $encoding $bun] puts "$encoding encoded: ${eyat} ${ebun}" puts "reencoded: [encoding convertfrom $encoding $eyat] [encoding convertfrom $encoding $ebun]" - return $yatbun + return $yatbun } proc test_grave {} { set g [format %c 0x300] @@ -692,7 +692,7 @@ tcl::namespace::eval punk::char { #ESC ( B ESC ) B ASCII Set #ESC ( 0 ESC ) 0 Special Graphics #ESC ( 1 ESC ) 1 Alternate Character ROM Standard Character Set - #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic + #ESC ( 2 ESC ) 2 Alternate Character ROM Special Graphic # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Unicode character sets - some hardcoded - some loadable from data files @@ -700,7 +700,7 @@ tcl::namespace::eval punk::char { variable charinfo [tcl::dict::create] variable charsets [tcl::dict::create] - + # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # Aggregate character sets (ones that pick various ranges from underlying unicode ranges) # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -741,7 +741,7 @@ tcl::namespace::eval punk::char { } # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- - # Unicode ranges + # Unicode ranges # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- tcl::dict::set charsets "greek" [list ranges [list {start 880 end 1023} {start 7936 end 8191}] description "Greek and Coptic" settype "other"] @@ -975,9 +975,9 @@ tcl::namespace::eval punk::char { variable charset_extents_rangenames ;# dict keyed on start,end pointing to list of 2-tuples {setname rangeindex_within_set} #build 2 indexes for each range.(charsets are not just unicode blocks so can have multiple ranges) #Note that a range could be as small as a single char (startpoint = endpoint) so there can be many ranges with same start and end if charsets use some of the same subsets. - #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict - #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key - #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key + #as each charset_extents_startpoins,charset_extents_endpoints is built - the associated range name and index is appended to the rangenames dict + #startpoints - key is startpoint of a range, value is list of endpoints one for each range starting at this startpoint-key + #endpoints - key is endpoint of a range, value is list of startpoints one for each range ending at this endpoint-key proc _build_charset_extents {} { variable charsets variable charset_extents_startpoints @@ -995,7 +995,7 @@ tcl::namespace::eval punk::char { set end [tcl::dict::get [lindex $ranges 0] end] if {![tcl::dict::exists $charset_extents_startpoints $start] || $end ni [tcl::dict::get $charset_extents_startpoints $start]} { #assertion if end wasn't in startpoits list - then start won't be in endpoints list - tcl::dict::lappend charset_extents_startpoints $start $end + tcl::dict::lappend charset_extents_startpoints $start $end tcl::dict::lappend charset_extents_endpoints $end $start } tcl::dict::lappend charset_extents_rangenames ${start},${end} [list $setname 1] @@ -1023,14 +1023,14 @@ tcl::namespace::eval punk::char { #no need to sort charset_extents_rangenames - lookup only done using dict methods return [tcl::dict::size $charset_extents_startpoints] } - _build_charset_extents ;#rebuilds for all charsets + _build_charset_extents ;#rebuilds for all charsets #nerdfonts are within the Private use E000 - F8FF range proc load_nerdfonts {} { variable charsets variable charinfo package require fileutil - set ver [package provide punk::char] + set ver [package provide punk::char] if {$ver ne ""} { set ifneeded [package ifneeded punk::char [package provide punk::char]] #puts stderr "punk::char ifneeded script: $ifneeded" @@ -1038,7 +1038,7 @@ tcl::namespace::eval punk::char { set basedir [file dirname [lindex $sourceinfo end]] } else { #review - will only work at package load time - set scr [info script] + set scr [info script] if {$scr eq ""} { error "load_nerdfonts unable to determine package folder" } @@ -1048,7 +1048,7 @@ tcl::namespace::eval punk::char { set fname [file join $pkg_data_dir nerd-fonts-glyph-list.txt] if {[file exists $fname]} { #puts stderr "load_nerdfonts loading $fname" - set data [fileutil::cat -translation binary $fname] + set data [fileutil::cat -translation binary $fname] set short_seen [tcl::dict::create] set current_set_range [tcl::dict::create] set filesets_loading [list] @@ -1066,7 +1066,7 @@ tcl::namespace::eval punk::char { dict unset charset $setname } set newrange [list start $dec end $dec] - tcl::dict::set current_set_range $setname $newrange + tcl::dict::set current_set_range $setname $newrange tcl::dict::set charsets $setname [list ranges [list $newrange] description "nerd fonts $rawsetname" settype "nerdfonts privateuse"] lappend filesets_loading $setname @@ -1080,13 +1080,13 @@ tcl::namespace::eval punk::char { #overwrite last ranges element set rangelist [lrange [tcl::dict::get $charsets $setname ranges] 0 end-1] lappend rangelist [tcl::dict::get $current_set_range $setname] - tcl::dict::set charsets $setname ranges $rangelist + tcl::dict::set charsets $setname ranges $rangelist } else { #new range for set tcl::dict::set current_set_range $setname start $dec tcl::dict::set current_set_range $setname end $dec set rangelist [tcl::dict::get $charsets $setname ranges] - lappend rangelist [tcl::dict::get $current_set_range $setname] + lappend rangelist [tcl::dict::get $current_set_range $setname] tcl::dict::set charsets $setname ranges $rangelist } @@ -1130,7 +1130,7 @@ tcl::namespace::eval punk::char { proc package_base {} { #assume punk::char is in .tm form and we can use the package provide statement to determine base location - #review + #review set pkgver [package present punk::char] set pkginfo [package ifneeded punk::char $pkgver] set tmfile [lindex $pkginfo end] @@ -1156,7 +1156,7 @@ tcl::namespace::eval punk::char { if {[tcl::dict::exists $dictValue {*}$keys]} { return [tcl::dict::get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } } @@ -1181,7 +1181,7 @@ tcl::namespace::eval punk::char { } puts "ok.. loading" set fd [open $file r] - fconfigure $fd -translation binary + chan configure $fd -translation binary set data [read $fd] close $fd set block_count 0 @@ -1193,7 +1193,7 @@ tcl::namespace::eval punk::char { if {[set pcolon [tcl::string::first ";" $ln]] > 0} { set lhs [tcl::string::trim [tcl::string::range $ln 0 $pcolon-1]] set name [tcl::string::trim [tcl::string::range $ln $pcolon+1 end]] - set lhsparts [split $lhs .] + set lhsparts [split $lhs .] set start [lindex $lhsparts 0] set end [lindex $lhsparts end] #puts "$start -> $end '$name'" @@ -1207,9 +1207,9 @@ tcl::namespace::eval punk::char { return $block_count } - #unicode scripts + #unicode scripts - #unicode UnicodeData.txt + #unicode UnicodeData.txt @@ -1225,8 +1225,8 @@ tcl::namespace::eval punk::char { # -- --- #A = Ambiguous - All characters that can be sometimes wide and sometimes narrow. (wide in east asian legacy sets, narrow in non-east asian usage) (private use chars considered ambiguous) #F = East Asian Full-width - #H = East Asian Half-width - #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na + #H = East Asian Half-width + #N = Not east Asian (Neutral) - all other characters. (do not occur in legacy East Asian character sets) - treated like Na #Na = East Asian Narrow - all other characters that are always narrow and have explicit full-width counterparts (e.g includes all of ASCII) #W = East Asian Wide - all other characters that are always wide (Occur only in the context of Eas Asian Typography) # -- --- @@ -1304,7 +1304,7 @@ tcl::namespace::eval punk::char { set initial_fields $known_fields if {"testwidth" ni $opt_fields} { if {"testwidth" ni $opt_except} { - lappend opt_except testwidth + lappend opt_except testwidth } } if {"char" ni $opt_fields} { @@ -1369,13 +1369,13 @@ tcl::namespace::eval punk::char { #testwidth is one of the main ones likely to be worthwhile excluding as querying the console via ansi takes time set existing_testwidth "" if {[tcl::dict::exists $charinfo $dec_char testwidth]} { - set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] + set existing_testwidth [tcl::dict::get $charinfo $dec_char testwidth] } if {$existing_testwidth eq ""} { #no cached data - do expensive cursor-position test (Note this might not be 100% reliable - terminals lie e.g if ansi escape sequence has set to wide printing.) set char [format %c $dec_char] set chwidth [char_info_testwidth $char] - + tcl::dict::set returninfo testwidth $chwidth #cache it. todo - -verify flag to force recalc in case font/terminal changed in some way? tcl::dict::set charinfo $dec_char testwidth $chwidth @@ -1387,10 +1387,10 @@ tcl::namespace::eval punk::char { set char [format %c $dec_char] tcl::dict::set returninfo char $char } - memberof { + memberof { #memberof takes in the order of a few hundred microseconds if a simple scan of all ranges is taken - possibly worthwhile caching/optimising #note that memberof is not just unicode blocks - but scripts and other non-contiguous sets consisting of multiple ranges - some of which may include ranges of a single character. (e.g WGL4) - #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. + #This means there probably isn't a really efficient means of calculating membership other than scanning all the defined ranges. #We could potentially populate it using a side-thread - but it seems reasonable to just cache result after first use here. #some efficiency could also be gained by pre-calculating the extents for each charset which isn't a simple unicode block. (and perhaps sorting by max char) set memberof [list] @@ -1435,7 +1435,7 @@ tcl::namespace::eval punk::char { set splen [tcl::dict::size $charset_extents_startpoints] set eplen [tcl::dict::size $charset_extents_endpoints] set s [lsearch -bisect -integer $skeys $dec] - set s_at_or_below [lrange $skeys 0 $s] + set s_at_or_below [lrange $skeys 0 $s] set e_of_s [list] foreach sk $s_at_or_below { lappend e_of_s {*}[tcl::dict::get $charset_extents_startpoints $sk] @@ -1472,16 +1472,16 @@ tcl::namespace::eval punk::char { set eps [list] } - + return [tcl::dict::create startpoints $splen endpoints $eplen midpoint [expr {floor($eplen/2)}] posn $e lhs_endpoints_to_check "[llength $reduced_endpoints]/[llength $e_of_s]=[llength $sps]ranges" rhs_startpoints_to_check "[llength $reduced_startpoints]/[llength $s_of_e]=[llength $eps]"] } #for just a few extra sets such as wgl4 and unicode blocks loaded - this gives e.g 5x + better performance than the simple search above, and up to twice as slow for tcl 8.6 #performance biased towards lower numbered characters (which is not too bad in the context of unicode) #todo - could be tuned to perform better at end by assuming a fairly even distribution of ranges - and so searching startpoint ranges first for items left of middle, endpoint ranges first for items right of middle - #review with scripts loaded and more defined ranges.. + #review with scripts loaded and more defined ranges.. #This algorithm supports arbitrary overlapping ranges and ranges with same start & endpoints #Should be much better than O(n) for n sets except for pathological case of member of all or nearly-all intervals ? - #review - compare with 'interval tree' algorithms. + #review - compare with 'interval tree' algorithms. proc char_info_dec_memberof {dec} { variable charset_extents_startpoints variable charset_extents_endpoints @@ -1563,7 +1563,7 @@ tcl::namespace::eval punk::char { set matchcount 0 foreach glob $and_globs { if {[tcl::string::match -nocase $glob $s] || [tcl::string::match -nocase $glob $d]} { - incr matchcount + incr matchcount } } if {$matchcount == [llength $and_globs]} { @@ -1595,12 +1595,12 @@ tcl::namespace::eval punk::char { } - #non-overlapping unicode blocks + #non-overlapping unicode blocks proc char_blocks {{name_or_glob *}} { variable charsets #todo - more efficient datastructures? if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { if {[tcl::dict::get $charsets $name_or_glob settype] eq "block"} { return [tcl::dict::create $name_or_glob [tcl::dict::get $charsets $name_or_glob]] @@ -1630,7 +1630,7 @@ tcl::namespace::eval punk::char { proc charset_names {{name_or_glob *}} { variable charsets if {![regexp {[?*]} $name_or_glob]} { - #no glob - just retrieve it + #no glob - just retrieve it if {[tcl::dict::exists $charsets $name_or_glob]} { return [list $name_or_glob] } @@ -1641,7 +1641,7 @@ tcl::namespace::eval punk::char { } } else { if {$name_or_glob eq "*"} { - return [lsort [tcl::dict::keys $charsets]] + return [lsort [tcl::dict::keys $charsets]] } #tcl::dict::keys $dict doesn't have option for case insensitive searches return [lsort [lsearch -all -inline -nocase [tcl::dict::keys $charsets] $name_or_glob]] @@ -1655,7 +1655,7 @@ tcl::namespace::eval punk::char { variable charsets #dictionary sorting of the keys is slow! - we should obviously store it in sorted order instead of sorting entire list on retrieval - or just sort results #set sortedkeys [lsort -increasing -dictionary [tcl::dict::keys $charsets]] ;#NOTE must use -dictionary to use -sorted flag below - set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] + set sortedkeys [lsort -increasing [tcl::dict::keys $charsets]] if {$namesearch eq "*"} { return $sortedkeys } @@ -1664,7 +1664,7 @@ tcl::namespace::eval punk::char { return [lsearch -all -inline -nocase $sortedkeys $namesearch] ;#no point using -sorted flag when -all is used } else { #return [lsearch -sorted -inline -nocase $sortedkeys $namesearch] ;#no globs - bails out earlier if -sorted? - return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs + return [lsearch -inline -nocase $sortedkeys $namesearch] ;#no globs } } proc charsets {{namesearch *}} { @@ -1738,7 +1738,7 @@ tcl::namespace::eval punk::char { set opt_ansi [tcl::dict::get $opts -ansi] set opt_lined [tcl::dict::get $opts -lined] # -- --- --- --- - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} if {$opt_ansi} { set a1 [a BLACK white bold] @@ -1768,7 +1768,7 @@ tcl::namespace::eval punk::char { } set i 1 append out \n $prefix $charsetname - append out \n + append out \n set marker_line $prefix set line $prefix @@ -1847,7 +1847,7 @@ tcl::namespace::eval punk::char { } else { set charset_dict [charset_dictget $charsetname] } - + set col_items_short [list] set col_items_desc [list] tcl::dict::for {k inf} $charset_dict { @@ -1873,7 +1873,7 @@ tcl::namespace::eval punk::char { return $out } - #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria + #use console cursor movements to test and cache the column-width of each char in the set of characters returned by the search criteria proc charset_calibrate {namesearch args} { variable charsets variable charinfo @@ -1909,7 +1909,7 @@ tcl::namespace::eval punk::char { set twidth [tcl::dict::get $charinfo $dec testwidth] } if {$twidth eq ""} { - #puts -nonewline stdout "." ;#this + #puts -nonewline stdout "." ;#this set width [char_info_testwidth $ch] ;#based on console test rather than unicode props tcl::dict::set charinfo $dec testwidth $width } else { @@ -1925,10 +1925,10 @@ tcl::namespace::eval punk::char { #maint warning - also in overtype! #intended for single grapheme - but will work for multiple - #cannot contain ansi or newlines + #cannot contain ansi or newlines #(a cache of ansifreestring_width calls - as these are quite regex heavy) #review - effective memory leak on longrunning programs if never cleared - #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner + #tradeoff in fragmenting cache and reducing efficiency vs ability to clear in a scoped manner proc grapheme_width_cached {ch {key ""}} { variable grapheme_widths #if key eq "*" - we won't be able to clear that cache individually. Perhaps that's ok @@ -1975,7 +1975,7 @@ tcl::namespace::eval punk::char { # - compare with wcswidth returning -1 for entire string containing such in python,perl proc wcswidth {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) #Tcl initial evaluation stack size is 2000 (? review) #REVIEW - when we cater for grapheme clusters - we can't just split the string at arbitrary points like this!! set chunksize 2000 @@ -1984,14 +1984,14 @@ tcl::namespace::eval punk::char { set startidx 0 set endidx [expr {$startidx + $chunksize -1}] for {set i 0} {$i < $chunks_required} {incr i} { - set chunk [tcl::string::range $string $startidx $endidx] + set chunk [tcl::string::range $string $startidx $endidx] set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] foreach c $codes { if {$c <= 255 && !($c < 31 || $c == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$c < 917504 || $c > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $c] @@ -2023,7 +2023,7 @@ tcl::namespace::eval punk::char { set graphemes [list] while {$i < [tcl::string::length $string]} { set aftercluster [tk::endOfCluster $string $i] - lappend graphemes [string range $string $i $aftercluster-1] + lappend graphemes [string range $string $i $aftercluster-1] set i $aftercluster } return $graphemes @@ -2052,15 +2052,15 @@ tcl::namespace::eval punk::char { } } incr width $gw - + #if {[string first \u200d $g] >=0} { - # incr width 2 + # incr width 2 #} else { # #other joiners??? # incr width [wcswidth_unclustered $g] #} } else { - incr width [wcswidth_unclustered $g] + incr width [wcswidth_unclustered $g] } set i $aftercluster } @@ -2071,8 +2071,8 @@ tcl::namespace::eval punk::char { scan $char %c dec if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - return 1 + #todo - compare with python or other lang wcwidth + return 1 } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars return [textutil::wcswidth_char $dec] ;#note textutil::wcswidth_char takes a decimal codepoint! @@ -2086,8 +2086,8 @@ tcl::namespace::eval punk::char { scan $c %c dec if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $dec] ;#takes decimal codepoint @@ -2105,7 +2105,7 @@ tcl::namespace::eval punk::char { # - compare with wcswidth returning -1 for entire string containing such in python,perl proc wcswidth_unclustered {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) + #..but - 'scan' is horrible for 400K+ (Tcl evaluation stack has to be reallocated/copied?) #Tcl initial evaluation stack size is 2000 (? review) #we can only split the string at arbitrary points like this because we are specifically dealing with input that has no clusters!. set chunksize 2000 @@ -2114,14 +2114,14 @@ tcl::namespace::eval punk::char { set startidx 0 set endidx [expr {$startidx + $chunksize -1}] for {set i 0} {$i < $chunks_required} {incr i} { - set chunk [tcl::string::range $string $startidx $endidx] + set chunk [tcl::string::range $string $startidx $endidx] set codes [scan $chunk [tcl::string::repeat %c [tcl::string::length $chunk]]] foreach dec $codes { if {$dec <= 255 && !($dec < 31 || $dec == 127)} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth - incr width + #todo - compare with python or other lang wcwidth + incr width } elseif {$dec < 917504 || $dec > 917631} { #TODO - various other joiners and non-printing chars set w [textutil::wcswidth_char $dec] @@ -2141,8 +2141,8 @@ tcl::namespace::eval punk::char { proc wcswidth0 {string} { #faster than textutil::wcswidth (at least for string up to a few K in length) - #..but - 'scan' is horrible for 400K+ - #TODO + #..but - 'scan' is horrible for 400K+ + #TODO set codes [scan $string [tcl::string::repeat %c [tcl::string::length $string]]] set width 0 foreach dec $codes { @@ -2150,9 +2150,9 @@ tcl::namespace::eval punk::char { if {$dec < 917504 || $dec > 917631} { if {$dec <= 255} { #review - non-printing ascii? why does textutil::wcswidth report 1 ?? - #todo - compare with python or other lang wcwidth + #todo - compare with python or other lang wcwidth if {!($dec < 31 || $dec == 127)} { - incr width + incr width } } else { #TODO - various other joiners and non-printing chars @@ -2179,11 +2179,11 @@ tcl::namespace::eval punk::char { #prerequisites - no ansi escapes - no newlines - utf8 encoding assumed #review - what about \r \t \b ? #NO processing of \b - already handled in ansi::printing_length which then calls this - #this version breaks string into sequences of ascii vs unicode + #this version breaks string into sequences of ascii vs unicode proc ansifreestring_width {text} { #caller responsible for calling ansistrip first if text may have ansi codes - and for ensuring no newlines #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2204,11 +2204,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] # -- --- --- --- --- --- --- @@ -2221,10 +2221,10 @@ tcl::namespace::eval punk::char { #for now - strip them out #ZWNJ \u200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u200b zero width space + #ZWSP \u200b zero width space #\uFFEFBOM/ ZWNBSP and others that should be zero width - #todo - work out proper way to mark/group zero width. + #todo - work out proper way to mark/group zero width. #set text [tcl::string::map [list \u200b "" \u200c "" \u200d "" \uFFEF ""] $text] set text [tcl::string::map [list \u200b "" \u200c "" \u200d ""] $text] @@ -2241,7 +2241,7 @@ tcl::namespace::eval punk::char { #c1 controls - first section of the Latin-1 Supplement block - all non-printable from a utf-8 perspective #some or all of these may have a visual representation in other encodings e.g cp855 seems to have 1 width for them all - #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here + #we are presuming that the text supplied has been converted from any other encoding to utf8 - so we don't need to handle that here #they should also be unlikely to be present in an ansi-free string (as is a precondition for use of this function) set text [regsub -all {[\u0080-\u009f]+} $text ""] @@ -2262,7 +2262,7 @@ tcl::namespace::eval punk::char { #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] #tcl pre 2023-11 - braced high unicode regexes don't work #fixed in bug-4ed788c618 2023-11 - #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + #set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only #maintain unicode as sequences - todo - scan for grapheme clusters #set uc_sequences [punk::ansi::ta::_perlish_split "(?:\[\u0100-\U10FFFF\])+" $text] @@ -2291,7 +2291,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2312,11 +2312,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #review @@ -2325,7 +2325,7 @@ tcl::namespace::eval punk::char { #ZWNJ \u0200c should also be zero length - but as a 'non' joiner - it should add zero to the length - #ZWSP \u0200b zero width space + #ZWSP \u0200b zero width space #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2343,10 +2343,10 @@ tcl::namespace::eval punk::char { } #review - wcswidth should detect these - set re_ascii_fullwidth {[\uFF01-\uFF5e]} + set re_ascii_fullwidth {[\uFF01-\uFF5e]} set doublewidth_char_count 0 - set zerowidth_char_count 0 + set zerowidth_char_count 0 #split just to get the standalone character widths - and then scan for other combiners (?) #review #set can_regex_high_unicode [tcl::string::match [regexp -all -inline {[\U80-\U0010FFFF]} \U0001F525] \U0001F525] @@ -2354,7 +2354,7 @@ tcl::namespace::eval punk::char { #fixed in bug-4ed788c618 2023-11 #set uc_sequences [regexp -all -inline -indices {[\u0100-\U10FFFF]} $text] #set uc_sequences [regexp -all -inline -indices "\[\u0100-\U10FFFF\]" $text] ;#e.g for string: \U0001f9d1abc\U001f525ab returns {0 0} {4 4} - set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only + set uc_chars [regexp -all -inline "\[\u0100-\U10FFFF\]" $text] ;#e.g return list of chars in range only foreach c $uc_chars { if {[regexp $re_ascii_fullwidth $c]} { incr doublewidth_char_count @@ -2364,12 +2364,12 @@ tcl::namespace::eval punk::char { # b)- textutil::wcswidth_char seems to be east-asian-width based - and not a reliable indicator of 'character cells taken by the character when printed to the terminal' despite this statement in tclllib docs. #(character width is a complex context-dependent topic) # c) by checking for a cached console testwidth first - we make this function less deterministic/repeatable depending on whether console tests have been run. - # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here + # d) Upstream caching of grapheme_width may also lock in a result from whatever method was first employed here #Despite all this - the mechanism is hoped to give best effort consistency for terminals - #further work needed for combining emojis etc - which can't be done in a per character loop + #further work needed for combining emojis etc - which can't be done in a per character loop #todo - see if wcswidth does any of this. It is very slow for strings that include mixed ascii/unicode - so perhaps we can use a perlish_split # to process sequences of unicode. - #- and the user has the option to test character sets first if terminal position reporting gives better results + #- and the user has the option to test character sets first if terminal position reporting gives better results if {[char_info_is_testwidth_cached $c]} { set width [char_info_testwidth_cached $c] } else { @@ -2378,7 +2378,7 @@ tcl::namespace::eval punk::char { set width [textutil::wcswidth_char [scan $c %c]] } if {$width == 0} { - incr zerowidth_char_count + incr zerowidth_char_count } elseif {$width == 2} { incr doublewidth_char_count } @@ -2395,7 +2395,7 @@ tcl::namespace::eval punk::char { #we can c0 control characters after or while processing ansi escapes. - #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) + #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" @@ -2416,11 +2416,11 @@ tcl::namespace::eval punk::char { #experiment to detect leading diacritics - but this isn't necessary - it's still zero-width - and if the user is splitting properly we shouldn't be getting a string with leading diacritics anyway #(leading combiners may display in terminal as mark on rightmost prompt char which is usually a space - but won't add width even then) - #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} + #set re_leading_diacritic {^(?:[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+)} #if {[regexp $re_leading_diacritic $text]} { - # set text " $text" + # set text " $text" #} - set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set text [regsub -all $re_diacritics $text ""] #we should only map control sequences to nothing after processing ones with length effects, such as \b (\x07f) or DEL \x1f @@ -2437,7 +2437,7 @@ tcl::namespace::eval punk::char { return [tcl::string::length $text] } - #slow when ascii mixed with unicode (but why?) + #slow when ascii mixed with unicode (but why?) return [punk::char::wcswidth $text] } #This shouldn't be called on text containing ansi codes! @@ -2516,11 +2516,11 @@ tcl::namespace::eval punk::char { return [format $fmt {*}$declist] } - #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) + #split into plaintext and runs of combiners (combining diacritical marks - not ZWJ or ZWJNJ) proc combiner_split {text} { #split into odd numbered list (or zero) in a similar way to punk::ansi::ta::_perlish_split # - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} + #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} set graphemes [list] if {[tcl::string::length $text] == 0} { return {} @@ -2528,12 +2528,12 @@ tcl::namespace::eval punk::char { set list [list] set start 0 set strlen [tcl::string::length $text] - #make sure our regexes aren't non-greedy - or we may not have exit condition for loop + #make sure our regexes aren't non-greedy - or we may not have exit condition for loop #review while {$start < $strlen && [regexp -start $start -indices -- {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} $text match]} { lassign $match matchStart matchEnd #puts "->start $start ->match $matchStart $matchEnd" - lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart $matchEnd] set start [expr {$matchEnd+1}] } lappend list [tcl::string::range $text $start end] @@ -2547,7 +2547,7 @@ tcl::namespace::eval punk::char { #This is difficult in Tcl without unicode property based Character Classes in the regex engine #review - this needs to be performant - it is used a lot by punk terminal/ansi features #todo - trie data structures for unicode? - #for now we can at least combine diacritics + #for now we can at least combine diacritics #should also handle the ZWJ (and the variation selectors? eg \uFE0F) character which should account for emoji clusters #Note - emoji cluster could be for example 11 code points/41 bytes (family emoji with skin tone modifiers for each member, 3 ZWJs) #This still leaves a whole class of clusters.. korean etc unhandled :/ @@ -2560,7 +2560,7 @@ tcl::namespace::eval punk::char { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] lappend graphemes [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2575,7 +2575,7 @@ tcl::namespace::eval punk::char { set combiner_decs [scan $combiners [tcl::string::repeat %c [tcl::string::length $combiners]]] lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] lappend graphemes {*}$pt_decs - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[scan [lindex $csplits end] [tcl::string::repeat %c [tcl::string::length [lindex $csplits end]]]] @@ -2592,7 +2592,7 @@ tcl::namespace::eval punk::char { lset pt_decs end [concat [lindex $pt_decs end] $combiner_decs] } lappend graphemes {*}$pt_decs - } + } return $graphemes } proc grapheme_split2 {text} { @@ -2601,7 +2601,7 @@ tcl::namespace::eval punk::char { foreach {pt combiners} [lrange $csplits 0 end-1] { set clist [split $pt ""] lappend graphemes {*}[lrange $clist 0 end-1] [tcl::string::cat [lindex $clist end] $combiners] - } + } #last csplit never has a combiner (_perlish_split style) - and may be empty - in which case we don't append it as a grapheme if {[lindex $csplits end] ne ""} { lappend graphemes {*}[split [lindex $csplits end] ""] @@ -2645,10 +2645,10 @@ tcl::namespace::eval punk::char { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::char [tcl::namespace::eval punk::char { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm index fbce0905..ac70e97b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/config-0.1.tm @@ -32,7 +32,7 @@ tcl::namespace::eval punk::config { if {$exename ne ""} { set exefolder [file dirname $exename] #default file logs to logs folder at same level as exe if writable, or empty string - set log_folder [file normalize $exefolder/../logs] + set log_folder [file normalize $exefolder/../logs] ;#~2ms #tcl::dict::set startup scriptlib $exefolder/scriptlib #tcl::dict::set startup apps $exefolder/../../punkapps 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 a8884746..a3f5d95c 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 @@ -777,13 +777,13 @@ namespace eval punk::console { set extension [lindex [split $waitvar($callid) -] 1] if {$extension eq ""} { puts "blank extension $waitvar($callid)" - puts "->[set $waitvar($callid]<-" + puts "->[set $waitvar($callid)]<-" } puts stderr "get_ansi_response_payload Extending timeout by $extension" after cancel $timeoutid($callid) set total_elapsed [expr {[clock millis] - $tslaunch($callid)}] set last_elapsed [expr {[clock millis] - $lastvwait}] - set remaining [expr {$remaining - $last_elapsed}] + set remaining [expr {$remaining - $last_elapsed}] if {$remaining < 0} {set remaining 0} set newtime [expr {$remaining + $extension}] set timeoutid($callid) [after $newtime [list set $waitvarname timedout]] @@ -797,7 +797,7 @@ namespace eval punk::console { } } } - #response handler automatically removes it's own chan event + #response handler automatically removes it's own chan event chan event $input readable {} ;#explicit remove anyway - review if {$waitvar($callid) ne "timedout"} { @@ -814,7 +814,7 @@ namespace eval punk::console { #it *might* be ok to restore entire state on an input channel #(it's not always on all channels - e.g stdout has -winsize which is read-only) #Safest to only restore what we think we've modified. - fconfigure $input -blocking [dict get $previous_input_state -blocking] + chan configure $input -blocking [dict get $previous_input_state -blocking] @@ -828,10 +828,10 @@ namespace eval punk::console { set prefixdata [string range $input_read {*}$prefix_indices] if {!$ignoreok && $prefixdata ne ""} { #puts stderr "Warning - get_ansi_response_payload read extra data at start - '[ansistring VIEW -lf 1 $prefixdata]' (responsedata=[ansistring VIEW -lf 1 $responsedata])" - lappend input_chunks_waiting($input) $prefixdata + lappend input_chunks_waiting($input) $prefixdata } - } else { - #timedout - or eof? + } else { + #timedout - or eof? if {!$ignoreok} { puts stderr "get_ansi_response_payload callid:$callid regex match '$capturingendregex' to input_read '[ansistring VIEW -lf 1 -vt 1 $input_read]' not found" lappend input_chunks_waiting($input) $input_read @@ -872,11 +872,11 @@ namespace eval punk::console { flush stdout #concat and supply to existing handler in single text block - review - #Note will only + #Note will only set waitingdata [join $input_chunks_waiting($input) ""] set input_chunks_waiting($input) [list] #after idle [list after 0 [list {*}$existing_handler $waitingdata]] - after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review + after idle [list {*}$existing_handler $waitingdata] ;#after 0 may be put ahead of events it shouldn't be - review unset waitingdata } else { #! todo? for now, emit a clue as to what's happening. @@ -942,7 +942,7 @@ namespace eval punk::console { #review - reading 1 byte at a time and repeatedly running the small capturing/completion regex seems a little inefficient... but we don't have a way to peek or put back chars (?) #review (we do have the punk::console::input_chunks_waiting($chan) array to cooperatively put back data - but this won't work for user scripts not aware of this) #review - timeout - what if terminal doesn't put data on stdin? error vs stderr report vs empty results - #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? + #review - Main loop may need to detect some terminal responses and store them for lookup instead-of or as-well-as this handler? #e.g what happens to mouse-events while user code is executing? #we may still need this handler if such a loop doesn't exist. proc ansi_response_handler_regex {chan callid endregex} { @@ -973,14 +973,14 @@ namespace eval punk::console { chan event $chan readable {} set waits($callid) ok } else { - # 30ms 16ms? + # 30ms 16ms? set tsnow [clock millis] set total_elapsed [expr {[set tslaunch($callid)] - $tsnow}] set last_elapsed [expr {[set tsclock($callid)] - $tsnow}] if {[string length $chunks($callid)] % 10 == 0 || $last_elapsed > 16} { if {$total_elapsed > 3000} { #REVIEW - #too long since initial read handler launched.. + #too long since initial read handler launched.. #is other data being pumped into stdin? Eventloop starvation? Did we miss our codes? #For now we'll stop extending the timeout. after cancel $::punk::console::ansi_response_timeoutid($callid) @@ -1009,7 +1009,7 @@ namespace eval punk::console { chan event $chan readable {} # Something else puts stderr "ansi_response_handler_regex Situation shouldn't be possible. No error and no bytes read on channel $chan but not chan blocked or EOF" - set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof + set waits($callid) error_unknown_zerobytes_while_not_blocked_or_eof } } } ;#end namespace eval internal @@ -1034,7 +1034,7 @@ namespace eval punk::console { if {$ansi_wanted <= 0} { return } - #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here + #a and a+ are called a *lot* - avoid even slight overhead of tailcall as it doesn't give us anything useful here #tailcall punk::ansi::a+ {*}$args ::punk::ansi::a+ {*}$args } @@ -1092,7 +1092,7 @@ namespace eval punk::console { } default { set ansi_wanted 2 - } + } default { error "punk::console::ansi expected 0|1|on|off|true|false|yes|no|default" } @@ -1133,9 +1133,9 @@ namespace eval punk::console { } #test - find a better place to set terminal type - variable is_vt52 0 + variable is_vt52 0 proc vt52 {{onoff {}}} { - #todo - return to colour state beforehand?. support 0-15 vt52 colours? + #todo - return to colour state beforehand?. support 0-15 vt52 colours? #we shouldn't have to trun off colour to enter vt52 - we should make punk::console emit correct codes variable is_vt52 if {$onoff eq ""} { @@ -1146,7 +1146,7 @@ namespace eval punk::console { } if {$is_vt52} { if {!$onoff} { - puts -nonewline "\x1b<" + puts -nonewline "\x1b<" set is_vt52 0 colour on } @@ -1156,7 +1156,7 @@ namespace eval punk::console { set is_vt52 1 colour off } else { - puts -nonewline "\x1b<" + puts -nonewline "\x1b<" #emit even though our is_vt52 flag thinks it's on. Should be harmless if underlying terminal already vt100+ } } @@ -1222,10 +1222,10 @@ namespace eval punk::console { return $onoff } else { if {$onoff} { - {*}[auto_execok stty] echo + {*}[auto_execok stty] echo return 1 } else { - {*}[auto_execok stty] -echo + {*}[auto_execok stty] -echo return 0 } } @@ -1259,7 +1259,7 @@ namespace eval punk::console { set expected [dict get $opts -expected_ms] set capturingregex {(((.*)))$} ;#capture entire response same as response-payload - set ts_start [clock millis] + set ts_start [clock millis] set response [punk::console::internal::get_ansi_response_payload -ignoreok 1 -return dict -expected_ms $expected -terminal $inoutchannels $request $capturingregex] set ts_end [clock millis] puts stderr $response @@ -1273,7 +1273,7 @@ namespace eval punk::console { # -- --- --- --- --- --- --- #get_ansi_response functions - #review - can these functions sensibly be used on channels not attached to the local console? + #review - can these functions sensibly be used on channels not attached to the local console? #ie can we default to {stdin stdout} but allow other channel pairs? # -- --- --- --- --- --- --- proc get_cursor_pos {{inoutchannels {stdin stdout}}} { @@ -1284,13 +1284,13 @@ namespace eval punk::console { #e.g \033\[46;1R set capturingregex {(.*)(\x1b\[([0-9]+;[0-9]+)R)$} ;#must capture prefix,entire-response,response-payload - set request "\033\[6n" + set request "\033\[6n" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] #some terminals fail to respond properly to \x1b\[6n but do respond to \x1b\[?6n and vice-versa :/ - #todo - what? + #todo - what? #often terminals that fail will just put the raw request code on stdin - we could detect that and then #try the other? - + return $payload } proc get_checksum_rect {id page t l b r {inoutchannels {stdin stdout}}} { @@ -1333,7 +1333,7 @@ namespace eval punk::console { proc get_device_attributes {{inoutchannels {stdin stdout}}} { #DA1 variable last_da1_result - #first element in result is the terminal's architectural class 61,62,63,64.. ? + #first element in result is the terminal's architectural class 61,62,63,64.. ? #for vt100 we get things like: "ESC\[?1;0c" #for vt102 "ESC\[?6c" @@ -1368,7 +1368,7 @@ namespace eval punk::console { proc get_tabstops {{inoutchannels {stdin stdout}}} { #DECTABSR \x1b\[2\$w #response example " ^[P2$u9/17/25/33/41/49/57/65/73/81^[\ " (where ^[ is \x1b) - #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} + #set capturingregex {(.*)(\x1b\[P2$u()\x1b\[\\)} #set capturingregex {(.*)(\x1bP2$u((?:[0-9]+)*(?:\/[0-9]+)*)\x1b\\)$} set capturingregex {(.*)(\x1bP2\$u(.*)\x1b\\)$} set request "\x1b\[2\$w" @@ -1387,7 +1387,7 @@ namespace eval punk::console { #either terminal failed to report - or none set. set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } #We don't support none - default to 8 return 8 @@ -1397,7 +1397,7 @@ namespace eval punk::console { if {[llength $tslist] == 1} { set testw [test_char_width \t] if {[string is integer -strict $testw]} { - return $testw + return $testw } return 8 } else { @@ -1441,7 +1441,7 @@ namespace eval punk::console { set cell_size "" set cell_size_fallback 10x20 - #todo - change -inoutchannels to -terminalobject with prebuilt default + #todo - change -inoutchannels to -terminalobject with prebuilt default punk::args::define { @id -id ::punk::console::cell_size @@ -1450,7 +1450,7 @@ namespace eval punk::console { newsize -default "" -help\ "character cell pixel dimensions WxH or omit to query cell size." - } + } proc cell_size {args} { set argd [punk::args::get_by_id ::punk::console::cell_size $args] set inoutchannels [dict get $argd opts -inoutchannels] @@ -1462,11 +1462,11 @@ namespace eval punk::console { if {$cell_size eq ""} { #not set - try to query terminal's overall dimensions set pixeldict [punk::console::get_xterm_pixels $inoutchannels] - lassign $pixeldict _w sw _h sh + lassign $pixeldict _w sw _h sh if {[string is integer -strict $sw] && [string is integer -strict $sh]} { lassign [punk::console::get_size] _cols columns _rows rows #review - is returned size in pixels always a multiple of rows and cols? - set w [expr {$sw / $columns}] + set w [expr {$sw / $columns}] set h [expr {$sh / $rows}] set cell_size ${w}x${h} return $cell_size @@ -1511,7 +1511,7 @@ namespace eval punk::console { return [expr {$payload in {Z K M}}] } - #todo - determine cursor on/off state before the call to restore properly. + #todo - determine cursor on/off state before the call to restore properly. proc get_size {{inoutchannels {stdin stdout}}} { lassign $inoutchannels in out #we can't reliably use [chan names] for stdin,stdout. There could be stacked channels and they may have a names such as file22fb27fe810 @@ -1521,7 +1521,7 @@ namespace eval punk::console { } else { if {$is_eof} { error "punk::console::get_size eof on output channel $out ([info level 1])" - } + } } #we don't need to care about the input channel if chan configure on the output can give us the info. #short circuit ansi cursor movement method if chan configure supports the -winsize value @@ -1529,7 +1529,7 @@ namespace eval punk::console { if {[dict exists $outconf -winsize]} { #this mechanism is much faster than ansi cursor movements #REVIEW check if any x-platform anomalies with this method? - #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least + #can -winsize key exist but contain erroneous info? We will check that we get 2 ints at least lassign [dict get $outconf -winsize] cols lines if {[string is integer -strict $cols] && [string is integer -strict $lines]} { return [list columns $cols rows $lines] @@ -1542,7 +1542,7 @@ namespace eval punk::console { } else { if {$is_eof} { error "punk::console::get_size eof on input channel $in ([info level 1])" - } + } } #keep out of catch - no point in even trying a restore move if we can't get start position - just fail here. @@ -1565,7 +1565,7 @@ namespace eval punk::console { puts -nonewline $out [$func_coff][$movefunc 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols puts -nonewline $out [$movefunc $start_row $start_col][$func_con];flush stdout - set result [list columns $cols rows $lines] + set result [list columns $cols rows $lines] } errM]} { puts -nonewline $out [$movefunc $start_row $start_col] puts -nonewline $out [$func_con] @@ -1578,7 +1578,7 @@ namespace eval punk::console { #faster than get_size when it is using ansi mechanism - but uses cursor_save - which we may want to avoid if calling during another operation which uses cursor save/restore proc get_size_cursorrestore {{inoutchannels {stdin stdout}}} { lassign $inoutchannels in out - #we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly + #we use the same shortcircuit mechanism as get_size to avoid ansi at all if the output channel will give us the info directly set outconf [chan configure $out] if {[dict exists $outconf -winsize]} { lassign [dict get $outconf -winsize] cols lines @@ -1592,8 +1592,8 @@ namespace eval punk::console { #This issue also occurs when switching back from the alternate screen buffer - so perhaps that needs to be addressed elsewhere. puts -nonewline $out [punk::ansi::cursor_off][punk::ansi::cursor_save_dec][punk::ansi::move 2000 2000] lassign [get_cursor_pos_list $inoutchannels] lines cols - puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out - set result [list columns $cols rows $lines] + puts -nonewline $out [punk::ansi::cursor_restore][punk::console::cursor_on];flush $out + set result [list columns $cols rows $lines] } errM]} { puts -nonewline $out [punk::ansi::cursor_restore_dec] puts -nonewline $out [punk::ansi::cursor_on] @@ -1611,14 +1611,14 @@ namespace eval punk::console { set capturingregex {(.*)(\x1b\[8;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[18t" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] - lassign [split $payload {;}] rows cols + lassign [split $payload {;}] rows cols return [list columns $cols rows $rows] } proc get_xterm_pixels {{inoutchannels {stdin stdout}}} { set capturingregex {(.*)(\x1b\[4;([0-9]+;[0-9]+)t)$} ;#must capture prefix,entire-response,response-payload set request "\x1b\[14t" set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] - lassign [split $payload {;}] height width + lassign [split $payload {;}] height width return [list width $width height $height] } @@ -1629,7 +1629,7 @@ namespace eval punk::console { set payload [punk::console::internal::get_ansi_response_payload -terminal $inoutchannels $request $capturingregex] return $payload } - #Terminals generally default to LNM being reset (off) ie enter key sends a lone + #Terminals generally default to LNM being reset (off) ie enter key sends a lone #Terminals tested on windows either don't respond to this query, or respond with 0 (meaning mode not understood) #I presume from this that almost nobody is using LNM 1 (which sends both and ) proc get_mode_LNM {{inoutchannels {stdin stdout}}} { @@ -1689,7 +1689,7 @@ namespace eval punk::console { #terminals lie. This should be a reasonable (albeit relatively slow) test of actual width - but some terminals seem to miscalculate. #todo - a visual interactive test/questionnaire to ask user if things are lining up or if the terminal is telling fibs about cursor position. #todo - determine if these anomalies are independent of font - #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. + #punk::ansi should be able to glean widths from unicode data files - but this may be incomplete - todo - compare with what terminal actually does. #review - vertical movements (e.g /n /v will cause emit 0 to be ineffective - todo - disallow?) proc test_char_width {char_or_string {emit 0}} { #return 1 @@ -1797,7 +1797,7 @@ namespace eval punk::console { #don't set ansi_avaliable here - we want to be able to change things, retest etc. if {"windows" eq "$::tcl_platform(platform)"} { if {[package provide twapi] ne ""} { - set h_out [twapi::get_console_handle stdout] + set h_out [twapi::get_console_handle stdout] set existing_mode [twapi::GetConsoleMode $h_out] if {[expr {$existing_mode & 4}]} { #virtual terminal processing happens to be enabled - so it's supported @@ -1808,12 +1808,12 @@ namespace eval punk::console { #try temporarily setting it - if we get an error - ansi not supported if {[catch { - twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode | 4}] } errM]} { return 0 } #restore - twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] + twapi::SetConsoleMode $h_out [expr {$existing_mode & ~4}] return 1 } else { #todo - try a cursorpos query and read stdin to see if we got a response? @@ -1837,26 +1837,26 @@ namespace eval punk::console { set ansi_available [test_can_ansi] return $ansi_available } - return 1 + return 1 } - variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested + variable grapheme_cluster_support [dict create] ;#default empty dict for unknown/untested #todo - flag to retest? (for consoles where grapheme cluster support can be disabled e.g via decmode 2027) proc grapheme_cluster_support {} { variable grapheme_cluster_support if {[dict size $grapheme_cluster_support]} { - return $grapheme_cluster_support + return $grapheme_cluster_support } if {[info exists ::env(TERM_PROGRAM)]} { #terminals known to support grapheme clusters, but unable to respond to decmode request 2027 #wezterm (on windows as at 2024-12 decmode 2027 doesn't work) - #REVIEW - what if terminal is remote wezterm? can/will this env variable + #REVIEW - what if terminal is remote wezterm? can/will this env variable # iterm and apple terminal also set TERM_PROGRAM if {[string tolower $::env(TERM_PROGRAM)] in [list wezterm]} { set is_available 1 - return [dict create available 1 mode set] + return [dict create available 1 mode set] } } #where 1 = set, 2 = unset. (0 = mode not recognised, 3 = permanently set, 4 = permanently unset) @@ -1884,7 +1884,7 @@ namespace eval punk::console { set m "BAD_RESPONSE" } } - return [dict create available $is_available mode $m] + return [dict create available $is_available mode $m] } @@ -1947,7 +1947,7 @@ namespace eval punk::console { set was_raw 1 } puts -nonewline stdout \033\[6n ;flush stdout - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 set info [read stdin 20] ;# after 1 if {[string first "R" $info] <=0} { @@ -2015,8 +2015,8 @@ namespace eval punk::console { (aka: cursor home) The sequence emitted will depend on the mode of the - terminal as stored in the consolehandle. - Directly setting the mode via raw escape sequences: + terminal as stored in the consolehandle. + Directly setting the mode via raw escape sequences: e.g unset_mode DECANM for vt52 or puts \x1b< to return to ANSI will not necessarily update the application of @@ -2036,7 +2036,7 @@ namespace eval punk::console { This sequence will generally not be understood by terminals that are not in vt52 mode even if higher modes are supported. - + } @values -min 2 -max 2 row -type integer -help\ @@ -2045,7 +2045,7 @@ namespace eval punk::console { "column number - starting at 1" }] proc move {row col} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { return [punk::ansi::move $row $col] } else { @@ -2053,7 +2053,7 @@ namespace eval punk::console { } } proc move_forward {n} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_forward $n] } else { @@ -2061,7 +2061,7 @@ namespace eval punk::console { } } proc move_back {n} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_back $n] } else { @@ -2075,7 +2075,7 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::move_down $n] } proc move_column {col} { - upvar ::punk::console::is_vt52 is_vt52 + upvar ::punk::console::is_vt52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_column $col] } else { @@ -2086,7 +2086,7 @@ namespace eval punk::console { puts -nonewline stdout [punk::ansi::move_row $row] } proc move_emit {row col data args} { - upvar ::punk::console::is_v52 is_vt52 + upvar ::punk::console::is_v52 is_vt52 if {!$is_vt52} { puts -nonewline stdout [punk::ansi::move_emit $row $col $data {*}$args] } else { @@ -2226,7 +2226,7 @@ namespace eval punk::console { } proc titleset {windowtitle} { puts -nonewline stdout [punk::ansi::titleset $windowtitle] - } + } proc test_decaln {} { puts -nonewline stdout [punk::ansi::test_decaln] } @@ -2239,10 +2239,10 @@ namespace eval punk::console { if { $ansi_wanted <= 0} { punk::console::local::titleset $windowtitle } else { - ansi::titleset $windowtitle + ansi::titleset $windowtitle } } - #no known pure-ansi solution + #no known pure-ansi solution proc titleget {} { return [local::titleget] } @@ -2272,14 +2272,14 @@ namespace eval punk::console { #experimental proc rhs_prompt {col text} { package require textblock - lassign [textblock::size $text] _w tw _h th + lassign [textblock::size $text] _w tw _h th if {$th > 1} { #move up first.. need to know current line? } #set blanks [string repeat " " [expr {$col + $tw}]] #puts -nonewline [punk::ansi::erase_eol]$blanks;move_emit_return this $col $text #puts -nonewline [move_emit_return this $col [punk::ansi::insert_spaces 150]$text] - cursor_save_dec + cursor_save_dec #move_emit_return this $col [punk::ansi::move_forward 50][punk::ansi::insert_spaces 150][punk::ansi::move_back 50][punk::ansi::move_forward $col]$text #puts -nonewline [punk::ansi::insert_spaces 150][punk::ansi::move_column $col]$text puts -nonewline [punk::ansi::erase_eol][punk::ansi::move_column $col]$text @@ -2323,7 +2323,7 @@ namespace eval punk::console { 18 30 60 C0 60 30 18 00 00 00 7E 00 7E 00 00 00 60 30 18 0C 18 30 60 00 - 3C 66 0C 18 18 00 18 00 + 3C 66 0C 18 18 00 18 00 } #libungif extras append fontmap1 { @@ -2491,7 +2491,7 @@ namespace eval punk::console { #curses attr off reverse #a noreverse set reverse 0 - set output "" + set output "" set charno 0 foreach char [split $str {}] { binary scan $char c f @@ -2528,9 +2528,9 @@ namespace eval punk::console { } proc display {} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr [clock format [clock seconds] -format %H:%M:%S] 10 5] punk::console::move $orig_row $orig_col @@ -2539,9 +2539,9 @@ namespace eval punk::console { proc displaystr {str} { lassign [punk::console::get_cursor_pos_list] orig_row orig_col - punk::console::move 20 20 + punk::console::move 20 20 punk::console::clear_above - punk::console::move 0 0 + punk::console::move 0 0 puts -nonewline [bigstr $str 10 5] punk::console::move $orig_row $orig_col @@ -2571,13 +2571,13 @@ namespace eval punk::console { if {$dingbat_heavy_plus_width == 2} { set can_terminal_report_dingbat_width 1 } else { - puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." + puts stderr "punk::console warning: terminal either not displaying wide unicode as wide, or unable to report width properly." } set diacritic_width [punk::console::test_char_width a\u0300] if {$diacritic_width == 1} { set can_terminal_report_diacritic_width 1 } else { - puts stderr "punk::console warning: terminal unable to report diacritic width properly." + puts stderr "punk::console warning: terminal unable to report diacritic width properly." } if {$can_high_unicode && $can_regex_high_unicode && $can_terminal_report_dingbat_width && $can_terminal_report_diacritic_width} { @@ -2617,7 +2617,7 @@ namespace eval punk::console::check { } return $has_bug_legacysymbolwidth } - return 1 + return 1 } variable has_bug_zwsp -1 ;#undetermined proc has_bug_zwsp {} { 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 1f02859b..ca222524 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 @@ -9,7 +9,7 @@ # @@ Meta Begin # Application punk::fileline 0.1.0 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::fileline 0 0.1.0] #[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 --}] +#[moddesc {punk fileline}] [comment {-- Description at end of page heading --}] #[require punk::fileline] #[keywords module text parse file encoding BOM] #[description] @@ -33,7 +33,7 @@ #[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]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] @@ -42,13 +42,13 @@ # 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 +# 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]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. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -141,7 +141,7 @@ namespace eval punk::fileline::class { variable o_line_epoch variable o_payloadlist variable o_linemap - variable o_LF_C + variable o_LF_C variable o_CRLF_C @@ -158,7 +158,7 @@ namespace eval punk::fileline::class { #[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] - # fconfigure $fd -translation binary + # chan configure $fd -translation binary # set chunkdata [lb]read $fd[rb]] #or # set chunkdata [lb]fileutil::cat -translation binary[rb] @@ -191,7 +191,7 @@ namespace eval punk::fileline::class { set o_bom "" ;#review set o_chunk $datachunk - set o_line_epoch [list] + 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\ @@ -206,11 +206,11 @@ namespace eval punk::fileline::class { } } 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" @@ -261,7 +261,7 @@ namespace eval punk::fileline::class { #[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 + #[para] objName chunk 0 end return [string range $o_chunk $chunkstart $chunkend] } method chunklen {} { @@ -273,7 +273,7 @@ namespace eval punk::fileline::class { 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]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\ @@ -331,7 +331,7 @@ namespace eval punk::fileline::class { if {$opt_ansi} { set ::punk::fileline::ansi::enabled 1 } else { - set ::punk::fileline::ansi::enabled 0 + set ::punk::fileline::ansi::enabled 0 } if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { proc ::punk::fileline::a {args} { @@ -350,7 +350,7 @@ namespace eval punk::fileline::class { } proc ::punk::fileline::ansistrip {str} { if {$::punk::fileline::ansi::enabled} { - tailcall ::punk::fileline::ansi::ansistrip $str + tailcall ::punk::fileline::ansi::ansistrip $str } else { return $str } @@ -361,10 +361,10 @@ namespace eval punk::fileline::class { #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 + #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) " + 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] @@ -402,7 +402,7 @@ namespace eval punk::fileline::class { } else { set linebase $maxline } - set linebase ${sign}$linebase + set linebase ${sign}$linebase } elseif {[string match start* $tail]} { set endmath [string range $tail 5 end] if {[string length $endmath]} { @@ -489,7 +489,7 @@ namespace eval punk::fileline::class { 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 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] @@ -503,11 +503,11 @@ namespace eval punk::fileline::class { set e [dict get $lineinfo end] set boundarymarker "" - set displayidx "" + 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 [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] @@ -527,29 +527,29 @@ namespace eval punk::fileline::class { set linenum_display ${linenum_display},$idx } - set lhs_status $opt_cmark ;#default + 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 + set lhs_status $opt_tmark + set rhs_status $opt_tmark } elseif {"left" in $tside} { - set lhs_status $opt_tmark + set lhs_status $opt_tmark } elseif {"right" in $tside} { set rhs_status $opt_tmark } } else { - set line [my line $lineidx] + set line [my line $lineidx] } if {$displayidx ne ""} { - set line [string replace $line $displayidx $displayidx [a+ White green bold]$char_display[a]] + 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 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 *] @@ -586,12 +586,12 @@ namespace eval punk::fileline::class { 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]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 + 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] @@ -641,13 +641,13 @@ namespace eval punk::fileline::class { set opt_strategy [dict get $opts -strategy] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_start [dict get $opts -start] - set opt_start [expr {$opt_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 + set opt_end $max_line_index } #TODO if {$opt_end < $max_line_index} {error "-end less than max_line_index unimplemented"} @@ -705,7 +705,7 @@ namespace eval punk::fileline::class { #[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 + lassign [my numeric_linerange $lineindex 0] lineindex return [lindex $o_payloadlist $lineindex] } method linepayloads {startindex endindex} { @@ -722,17 +722,17 @@ namespace eval punk::fileline::class { #[list_begin itemized] #[item] le #[para] A string representing the type of line-ending: crlf|lf|none - #[item] linelen + #[item] linelen #[para] The number of characters/bytes in the whole line including line-ending if any - #[item] payloadlen + #[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 + #[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 + lassign [my numeric_linerange $lineindex 0] lineindex dict get $o_linemap $lineindex } method lineinfo {lineindex} { @@ -797,7 +797,7 @@ namespace eval punk::fileline::class { 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 + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set linestart -1 for {set i 0} {$i < [llength $o_payloadlist]} {incr i} { @@ -829,7 +829,7 @@ namespace eval punk::fileline::class { #[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 + lassign [my numeric_chunkrange $chunkstart $chunkend] chunkstart chunkend set defaults [dict create\ -show_truncated 0\ ] @@ -840,9 +840,9 @@ namespace eval punk::fileline::class { } } 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] @@ -878,8 +878,8 @@ namespace eval punk::fileline::class { 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 + dict set first truncated $truncated + dict set first truncatedleft $lhs } } ########################### @@ -908,7 +908,7 @@ namespace eval punk::fileline::class { if {$chunkend < [dict get $end_info end]} { #there is rhs truncation if {[dict get $first is_truncated]} { - dict set first truncatedside [list left right] + dict set first truncatedside [list left right] } else { dict set first is_truncated 1 dict set first truncatedside [list right] @@ -925,7 +925,7 @@ namespace eval punk::fileline::class { 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 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]} { @@ -971,13 +971,13 @@ namespace eval punk::fileline::class { set payload_and_le "${payload}${le_chars}" set split [expr {$chunkend - $line_start}] - set truncated [string range $payload_and_le 0 $split] + 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' + #this is a bit unintuitive - but probably best reflects the reality. The truncated value is the truncated 'line' rather than the truncated 'payload' } } @@ -991,7 +991,7 @@ namespace eval punk::fileline::class { ########################### #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. + #assertion If not opt_show_truncated - then truncated records will not have truncated,truncatedleft,truncatedright keys. return $infolist } @@ -1017,12 +1017,12 @@ namespace eval punk::fileline::class { #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 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. @@ -1035,7 +1035,7 @@ namespace eval punk::fileline::class { #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] } @@ -1061,13 +1061,13 @@ namespace eval punk::fileline::class { 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]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 + #[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 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] { @@ -1078,9 +1078,9 @@ namespace eval punk::fileline::class { set index $max } "*-*" { - #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions + #end-int or int-int - like lrange etc we don't accept arbitrarily complex expressions lassign [split $index -] A B - if {$A eq "end"} { + if {$A eq "end"} { set index [expr {$max - $B}] } else { set index [expr {$A - $B}] @@ -1088,7 +1088,7 @@ namespace eval punk::fileline::class { } "*+*" { lassign [split $index +] A B - if {$A eq "end"} { + 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}] @@ -1098,9 +1098,9 @@ namespace eval punk::fileline::class { } 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. + #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 + #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 } @@ -1109,13 +1109,13 @@ namespace eval punk::fileline::class { } } } - #Unlike Tcl lrange,lindex etc - we don't want to support out of bound indices. + #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" + 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)" + error "Bad end index '$original_endidx'. $endidx out of bounds 0 - $max (try $max or end)" } return [list $startidx $endidx] } @@ -1136,7 +1136,7 @@ namespace eval punk::fileline::class { 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 lf_lines [split $normalised_data $o_LF_C] set idx 0 set lf_count 0 @@ -1145,14 +1145,14 @@ namespace eval punk::fileline::class { set i 0 set imax [expr {[llength $lf_lines]-1}] foreach lfln $lf_lines { - set crlf_parts [split $lfln $o_CRLF_C] + 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 + #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 @@ -1177,7 +1177,7 @@ namespace eval punk::fileline::class { 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 filedata_offset $linelen incr crlf_count incr idx } @@ -1200,7 +1200,7 @@ namespace eval punk::fileline::class { set le lf } - lappend o_payloadlist $lfpart + 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 @@ -1221,8 +1221,11 @@ namespace eval punk::fileline::class { #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 + #??? + #set } @@ -1248,19 +1251,19 @@ namespace eval punk::fileline { #*** !doctools #[subsection {Namespace punk::fileline}] - #[para] Core API functions for punk::fileline + #[para] Core API functions for punk::fileline #[list_begin definitions] - punk::args::define { + 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 + -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]] @@ -1272,7 +1275,7 @@ namespace eval punk::fileline { #[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]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. @@ -1285,10 +1288,10 @@ namespace eval punk::fileline { # -- --- --- --- if {$opt_file ne ""} { - set filename $opt_file - set fd [open $filename r] - fconfigure $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 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]} { @@ -1335,7 +1338,7 @@ namespace eval punk::fileline { 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) + #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 @@ -1360,7 +1363,7 @@ namespace eval punk::fileline { set bomenc "binary" ;# utf-8??? set startdata 3 } elseif {$maybe_bom eq "84319533"} { - if {![dict exists [punk::char::page_names_dict gb18030]]} { + 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 { @@ -1374,7 +1377,7 @@ namespace eval punk::fileline { 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!" + 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 @@ -1433,7 +1436,7 @@ namespace eval punk::fileline { } 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]] @@ -1443,7 +1446,7 @@ namespace eval punk::fileline { #!? if {$bomenc eq "binary"} { set datachunk [string range $rawchunk $startdata end] - set encoding_selected binary + set encoding_selected binary } else { set datachunk [encoding convertfrom utf-8 [string range $rawchunk $startdata end]] set encoding_selected utf-8 @@ -1485,7 +1488,7 @@ namespace eval punk::fileline { proc file_boundary_display {filename startbyte endbyte chunksize args} { set fd [open $filename r] ;#use default error if file not readable - fconfigure $fd -translation binary + chan configure $fd -translation binary set rawfiledata [read $fd] close $fd set textobj [class::textinfo new $rawfiledata] @@ -1510,7 +1513,7 @@ namespace eval punk::fileline::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::fileline::lib}] - #[para] Secondary functions that are part of the API + #[para] Secondary functions that are part of the API #[list_begin definitions] @@ -1532,12 +1535,12 @@ namespace eval punk::fileline::lib { #[para]e.g #[example_begin] # range_spans_chunk_boundaries 10 1750 512 - # is_span 1 boundaries {512 1024 1536} + # is_span 1 boundaries {512 1024 1536} #[example_end] - #[para]The -offset option + #[para]The -offset option #[example_begin] # range_spans_chunk_boundaries 10 1750 512 -offset 2 - # is_span 1 boundaries {514 1026 1538} + # 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-}]} { @@ -1576,12 +1579,12 @@ namespace eval punk::fileline::lib { namespace eval punk::fileline::system { #*** !doctools #[subsection {Namespace punk::fileline::system}] - #[para] Internal functions that are not part of the API + #[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 + return [binary format S* $elements] ;#format big endian } proc wordswap32 {data} { binary scan $data i* elements @@ -1622,7 +1625,7 @@ namespace eval punk::fileline::system { 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 @@ -1632,7 +1635,7 @@ namespace eval punk::fileline::system { } else { set overflow 0 } - set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] + set boundaries [lmap v $boundaries[unset boundaries] {expr {$v + $opt_offset}}] if {$overflow} { #we don't know how many overflowed.. set inrange [list] @@ -1668,7 +1671,7 @@ namespace eval punk::fileline::system { set opt_offset [dict get $opts -offset] # -- --- --- --- - set is_span 0 + set is_span 0 set smod [expr {$start % $chunksize}] if {$smod != 0} { set start [expr {$start + ($chunksize - $smod)}] @@ -1681,7 +1684,7 @@ namespace eval punk::fileline::system { 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 + incr btrack $chunksize set boff [expr {$btrack + $opt_offset}] } set bstart $btrack @@ -1689,9 +1692,9 @@ namespace eval punk::fileline::system { set bstart $start } for {set b $bstart} {[set boff [expr {$b + $opt_offset}]] <= $end} {incr b $chunksize} { - lappend boundaries $boff - } - + lappend boundaries $boff + } + return [list is_span [expr {[llength $boundaries]>0}] boundaries $boundaries offset $opt_offset] } @@ -1707,7 +1710,7 @@ 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 + #[para]See [package punk::ansi] for documentation #[list_begin definitions] variable enabled 1 #*** !doctools @@ -1720,11 +1723,11 @@ namespace eval punk::fileline::ansi { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::fileline [namespace eval punk::fileline { variable pkg punk::fileline variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm index fe28d0a4..08174ca8 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/icomm-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin shellspy_module_punk::icomm 0 0.1.0] #[copyright "2025"] #[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] #[require punk::icomm] #[keywords module] #[description] @@ -107,7 +107,7 @@ package require punk::args # # Note that the actual code was changed in several places (Reordered, # eval speedup) -# +# # comm works just like Tk's send, except that it uses sockets. # These commands work just like "send" and "winfo interps": # @@ -116,7 +116,7 @@ package require punk::args # # See the manual page comm.n for further details on this package. -package require Tcl 8.6- +package require Tcl 8.6- package require snit ; # comm::future objects. namespace eval ::punk::icomm { @@ -196,7 +196,7 @@ namespace eval ::punk::icomm { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[subsection {Namespace punk::icomm}] - #[para] Core API functions for punk::icomm + #[para] Core API functions for punk::icomm #[list_begin definitions] variable PUNKARGS @@ -306,7 +306,7 @@ namespace eval ::punk::icomm { ## API: Setup async result generation for a remotely invoked command. # (future,fid,) -> list (future) - # (current,async) -> bool (default 0) + # (current,async) -> bool (default 0) # (current,state) -> list (chan fid cmd ser) proc comm_cmd_return_async {chan} { @@ -711,7 +711,6 @@ namespace eval ::punk::icomm { # # Results: # None. - proc commConfigure {chan {force 0} args} { variable comm @@ -876,9 +875,9 @@ namespace eval ::punk::icomm { ![string equal $encoding $comm($chan,encoding)]} { # This should not be entered yet set comm($chan,encoding) $encoding - fconfigure $comm($chan,socket) -encoding $encoding + chan configure $comm($chan,socket) -encoding $encoding foreach {i sock} [array get comm $chan,peers,*] { - fconfigure $sock -encoding $encoding + chan configure $sock -encoding $encoding } } @@ -891,7 +890,7 @@ namespace eval ::punk::icomm { #treat as always connected - call commIncoming imediately. punk::icomm::commIncoming $chan $comm($chan,tclchan) "localaddr" "localtclchan" return - } + } #------------------------- @@ -936,10 +935,10 @@ namespace eval ::punk::icomm { set nport [incr comm(lastport)] } set comm($chan,socket) $ret - fconfigure $ret -translation lf -encoding $comm($chan,encoding) + chan configure $ret -translation lf -encoding $comm($chan,encoding) # If port was 0, system allocated it for us - set comm($chan,port) [lindex [fconfigure $ret -sockname] 2] + set comm($chan,port) [lindex [chan configure $ret -sockname] 2] return "" } @@ -1090,8 +1089,8 @@ namespace eval ::punk::icomm { # coroutines to hide the CSP and properly handle everything # event based. - fconfigure $fid -blocking 0 - fileevent $fid readable [list ::punk::icomm::commIncomingOffered $chan $fid $addr $remport] + chan configure $fid -blocking 0 + chan event $fid readable [list ::punk::icomm::commIncomingOffered $chan $fid $addr $remport] return } @@ -1112,8 +1111,8 @@ namespace eval ::punk::icomm { # Protocol version line has been received, disable event handling # again. - fileevent $fid readable {} - fconfigure $fid -blocking 1 + chan event $fid readable {} + chan configure $fid -blocking 1 # a list of offered proto versions is the first word of first line # remote id is the second word of first line @@ -1133,7 +1132,7 @@ namespace eval ::punk::icomm { } if {![info exists vers]} { close $fid - if {[info exists comm($chan,silent)] && + if {[info exists comm($chan,silent)] && [string is true -strict $comm($chan,silent)]} { return } @@ -1144,7 +1143,7 @@ namespace eval ::punk::icomm { if {[dict exists $chanconf -sockname]} { # If the remote host addr isn't our local host addr, # then add it to the remote id. - if {[string equal [lindex [fconfigure $fid -sockname] 0] $addr]} { + if {[string equal [lindex [chan configure $fid -sockname] 0] $addr]} { set id $remid } else { set id [list $remid $addr] @@ -1216,8 +1215,8 @@ namespace eval ::punk::icomm { set comm($chan,peers,$id) $fid } set comm($chan,fids,$fid) $id - fconfigure $fid -translation lf -encoding $comm($chan,encoding) -blocking 0 - fileevent $fid readable [list ::punk::icomm::commCollect $chan $fid] + chan configure $fid -translation lf -encoding $comm($chan,encoding) -blocking 0 + chan event $fid readable [list ::punk::icomm::commCollect $chan $fid] } # ::punk::icomm::commLostConn -- @@ -1325,7 +1324,7 @@ namespace eval ::punk::icomm { # ::punk::icomm::commCollect -- # - # Internal command. Called from the fileevent to read from fid + # Internal command. Called from the chan event to read from fid # and append to the buffer. This continues until we get a whole # command, which we then invoke. # @@ -1344,9 +1343,9 @@ namespace eval ::punk::icomm { if {[catch {read $fid} nbuf] || [eof $fid]} { commDebug {puts stderr "<$chan> collect/lost eof $fid = [eof $fid]"} commDebug {puts stderr "<$chan> collect/lost nbuf = <$nbuf>"} - commDebug {puts stderr "<$chan> collect/lost [fconfigure $fid]"} + commDebug {puts stderr "<$chan> collect/lost [chan configure $fid]"} - fileevent $fid readable {} ;# be safe + chan event $fid readable {} ;# be safe commLostConn $chan $fid "target application died or connection lost" return } @@ -1382,7 +1381,7 @@ namespace eval ::punk::icomm { # Unpack the indices, then extract the word. #foreach {s e step} $cmdrange break lassign $cmdrange s e step - + set cmd [string range $data $s $e] commDebug {puts stderr "<$chan> cmd <$data>"} if {[string equal "" $cmd]} break @@ -1849,7 +1848,7 @@ namespace eval ::punk::icomm { # backslash-quoted braces we look for double-backslashes # as well and skip them. Without this a string like '{puts # \\}' will incorrectly find a \} at the end, missing the - # end of the word. + # end of the word. set re {((\\\\)|([{}])|(\\[{}]))} ;#split out for dumb editor to fix highlighting # ^^ ^ ^ # |\\ regular \quoted @@ -1996,7 +1995,7 @@ proc ::punk::icomm::initlocal {{tcpport 0}} { if {[string equal macintosh $::tcl_platform(platform)]} { ::punk::icomm::comm new ::punk::icomm::comm -port 0 -local 0 -listen 1 set ::punk::icomm::comm(localhost) \ - [lindex [fconfigure $::punk::icomm::comm(::punk::icomm::comm,socket) -sockname] 0] + [lindex [chan configure $::punk::icomm::comm(::punk::icomm::comm,socket) -sockname] 0] ::punk::icomm::comm config -local 1 } else { ::punk::icomm::comm new ::punk::icomm::comm -port 0 -local 1 -listen 1 @@ -2018,14 +2017,14 @@ tcl::namespace::eval punk::icomm::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::icomm::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 + # #[para]Description of utility1 + # return 1 #} @@ -2043,16 +2042,16 @@ tcl::namespace::eval punk::icomm::lib { #tcl::namespace::eval punk::icomm::system { #*** !doctools #[subsection {Namespace punk::icomm::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #} -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === tcl::namespace::eval punk::icomm { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase variable PUNKARGS @@ -2061,7 +2060,7 @@ tcl::namespace::eval punk::icomm { lappend PUNKARGS [list { @id -id "(package)punk::icomm" @package -name "punk::icomm" -help\ - "taken from tcllib comm package + "taken from tcllib comm package todo - describe changes" }] @@ -2076,7 +2075,7 @@ tcl::namespace::eval punk::icomm { set about_topics [list] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + 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] @@ -2084,11 +2083,11 @@ tcl::namespace::eval punk::icomm { proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::icomm + punk::args::lib::tstr [string trim { + package punk::icomm description to come.. } \n] } @@ -2122,9 +2121,9 @@ tcl::namespace::eval punk::icomm { # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] dict set overrides @id -id "::punk::icomm::about" - dict set overrides @cmd -name "punk::icomm::about" + dict set overrides @cmd -name "punk::icomm::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About punk::icomm + About punk::icomm }] \n] dict set overrides topic -choices [list {*}[punk::icomm::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 @@ -2140,7 +2139,7 @@ tcl::namespace::eval punk::icomm { } } # end of sample 'about' function -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # ----------------------------------------------------------------------------- @@ -2155,11 +2154,11 @@ namespace eval ::punk::args::register { # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::icomm [tcl::namespace::eval punk::icomm { variable pkg punk::icomm variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm index d41a947b..3cd3dfc6 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/imap4-0.9.tm @@ -91,7 +91,7 @@ #[manpage_begin shellspy_module_punk::imap4 0 0.9] #[copyright "2025"] #[titledesc {IMAP4 client}] [comment {-- Name section and table of contents description --}] -#[moddesc {IMAP4 client}] [comment {-- Description at end of page heading --}] +#[moddesc {IMAP4 client}] [comment {-- Description at end of page heading --}] #[require punk::imap4] #[keywords module mail imap imap4 client mailclient] #[description] @@ -110,8 +110,8 @@ tcl::namespace::eval punk::imap4 { #assert? - if argv0 exists and is same as [info script] - we're not in a safe interp #when running a tm module as an app - we should calculate the corresponding tm path #based on info script and the namespace of the package being provided here - #and add that to the tm list if not already present. - #(auto-cater for any colocated dependencies) + #and add that to the tm list if not already present. + #(auto-cater for any colocated dependencies) set scr [file normalize [info script]] set ns [namespace current] #puts "scr:--$scr--" @@ -220,7 +220,7 @@ tcl::namespace::eval punk::imap4::system { error "add_conlog side must be c or s" } if {$type ni {line literal chunk}} { - error "add_conlog type must be line literal or chunk" + error "add_conlog type must be line literal or chunk" } variable conlog set records [list] @@ -229,19 +229,19 @@ tcl::namespace::eval punk::imap4::system { } return [llength $datalist] } - proc get_conlog {chan {tag *}} { + proc get_conlog {chan {tag *}} { variable conlog if {$tag eq "*"} { return [dict get $conlog $chan] } else { - #retrieve + #retrieve set loglist [dict get $conlog $chan] #review - the relevant loglines should all be tagged with the 'request' key even if response line was a * return [lsearch -all -inline -index 3 $loglist $tag] #set result [list] #set first [lsearch -index 3 $loglist $tag] #if {$first > -1} { - # set last [lsearch -index 3 -start $first+1 $loglist $tag] + # set last [lsearch -index 3 -start $first+1 $loglist $tag] # if {$last > -1} { # set result [lrange $loglist $first $last] # } else { @@ -503,7 +503,7 @@ tcl::namespace::eval punk::imap4::proto { + { if {$lastcmd eq "IDLE"} { #todo - verify '+ idling' case? - set info($chan,idle) [clock seconds] + set info($chan,idle) [clock seconds] } else { #assert - can't happen } @@ -558,11 +558,11 @@ tcl::namespace::eval punk::imap4::proto { append line $buf # Check if there is a literal specified. - # It will always occur at the end of a line - followed by the data to read + # It will always occur at the end of a line - followed by the data to read if {[regexp {{([0-9]+)}\s*$} $buf => length]} { # puts "Reading $length bytes of literal..." set chunk [read $chan $length] - lappend literals $chunk + lappend literals $chunk #add_conlog $chan $side $type ::punk::imap4::system::add_conlog $chan s $request_tag literal [list [dict create length $length lines [llength [split $chunk \n]]]] if {[dict get $coninfo $chan debug]} { @@ -570,7 +570,7 @@ tcl::namespace::eval punk::imap4::proto { ::punk::imap4::system::add_conlog $chan s $request_tag chunk [list [list length $length chunk $chunk]] } } else { - #We are at the end of a single line, + #We are at the end of a single line, #or a sequence of 1 or more lines which had trailing literal specifiers {nnn} followed by data we have read. break } @@ -667,7 +667,7 @@ tcl::namespace::eval punk::imap4::proto { #If tag eq * - we could still have an OK not stripped from line above #e.g initial connection response - #REVIEW - + #REVIEW - if {!$dirty && $tag eq {*}} { switch -regexp -nocase -- $line { {^[0-9]+\s+EXISTS} { @@ -699,7 +699,7 @@ tcl::namespace::eval punk::imap4::proto { } {^METADATA} { #e.g - #* METADATA test1 ("/private/specialuse" NIL) + #* METADATA test1 ("/private/specialuse" NIL) # or #* METADATA Drafts ("/private/specialuse" {7} # \Drafts @@ -765,7 +765,7 @@ tcl::namespace::eval punk::imap4::proto { proc processmetadataline {chan request_tag line literals} { #our lines here have had the literals separated out #so we get complete lines where the literal acts as a placeholder - #e.g METADATA Junk ("/private/specialuse" {5}) + #e.g METADATA Junk ("/private/specialuse" {5}) puts stderr "processmetadataline: $line" set words [punk::imap4::lib::imapwords $line] set msgbox [dict get $words 1 value] @@ -785,7 +785,7 @@ tcl::namespace::eval punk::imap4::proto { lappend items $val } else { protoerror $chan "IMAP: METADATA malformed response ($lit mismatch size of literal [string length $val]) '$line'" - } + } } else { lappend items [dict get $wordinfo value] } @@ -793,7 +793,7 @@ tcl::namespace::eval punk::imap4::proto { puts stderr "msgbox: $msgbox items: $items" foreach {annotation val} $items { #todo -cache? where? - #folderinfo is for last LIST command + #folderinfo is for last LIST command # puts stderr "msgbox: $msgbox annotation: $annotation value: $val" } @@ -819,7 +819,7 @@ tcl::namespace::eval punk::imap4::proto { HEADER {string cat HEADER} RFC822.HEADER { #deprecated in rfc9051 - string cat RFC822.HEADER + string cat RFC822.HEADER } RFC822.TEXT { string cat RFC822.TEXT @@ -848,7 +848,7 @@ tcl::namespace::eval punk::imap4::proto { set nextcrlf [string first \r\n $val $startline] } lappend parts [string range $val $startline end] - + foreach f $parts { #RFC5322 - folding continuation lines cannot contain only white space @@ -989,10 +989,10 @@ tcl::namespace::eval punk::imap4::proto { # "HEADER.FIELD", "\Answered", "$Forwarded" #set pattern {([\w\.]+\[[^\[]+\]|[\w\.]+|[\\\$]\w+)} #some examples that should also match: - # BODY[] + # BODY[] # BODY[]<0.100> ;#first 100 bytes # BINARY.PEEK[1]<100.200> - set pattern {([\w\.]+\[[^\[]*\](?:\<[^\>]*\>)*|[\w\.]+|[\\\$]\w+)} + set pattern {([\w\.]+\[[^\[]*\](?:\<[^\>]*\>)*|[\w\.]+|[\\\$]\w+)} if {![regexp $pattern $data => match]} { protoerror $chan "IMAP data format error: '$data'" } @@ -1175,7 +1175,7 @@ tcl::namespace::eval punk::imap4 { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[subsection {Namespace punk::imap4}] - #[para] Core API functions for punk::imap4 + #[para] Core API functions for punk::imap4 #[list_begin definitions] variable PUNKARGS @@ -1189,7 +1189,7 @@ tcl::namespace::eval punk::imap4 { # Debug mode? Don't use it for production! It will print debugging # information to standard output and run a special IMAP debug mode shell # on protocol error. - #variable debug [dict create] + #variable debug [dict create] # Version variable version "2025-02-25" @@ -1197,7 +1197,7 @@ tcl::namespace::eval punk::imap4 { # This is where we take state of all the IMAP connections. # The following arrays are indexed with the connection channel # to access the per-channel information. - + ### client cached state array set folderinfo {} ;# list of folders. set mboxinfo [dict create] ;# selected mailbox info. @@ -1218,11 +1218,11 @@ tcl::namespace::eval punk::imap4 { "Connection security. TLS/SSL is recommended (implicit TLS). - If port is 143 and -security is omitted, then it will + If port is 143 and -security is omitted, then it will default to STARTTLS. For any other port, or omitted port, the default for -security is TLS/SSL. - ie if no channel security is wanted, then -security + ie if no channel security is wanted, then -security should be explicitly set to None." @values -min 1 -max 2 hostname -optional 0 -help\ @@ -1237,7 +1237,7 @@ tcl::namespace::eval punk::imap4 { port -optional 1 -type integer -help\ "Port to connect to. If port is omitted: - defaults to 143 when -security None or STARTTLS + defaults to 143 when -security None or STARTTLS defaults to 993 when -security TLS/SSL or -security is omitted." }] proc OPEN {args} { @@ -1276,11 +1276,11 @@ tcl::namespace::eval punk::imap4 { } } } else { - #port is specified and not 0 - set port $specified_port + #port is specified and not 0 + set port $specified_port if {$port == 143} { if {$opt_security eq "unspecified"} { - set opt_security STARTTLS + set opt_security STARTTLS } } else { #assume any other port is TLS/SSL by default if user didn't specify @@ -1294,7 +1294,7 @@ tcl::namespace::eval punk::imap4 { upvar ::punk::imap4::proto::info info upvar ::punk::imap4::proto::coninfo coninfo - #variable use_ssl + #variable use_ssl if {$opt_debug} { puts "I: open $address $port (SECURITY=$opt_security)" } @@ -1312,7 +1312,7 @@ tcl::namespace::eval punk::imap4 { # set chan [twapi::starttls $insecure_chan -peersubject mail.11email.com] # set connected 1 #} - if {!$connected} { + if {!$connected} { catch {package require tls} ;#review if {[info procs ::tls::socket] eq ""} { error "Package TLS must be loaded for STARTTLS connections." @@ -1329,7 +1329,7 @@ tcl::namespace::eval punk::imap4 { set chan $insecure_chan; #upgraded #processline $chan puts "--> [lastline $chan]" - #get new caps response? + #get new caps response? return $chan } else { puts stderr "STARTTLS failed" @@ -1345,7 +1345,7 @@ tcl::namespace::eval punk::imap4 { #implicit TLS - preferred set chan [::tls::socket $address $port] } - } + } chan configure $chan -translation binary dict set coninfo $chan [dict create hostname $address port $port debug $opt_debug security $opt_security] @@ -1392,22 +1392,22 @@ tcl::namespace::eval punk::imap4 { # is known as STARTTLS. # (implicit TLS on a dedicated port is the modern preference, # but this should be supported in the client API even if many servers - # move away from it) + # move away from it) proc STARTTLS {chan} { package require tls - #puts "Starting TLS" + #puts "Starting TLS" punk::imap4::proto::requirecaps $chan STARTTLS set clitag [punk::imap4::proto::request $chan STARTTLS] if {[punk::imap4::proto::getresponse $chan $clitag] != 0} { #puts "error sending STARTTLS" return 1 } - + #puts "TLS import" set chan [::tls::import $chan] #puts "TLS handshake" - + #tls::handshake #returns 0 if handshake still in progress (non-blocking) #returns 1 if handshake was successful @@ -1509,7 +1509,7 @@ tcl::namespace::eval punk::imap4 { } } } - append result + append result } return $result } @@ -1521,10 +1521,10 @@ tcl::namespace::eval punk::imap4 { #some headers have multipl values (SMTP traces) #also consider the somewhat contrived use of partials: # FETCH (BODY[]<0.100> BODY[]<0.10>) - #These are returned in the FETCH response as "BODY[]<0> {100}" and "BODY[]<0> {10}" + #These are returned in the FETCH response as "BODY[]<0> {100}" and "BODY[]<0> {10}" #This results in us having a msginfo key of "BODY[]<0>" with 2 values. # - + proc _set_msginfo_field {chan msgnum request_tag field value} { variable msginfo if {![dict exists $msginfo $chan $msgnum]} { @@ -1533,22 +1533,22 @@ tcl::namespace::eval punk::imap4 { set msgdata [dict get $msginfo $chan $msgnum] } if {![dict exists $msgdata $field]} { - set fieldinfo [dict create count 1 values [list $value] request $request_tag] + set fieldinfo [dict create count 1 values [list $value] request $request_tag] } else { #update field info for msgnum set prev_fieldinfo [dict get $msgdata $field] - set prev_request [dict get $prev_fieldinfo request] + set prev_request [dict get $prev_fieldinfo request] if {$prev_request ne $request_tag} { #new request - can overwrite set fieldinfo [dict create count 1 values [list $value] request $request_tag] } else { #same request - duplicate header/field e.g Received: header - we need to store all. - set fieldinfo $prev_fieldinfo + set fieldinfo $prev_fieldinfo dict incr fieldinfo count dict lappend fieldinfo values $value } } - dict set msgdata $field $fieldinfo + dict set msgdata $field $fieldinfo dict set msginfo $chan $msgnum $msgdata #set msginfo($chan,$msgnum,$field) $value } @@ -1570,7 +1570,7 @@ tcl::namespace::eval punk::imap4 { #no change to count or request fields dict set fieldinfo values $values - dict set msginfo $chan $msgnum $field $fieldinfo + dict set msginfo $chan $msgnum $field $fieldinfo #append msginfo($chan,$msgnum,$field) $value } @@ -1585,8 +1585,8 @@ tcl::namespace::eval punk::imap4 { for {set i 0} {$i < $count} {incr i} { append out "$msgseq $prop [lindex [dict get $propdata values] $i]" } - } - } + } + } return $out } @@ -1603,14 +1603,14 @@ tcl::namespace::eval punk::imap4 { "Login using the IMAP LOGIN command. " @leaders -min 1 -max 1 - chan -optional 0 + chan -optional 0 @opts -ignorestate -type none -help\ "Send the LOGIN even if protocol state is not appropriate" -ignorelogindisabled -type none -help\ "Ignore the LOGINDISABLED capability from the server and send LOGIN anyway. - (There should be no need to use this + (There should be no need to use this except for server testing purposes)" @values -min 2 -max 2 username @@ -1633,7 +1633,7 @@ tcl::namespace::eval punk::imap4 { } } if {!$opt_ignorestate} { - punk::imap4::proto::requirestate $chan NOAUTH + punk::imap4::proto::requirestate $chan NOAUTH } set rtag [punk::imap4::proto::request $chan "LOGIN $username $password"] if {[punk::imap4::proto::getresponse $chan $rtag] != 0} { @@ -1647,7 +1647,7 @@ tcl::namespace::eval punk::imap4 { @id -id ::punk::imap4::AUTH_PLAIN @cmd -name punk::imap4::AUTH_PLAIN -help\ "PLAIN SASL Authentication mechanism. - + This uses the 'initial response' to send the base64 encoded authzn authn password in the same line as AUTHENTICATE PLAIN. @@ -1657,17 +1657,17 @@ tcl::namespace::eval punk::imap4 { and the client sends the credentials after getting a continuation (+) from the server." @leaders -min 1 -max 1 - chan -optional 0 + chan -optional 0 @opts -ignorestate -type none -help\ "Send the AUTHENTICATE even if protocol state is not appropriate" -authorization -type string -default "" -help\ "authorization identity (identity to act as) - Usually it is not necessary to provide an + Usually it is not necessary to provide an authorization identity - as it will be derived - from the credentials. ie from the + from the credentials. ie from the 'authentication identity' which is the username. - " + " @values -min 2 -max 2 username -help\ "Authentication identity" @@ -1683,7 +1683,7 @@ tcl::namespace::eval punk::imap4 { if {$opt_ignorestate} { set allowstates * } else { - set allowstates NOAUTH + set allowstates NOAUTH } set username [dict get $values username] set password [dict get $values password] @@ -1738,7 +1738,7 @@ tcl::namespace::eval punk::imap4 { set rtag [punk::imap4::proto::request $chan "$cmd $mailbox"] if {[punk::imap4::proto::getresponse $chan $rtag] != 0} { #array set mboxinfo $savedmboxinfo - set info($chan,state) AUTH + set info($chan,state) AUTH return 1 } @@ -1869,7 +1869,7 @@ tcl::namespace::eval punk::imap4 { #todo "$" data-item ? foreach data_item $query_items { - set DATA_ITEM [string toupper $data_item] + set DATA_ITEM [string toupper $data_item] switch -- $DATA_ITEM { ALL - FAST - FULL {lappend items $DATA_ITEM} BODY - @@ -1974,7 +1974,7 @@ tcl::namespace::eval punk::imap4 { #based on assumed simple value queries such as specific properties and headers that are individually specified. set fetchresult [dict create] for {set i $start} {$i <= $end} {incr i} { - set flagdict [dict get $msginfo $chan $i] + set flagdict [dict get $msginfo $chan $i] #extract the fields that were added for this request_tag only dict for {f finfo} $flagdict { if {[dict get $finfo request] eq $request_tag} { @@ -1988,7 +1988,7 @@ tcl::namespace::eval punk::imap4 { #return $mailinfo set mailinfo {} - set fields [list] + set fields [list] #todo - something better foreach itm $items { if {$itm ni {ALL FAST FULL}} { @@ -1998,7 +1998,7 @@ tcl::namespace::eval punk::imap4 { #lappend fields {*}$hdrfields set fields [list {*}$fields {*}$hdrfields] for {set i $start} {$i <= $end} {incr i} { - set mailrec [list] + set mailrec [list] foreach {f} $fields { #lappend mailrec [msginfo $chan $i $f ""] set finfo [msginfo $chan $i $f ""] @@ -2144,7 +2144,7 @@ tcl::namespace::eval punk::imap4 { The cached results can be checked with the punk::imap4::has_capability command." @leaders -min 1 -max 1 - chan -optional 0 + chan -optional 0 @opts @values -min 0 -max 0 }] @@ -2176,7 +2176,7 @@ tcl::namespace::eval punk::imap4 { autologout timer on the server. " @leaders -min 1 -max 1 - chan -optional 0 + chan -optional 0 @opts @values -min 0 -max 0 }] @@ -2201,7 +2201,7 @@ tcl::namespace::eval punk::imap4 { return 1 } - #array set mboxinfo {} ;#JMN + #array set mboxinfo {} ;#JMN set mboxinfo [dict create] set info($chan,state) AUTH return 0 @@ -2233,7 +2233,7 @@ tcl::namespace::eval punk::imap4 { see also RFC3691 - IMAP UNSELECT command " @leaders -min 1 -max 1 - chan -optional 0 + chan -optional 0 @opts -ignorestate -type none -help\ "Send the UNSELECT even if protocol state is not appropriate" @@ -2260,14 +2260,14 @@ tcl::namespace::eval punk::imap4 { if {[punk::imap4::proto::simplecmd $chan UNSELECT {*}$allowstates {}]} { return 1 } - #array set mboxinfo {} ;#JMN + #array set mboxinfo {} ;#JMN set mboxinfo [dict create] set info($chan,state) AUTH return 0 } proc NAMESPACE {chan} { - punk::imap4::proto::simplecmd $chan NAMESPACE * + punk::imap4::proto::simplecmd $chan NAMESPACE * } # Create a new mailbox. @@ -2293,7 +2293,7 @@ tcl::namespace::eval punk::imap4 { #S: * METADATA "Foldername" (/private/specialuse {5} #S: \Junk #S: ) - #S: OK Completed + #S: OK Completed set annotation [string trim $annotation] if {![string match "/private/?*" $annotation] && ![string match "/shared/?*" $annotation]} { error "GETMETADATA annotation must begin with /shared/ or /private/" @@ -2306,10 +2306,10 @@ tcl::namespace::eval punk::imap4 { @cmd -name "punk::imap4::SETMETDATA" -help\ "Set metadata on mailbox" @leaders -min 1 -max 1 - chan + chan @opts @values -min 3 -max 3 - mailbox + mailbox annotation -choicerestricted 0 -choices { /private/specialuse /private/squat /private/sieve /private/sharedseen /private/comment /private/expire /private/news2mail /private/pop3showafter @@ -2363,7 +2363,7 @@ tcl::namespace::eval punk::imap4 { #TODO proc IDLE {chan} { if {[punk::imap4::prot::has_capability $chan IDLE]} { - punk::imap4::proto::simplecmd $chan IDLE {AUTH SELECT} + punk::imap4::proto::simplecmd $chan IDLE {AUTH SELECT} } else { error "IMAP SERVER has NOT advertised the capability IDLE." } @@ -2390,9 +2390,9 @@ tcl::namespace::eval punk::imap4 { @cmd -name "punk::imap4::FOLDERS" -help\ "List of folders" @leaders -min 1 -max 1 - chan + chan @opts - -ignorestate -type none + -ignorestate -type none -inline -type none @values -min 0 -max 2 ref -default "" @@ -2498,10 +2498,10 @@ tcl::namespace::eval punk::imap4 { "Debug mode. This is a developer mode that provides a basic REPL (Read Eval Print Loop) to interact more directly with the - server. + server. Every line entered is sent verbatim to the server (after the automatic addition of the request identifier/tag). - + It's possible to execute Tcl commands by starting the line with a forward slash." @leaders -min 0 -max 0 @@ -2542,7 +2542,7 @@ tcl::namespace::eval punk::imap4 { puts $l } - set prev_chan_debug [dict get $coninfo $chan debug] + set prev_chan_debug [dict get $coninfo $chan debug] dict set coninfo $chan debug 1 ;#ensure debug for this chan on while in debugmode @@ -2559,7 +2559,7 @@ tcl::namespace::eval punk::imap4 { gets stdin line if {![string length $line]} continue if {$line eq {!}} { - break + break } switch -glob -- $line { info { @@ -2670,7 +2670,7 @@ tcl::namespace::eval punk::imap4 { return 0 } - # Expunge : force removal of any messages with the + # Expunge : force removal of any messages with the # flag \Deleted proc EXPUNGE {chan} { if {[punk::imap4::proto::simplecmd $chan EXPUNGE SELECT {}]} { @@ -2744,6 +2744,61 @@ tcl::namespace::eval punk::imap4 { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::imap4::admin { + tcl::namespace::export {[a-zA-Z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + + lappend PUNKARGS [list { + @id -id "::punk::imap4::admin::GETQUOTA" + @cmd -name "punk::imap4::::admin::GETQUOTA" -help\ + "Get quota information" + @leaders -min 1 -max 1 + chan + @opts + @values -min 1 -max 1 + mailbox -help\ + "e.g user/account.test" + }] + proc GETQUOTA {args} { + set argd [punk::args::parse $args withid ::punk::imap4::admin::GETQUOTA] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + + punk::imap4::proto::simplecmd $chan GETQUOTA {AUTH SELECT} $mailbox + } + + lappend PUNKARGS [list { + @id -id "::punk::imap4::admin::SETQUOTARESOURCE" + @cmd -name "punk::imap4::admin::SETQUOTARESOURCE" -help\ + "Set quota for a resource" + @leaders -min 1 -max 1 + chan + @opts + -resource -default STORAGE -help\ + "This interface only allows setting of a single resource + at a time." + @values -min 2 -max 2 + mailbox -help\ + "e.g user/account.test" + quota -type integer -minsize 0 -help\ + "Number of 1024 Byte blocks + (KB)" + }] + proc SETQUOTARESOURCE {args} { + set argd [punk::args::parse $args withid ::punk::imap4::admin::SETQUOTARESOURCE] + lassign [dict values $argd] leaders opts values received + set chan [dict get $leaders chan] + set mailbox [dict get $values mailbox] + set resource [dict get $opts -resource] + set quota [dict get $values quota] + + punk::imap4::proto::simplecmd $chan SETQUOTA {AUTH SELECT} $mailbox "($resource $quota)" + } + +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace @@ -2756,21 +2811,21 @@ tcl::namespace::eval punk::imap4::lib { #*** !doctools #[subsection {Namespace punk::imap4::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 + # #[para]Description of utility1 + # return 1 #} #return 2 element list {address port} even if no port supplied. #port value 0 if not supplied proc parse_address_port {address_and_port} { #must handle ipv6 & ipv4 addresses with and without port - #as ipv6 needs square brackets to handle possible port + #as ipv6 needs square brackets to handle possible port # for symmetry we should support bracketed or unbracketed hostnames and ipv4 addresses too. #e.g for localhost [::1]:143 #e.g [1001:DF3:CF80::143] @@ -2784,7 +2839,7 @@ tcl::namespace::eval punk::imap4::lib { set address [string trim $address] ;#tolerate whitespace in brackets } else { set address $address_and_port - } + } set port 0 } 2 { @@ -2842,11 +2897,11 @@ tcl::namespace::eval punk::imap4::lib { # imapwords - a nonregex based parsing of IMAP command/response structures - # see also imaptotcl_ functions for alternative mechanism + # see also imaptotcl_ functions for alternative mechanism #consider what to do with partial lines due to literals: # * METADATA Drafts ("/private/specialuse" {7} #consider the following elements: - # BODY[] + # BODY[] # BODY[]<0.100> # BINARY.PEEK[1]<100.200> # we would categorise these as 'bare' initially - but switch to 'sectioned' at opening square bracket @@ -2870,7 +2925,7 @@ tcl::namespace::eval punk::imap4::lib { #set inbracket 0 #set inbrace 0 set words [dict create] - set w -1 + set w -1 set current "" set inesc 0 for {set i 0} {$i < $len} {incr i} { @@ -2906,28 +2961,28 @@ tcl::namespace::eval punk::imap4::lib { #) incr w set listnest 1 - set structure list + set structure list dict set words $w [dict create type list] } {[} { #] incr w set squarenest 1 - set structure squarelist + set structure squarelist dict set words $w [dict create type squarelist] } opencurly { incr w set structure literal dict set words $w [dict create type literal] - } + } default { incr w set structure bare dict set words $w [dict create type bare] ;#this is our initial assumption - may be converted to 'sectioned' later } } - #our resulting list retains the exact syntax of elements - ie keep openers and closers + #our resulting list retains the exact syntax of elements - ie keep openers and closers append current $c } } @@ -2938,7 +2993,7 @@ tcl::namespace::eval punk::imap4::lib { #assert not indq anyway set indq 0 if {![string is space $c]} { - if {$c eq "\["} { + if {$c eq "\["} { #not actually an atom.. set squarenest 1 dict set words $w type sectioned @@ -2958,7 +3013,7 @@ tcl::namespace::eval punk::imap4::lib { } squarelist { #square bracketed substructures e.g - #[PERMANENTFLAGS ()] + #[PERMANENTFLAGS ()] #[CAPABILITY IMAP4rev1 LITERAL+ ...] #It's not known if the protocol or extensions have any subelements that are themselves squarelists @@ -2973,8 +3028,8 @@ tcl::namespace::eval punk::imap4::lib { } else { #don't allow whitespace to terminate if {$c eq "\["} { - #not known if this is necessary, but if we encounter nested square brackets - we'll assume balanced and try to handle - incr squarenest + #not known if this is necessary, but if we encounter nested square brackets - we'll assume balanced and try to handle + incr squarenest append current $c } elseif {$c eq "\]"} { incr squarenest -1 @@ -3012,8 +3067,8 @@ tcl::namespace::eval punk::imap4::lib { if {$squarenest > 0} { #don't allow whitespace to terminate if {$c eq "\["} { - #not known if this is necessary, but if we encounter nested square brackets - we'll assume balanced and try to handle - incr squarenest + #not known if this is necessary, but if we encounter nested square brackets - we'll assume balanced and try to handle + incr squarenest } elseif {$c eq "\]"} { incr squarenest -1 } elseif {$c eq "\""} { @@ -3096,7 +3151,7 @@ tcl::namespace::eval punk::imap4::lib { } literal { #we are only catering for basic {nnn} where we expect nnn to be an integer byte count - #or {nnn+} + #or {nnn+} #Presumably these should be in quoted strings if in mailbox names, searches etc? REVIEW #\{ ;#editorfix set rc "\}" @@ -3128,7 +3183,7 @@ tcl::namespace::eval punk::imap4::lib { if {$lasttype ni {bare sectioned}} { #other type didn't terminate at end of line - mark as incomplete dict set words $lastindex error INCOMPLETE - } + } } } @@ -3163,14 +3218,14 @@ tcl::namespace::eval punk::imap4::lib { if {[dict size $words]} { return [dict get $words 0 value] } - return "" + return "" } proc secondword {line} { set words [imapwords $line 2] if {[dict size $words] > 1} { return [dict get $words 1 value] } - return "" + return "" } #*** !doctools @@ -3187,16 +3242,16 @@ tcl::namespace::eval punk::imap4::lib { #tcl::namespace::eval punk::imap4::system { #*** !doctools #[subsection {Namespace punk::imap4::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #} -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # Sample 'about' function with punk::args documentation -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === tcl::namespace::eval punk::imap4 { tcl::namespace::export {[a-zA-Z]*} ;# Convention: export all lowercase variable PUNKARGS @@ -3205,7 +3260,7 @@ tcl::namespace::eval punk::imap4 { lappend PUNKARGS [list { @id -id "(package)punk::imap4" @package -name "punk::imap4" -help\ - "Package + "Package Description" }] @@ -3220,7 +3275,7 @@ tcl::namespace::eval punk::imap4 { set about_topics [list] foreach f $topic_funs { set tail [namespace tail $f] - lappend about_topics [string range $tail [string length get_topic_] end] + 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] @@ -3228,11 +3283,11 @@ tcl::namespace::eval punk::imap4 { proc default_topics {} {return [list Description *]} # ------------------------------------------------------------- - # get_topic_ functions add more to auto-include in about topics + # get_topic_ functions add more to auto-include in about topics # ------------------------------------------------------------- proc get_topic_Description {} { - punk::args::lib::tstr [string trim { - package punk::imap4 + punk::args::lib::tstr [string trim { + package punk::imap4 A fork from tcllib imap4 module imap4 - imap client-side tcl implementation of imap protocol @@ -3266,9 +3321,9 @@ tcl::namespace::eval punk::imap4 { # we re-use the argument definition from punk::args::standard_about and override some items set overrides [dict create] dict set overrides @id -id "::punk::imap4::about" - dict set overrides @cmd -name "punk::imap4::about" + dict set overrides @cmd -name "punk::imap4::about" dict set overrides @cmd -help [string trim [punk::args::lib::tstr { - About punk::imap4 + About punk::imap4 }] \n] dict set overrides topic -choices [list {*}[punk::imap4::argdoc::about_topics] *] dict set overrides topic -choicerestricted 1 @@ -3284,7 +3339,7 @@ tcl::namespace::eval punk::imap4 { } } # end of sample 'about' function -# == === === === === === === === === === === === === === === +# == === === === === === === === === === === === === === === # ----------------------------------------------------------------------------- @@ -3294,16 +3349,16 @@ tcl::namespace::eval punk::imap4 { # variable PUNKARGS_aliases namespace eval ::punk::args::register { #use fully qualified so 8.6 doesn't find existing var in global namespace - lappend ::punk::args::register::NAMESPACES ::punk::imap4 ::punk::imap4::proto + lappend ::punk::args::register::NAMESPACES ::punk::imap4 ::punk::imap4::admin ::punk::imap4::proto } # ----------------------------------------------------------------------------- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::imap4 [tcl::namespace::eval punk::imap4 { variable pkg punk::imap4 variable version - set version 0.9 + set version 0.9 }] ################################################################################ @@ -3313,8 +3368,8 @@ if {[info script] eq $argv0} { #when running a tm module as an app - we should calculate the corresponding tm path #based on info script and the namespace of the package being provided here - #and add that to the tm list if not already present. - #(auto-cater for any colocated dependencies) + #and add that to the tm list if not already present. + #(auto-cater for any colocated dependencies) puts "--[info script]--" punk::args::define { @@ -3338,7 +3393,7 @@ if {[info script] eq $argv0} { 10.0.0.1:993 [::1]:143 " - user + user pass folder -optional 1 -default INBOX } @@ -3380,7 +3435,7 @@ if {[info script] eq $argv0} { set num_mails [punk::imap4::mboxinfo $imap exists] if {!$num_mails} { puts "No mail in folder '$folder'" - } else { + } else { set fields {from: to: subject: size} # fetch 3 records (at most)) inline set max [expr {$num_mails<=3?$num_mails:3}] @@ -3390,11 +3445,11 @@ if {[info script] eq $argv0} { puts "\t[lindex $fields $j] [lindex $rec $j]" } } - + # Show all the information available about the message ID 1 puts "Available info about message 1 => [punk::imap4::msginfo $imap 1]" } - + # Use the capability stuff puts "Capabilities: [punk::imap4::proto::has_capability $imap]" puts "Is able to imap4rev1? [punk::imap4::proto::has_capability $imap imap4rev1]" diff --git a/src/vfs/_vfscommon.vfs/modules/punk/jtest.tcl b/src/vfs/_vfscommon.vfs/modules/punk/jtest.tcl index 6379cfd9..2447100b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/jtest.tcl +++ b/src/vfs/_vfscommon.vfs/modules/punk/jtest.tcl @@ -41,4 +41,5 @@ defaultSilent 0 } #test - set x blah \ No newline at end of file + set x blah + diff --git a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm index 09a73385..b6c6dd4a 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/lib-0.1.1.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application punk::lib 0.1.1 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::lib 0 0.1.1] #[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 --}] +#[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]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 # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -34,7 +34,7 @@ #[section Overview] #[para] overview of punk::lib #[subsection Concepts] -#[para]The punk::lib modules should have no strong dependencies other than Tcl +#[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. @@ -108,7 +108,7 @@ tcl::namespace::eval punk::lib::ensemble { tcl::namespace::eval $extension [ list namespace ensemble create -command $routine -unknown [ list apply {{renamed ensemble routine args} { - list $renamed $routine + list $renamed $routine }} $renamed ] ] @@ -126,7 +126,7 @@ tcl::namespace::eval punk::lib::check { uplevel #0 $script set rep1 [tcl::unsupported::representation $::j] set script "" - set rep2 [tcl::unsupported::representation $::j] + set rep2 [tcl::unsupported::representation $::j] set nostring1 [string match "*no string" $rep1] set nostring2 [string match "*no string" $rep2] @@ -185,15 +185,15 @@ tcl::namespace::eval punk::lib::check { #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 + 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 + #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} { @@ -244,7 +244,7 @@ tcl::namespace::eval punk::lib::compat { 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 + #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 ""} { @@ -305,7 +305,7 @@ tcl::namespace::eval punk::lib::compat { 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 + #[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] @@ -356,7 +356,7 @@ tcl::namespace::eval punk::lib::compat { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -454,7 +454,7 @@ namespace eval punk::lib { #NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) proc aliases {{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] + 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]]} { @@ -464,7 +464,7 @@ namespace eval punk::lib { set segcount [llength $segments] ;#only match number of segments matching current ns - set all_aliases [interp aliases {}] + set all_aliases [interp aliases {}] set matched [list] foreach a $all_aliases { #normalize with leading :: @@ -477,7 +477,7 @@ namespace eval punk::lib { set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] set acount [llength $asegs] #puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $segments" - if {[expr {$acount - 1}] == $segcount} { + 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 @@ -485,7 +485,7 @@ namespace eval punk::lib { } } } - } + } #set matched_abs [lsearch -all -inline $all_aliases $glob] return $matched @@ -513,7 +513,7 @@ namespace eval punk::lib { set target [interp alias "" $aliasorglob] if {[llength $target]} { return $target - } + } if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { set aliaslist [punk::lib::aliases $aliasorglob] @@ -611,7 +611,7 @@ namespace eval punk::lib { } } 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. @@ -619,10 +619,10 @@ namespace eval punk::lib { #also 1b3 == 1b0003 if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version - set errmsg "tm_version_required_canonical - invalid version specification" + 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 + #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'" @@ -634,7 +634,7 @@ namespace eval punk::lib { error "$errmsg '$versionspec'" } } else { - # min- or min-max + # 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 @@ -700,29 +700,29 @@ namespace eval punk::lib { #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 + #on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report #use full 'lindex_resolve' which can report which side via -3 and -2 special results being lower and upper bound breaches respectively (-1 never returned) set a_index [lindex_resolve $l $a] set a_msg "" switch -- $a_index { -2 { - set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" + set a_msg "1st supplied index $a is above the upper bound for the list ([llength $l])" } -3 { - set a_msg "1st supplied index $a is below the lower bound for the list (0)" + set a_msg "1st supplied index $a is below the lower bound for the list (0)" } } set z_index [lindex_resolve $l $z] set z_msg "" switch -- $z_index { -2 { - set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" - } + set z_msg "2nd supplied index $z is above the upper bound for the list ([llength $l])" + } -3 { - set z_msg "2nd supplied index $z is below the lower bound for the list (0)" + set z_msg "2nd supplied index $z is below the lower bound for the list (0)" } } - set errmsg "lswap cannot swap indices $a and $z" + set errmsg "lswap cannot swap indices $a and $z" if {$a_msg ne ""} { append errmsg \n $a_msg } @@ -732,7 +732,7 @@ namespace eval punk::lib { error $errmsg } set item2 [lindex $l $z] - lset l $z [lindex $l $a] + lset l $z [lindex $l $a] lset l $a $item2 return $l } @@ -760,20 +760,20 @@ namespace eval punk::lib { #proc swap_intvars2 {swapv1 swapv2} { # upvar $swapv1 _x $swapv2 _y # set _x [expr {$_x ^ $_y}] - # set _y [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 _x $_y # set _y $z #} #*** !doctools #[subsection {Namespace punk::lib}] - #[para] Core API functions for punk::lib + #[para] Core API functions for punk::lib #[list_begin definitions] if {[info commands lseq] ne ""} { @@ -785,7 +785,7 @@ namespace eval punk::lib { } } else { #lseq accepts basic expressions e.g 4-2 for both arguments - #e.g we can do lseq 0 [llength $list]-1 + #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] @@ -798,16 +798,16 @@ namespace eval punk::lib { incr from -1 return [lmap v [lrepeat $count 0] {incr from}] } - #slower methods. + #slower methods. #2) - #set i -1 + #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] + # lappend L [incr from] #} #return $L } elseif {$from > $to} { @@ -821,14 +821,14 @@ namespace eval punk::lib { } #2) - #set i -1 + #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] + # lappend L [incr from -1] #} #return $L } else { @@ -839,7 +839,7 @@ namespace eval punk::lib { proc lzip {args} { switch -- [llength $args] { - 0 {return {}} + 0 {return {}} 1 {return [lindex $args 0]} 2 {return [lzip2lists {*}$args]} 3 {return [lzip3lists {*}$args]} @@ -874,7 +874,7 @@ namespace eval punk::lib { } proc Build_lzipn {n} { - set arglist [list] + 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 " @@ -890,7 +890,7 @@ namespace eval punk::lib { puts "proc punk::lib::lzip${n}lists {$arglist} \{" puts "$body" puts "\}" - proc ::punk::lib::lzip${n}lists $arglist $body + proc ::punk::lib::lzip${n}lists $arglist $body } #fastest is to know the number of lists to be zipped @@ -923,7 +923,7 @@ namespace eval punk::lib { } #neat algorithm - but while lmap seems better than foreach - it seems the script is evaluated a little slowly - # review - + # review - proc lzipn_alt args { #stackoverflow - courtesy glenn jackman (modified) foreach l $args { @@ -961,7 +961,7 @@ namespace eval punk::lib { 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 $e {*}$l {*}[lrepeat [expr {($numcolumns -([llength $l] % $numcolumns)) % $numcolumns}] NULL] ledit flatlist $s [expr {$s + $len - 1}] {*}$list incr s $numcolumns } @@ -977,7 +977,7 @@ namespace eval punk::lib { set numcolumns [::tcl::mathfunc::max {*}$lens] set flatlist [list] foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] } lmap c [lseq 0 $numcolumns-1] {lsearch -stride $numcolumns -index $c -inline -all -subindices $flatlist *} } @@ -988,9 +988,9 @@ namespace eval punk::lib { set numcolumns [::tcl::mathfunc::max {*}$lens] set flatlist [list] foreach len $lens list $args { - lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] + lappend flatlist {*}$list {*}[lrepeat [expr {($numcolumns - ($len % $numcolumns)) % $numcolumns}] ""] } - set zip_l {} + set zip_l {} set cols_remaining $numcolumns for {set c 0} {$c < $numcolumns} {incr c} { if {$cols_remaining == 1} { @@ -1006,14 +1006,14 @@ namespace eval punk::lib { #keep both lzipn_tclX functions available for side-by-side testing in Tcl versions where it's possible if {![package vsatisfies [package present Tcl] 9.0-] || [punk::lib::check::has_tclbug_lsearch_strideallinline ]} { #-stride either not available - or has bug preventing use of main algorithm below - proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] + proc lzipn {args} [info body ::punk::lib::lzipn_tcl8] } else { - proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] + proc lzipn {args} [info body ::punk::lib::lzipn_tcl9a] } - + namespace import ::punk::args::lib::tstr - + proc invoke command { @@ -1030,7 +1030,7 @@ namespace eval punk::lib { #}] #see https://wiki.tcl-lang.org/page/open - lassign [chan pipe] chanout chanin + lassign [chan pipe] chanout chanin lappend command 2>@$chanin set fh [open |$command] set stdout [read $fh] @@ -1045,7 +1045,7 @@ namespace eval punk::lib { } elseif {$sysmsg eq {CHILDSTATUS}} { return [list $stdout $stderr $exit] } else { - return -options $e $stderr + return -options $e $stderr } } return [list $stdout $stderr 0] @@ -1055,7 +1055,7 @@ namespace eval punk::lib { package require punk::args variable has_punk_ansi if {!$has_punk_ansi} { - set sep " = " + set sep " = " } else { #set sep " [a+ Web-seagreen]=[a] " set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " @@ -1081,18 +1081,18 @@ namespace eval punk::lib { 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) + 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. + 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 + 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 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 */%# + 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* + 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. @@ -1101,9 +1101,9 @@ namespace eval punk::lib { 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 segement 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. + 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::get_dict $argspec $args] @@ -1152,7 +1152,7 @@ namespace eval punk::lib { @cmd -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject -return -default "tailtohead" -choices {tailtohead sidebyside} - -channel -default none + -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 @@ -1181,7 +1181,7 @@ namespace eval punk::lib { }] $args] #for punk::lib - we want to reduce pkg dependencies. - # - so we won't even use the tcllib debug pkg here + # - 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 ""} { @@ -1222,18 +1222,18 @@ namespace eval punk::lib { 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 + #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: + #we currently return: #0 = v0 #1 = v1 #2 = v2 @@ -1245,7 +1245,7 @@ namespace eval punk::lib { #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}} { @@ -1263,7 +1263,7 @@ namespace eval punk::lib { set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] #puts stderr "showdict-->_split_patterns: $patterninfo" foreach v_idx $patterninfo { - lassign $v_idx v idx + 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 "!"} { @@ -1283,28 +1283,28 @@ namespace eval punk::lib { set keys [dict keys $dval] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p 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 } } %# { - 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 + dict set pattern_this_structure $p list lappend keyset # lappend keyset_structure list } ## { - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict lappend keyset [list ## query] - lappend keyset_structure dict + lappend keyset_structure dict } @* { #puts "showdict ---->@*<----" @@ -1323,19 +1323,19 @@ namespace eval punk::lib { #returns keys only lappend keyset [list $p query] lappend keyset_structure dict - dict set pattern_this_structure $p 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 + 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 + #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 @@ -1351,7 +1351,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @@* { #exact match key - review - should raise error to match punk pipe behaviour? @@ -1360,10 +1360,10 @@ namespace eval punk::lib { if {[dict exists $dval $k]} { set keys [dict keys [dict remove $dval $k]] lappend keyset {*}$keys - lappend keyset_structure {*}[lrepeat [llength $keys] dict] + lappend keyset_structure {*}[lrepeat [llength $keys] dict] } else { lappend keyset {*}[dict keys $dval] - lappend keyset_structure {*}[lrepeat [dict size $dval] dict] + lappend keyset_structure {*}[lrepeat [dict size $dval] dict] } } else { if {[dict exists $dval $k]} { @@ -1371,7 +1371,7 @@ namespace eval punk::lib { lappend keyset_structure dict } } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } @k@* - @K@* { #TODO get_not @@ -1380,7 +1380,7 @@ namespace eval punk::lib { lappend keyset $k lappend keyset_structure dict } - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*@*} { #return list of values @@ -1392,7 +1392,7 @@ namespace eval punk::lib { lappend keyset [list $p query] } lappend keyset_structure dict - dict set pattern_this_structure $p dict + dict set pattern_this_structure $p dict } {@\*.@*} { #TODO get_not @@ -1400,61 +1400,61 @@ namespace eval punk::lib { set keys [dict keys $dval $k] lappend keyset {*}$keys lappend keyset_structure {*}[lrepeat [llength $keys] dict] - dict set pattern_this_structure $p 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'" + #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 + 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 + 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 + 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 + dict set pattern_this_structure $p dict } default { - set this_type $opt_roottype + set this_type $opt_roottype if {[string match @* $p]} { - #list mode - trim optional list specifier @ + #list mode - trim optional list specifier @ set p [string range $p 1 end] - dict set pattern_this_structure $p list - set this_type list + dict set pattern_this_structure $p list + set this_type list } elseif {[string match %* $p]} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string lappend keyset $p - lappend keyset_structure string + lappend keyset_structure string set this_type string } if {$this_type eq "list"} { - dict set pattern_this_structure $p 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] + lappend keyset_structure {*}[lrepeat [llength $keys] list] } else { lappend keyset $p - lappend keyset_structure list + lappend keyset_structure list } } elseif {[string match "?*-?*" $p]} { #could be either - don't change type @@ -1469,7 +1469,7 @@ namespace eval punk::lib { #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds if {${lower_resolve} == -2} { ##x - #lower bound is above upper list range + #lower bound is above upper list range #match with decreasing indices is still possible set lower [expr {[llength $dval]-1}] ;#set to max } elseif {$lower_resolve == -3} { @@ -1510,15 +1510,15 @@ namespace eval punk::lib { } else { lappend keyset [list @$p query] } - lappend keyset_structure list - } + lappend keyset_structure list + } } elseif {$this_type eq "string"} { - dict set pattern_this_structure $p string + dict set pattern_this_structure $p string } elseif {$this_type eq "dict"} { #default equivalent to @\*@* - dict set pattern_this_structure $p dict + 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] + set keys [dict keys $dval $p] if {$get_not} { set keys [dict keys [dict remove $dval {*}$keys]] } @@ -1533,9 +1533,9 @@ namespace eval punk::lib { } } - # -- --- --- --- + # -- --- --- --- #check next pattern-segment for substructure type to use - # -- --- --- --- + # -- --- --- --- set substructure "" set pnext [lindex $segments 1] set patterninfo [punk::pipe::lib::_split_patterns $levelpatterns] @@ -1556,7 +1556,7 @@ namespace eval punk::lib { set substructure dict } # { - set substructure list + set substructure list } ## { set substructure dict @@ -1579,7 +1579,7 @@ namespace eval punk::lib { if {[string match @* $pnext]} { set substructure list } elseif {[string match %* $pnext]} { - set substructure string + set substructure string } else { #set substructure $opt_roottype #set substructure [dict get $pattern_this_structure $pattern_nest] @@ -1590,13 +1590,13 @@ namespace eval punk::lib { } } } else { - #e.g /@0,%str,.../ + #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 @@ -1629,7 +1629,7 @@ namespace eval punk::lib { } #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" } else { - puts stdout "unrecognised roottype: $opt_roottype" + puts stdout "unrecognised roottype: $opt_roottype" return $dval } @@ -1684,7 +1684,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] set subansibasekeys [lrange $opt_ansibase_keys 1 end] @@ -1692,7 +1692,7 @@ namespace eval punk::lib { #dict set nextopts -substructure $nextsub dict set nextopts -keytemplates $nextkeytemplates dict set nextopts -ansibase_keys $subansibasekeys - dict set nextopts -roottype $nextsub + dict set nextopts -roottype $nextsub dict set nextopts -channel none #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" @@ -1724,7 +1724,7 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - set nextopts [dict get $argd opts] + set nextopts [dict get $argd opts] dict set nextopts -roottype $nextsub dict set nextopts -channel none @@ -1751,22 +1751,22 @@ namespace eval punk::lib { set thisval [ansistring VIEWSTYLE -lf 1 $dval] } elseif {[string match *lpad-* $key]} { set hidekey 1 - lassign [split $key -] _ extra + 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 + 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 + 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 + 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 { @@ -1789,14 +1789,14 @@ namespace eval punk::lib { set nest [lrange $pattern_nest_list 1 end] lappend nextpatterns {*}[join $nest /] } - #set nextopts [dict get $argd opts] + #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} { @@ -1838,7 +1838,7 @@ namespace eval punk::lib { } } "sidebyside" { - # TODO - fix + # 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?) @@ -1942,7 +1942,7 @@ namespace eval punk::lib { #also struct::set difference with critcl is faster proc setdiff {A B} { if {[llength $A] == 0} {return {}} - set d [dict create] + set d [dict create] foreach x $A {dict set d $x {}} foreach x $B {dict unset d $x} return [dict keys $d] @@ -1950,7 +1950,7 @@ namespace eval punk::lib { #bulk dict remove is slower than a foreach with dict unset #proc setdiff2 {fromlist removeitems} { # #if {[llength $fromlist] == 0} {return {}} - # set d [dict create] + # set d [dict create] # foreach x $fromlist { # dict set d $x {} # } @@ -1975,8 +1975,8 @@ namespace eval punk::lib { struct::set union $list {} } } else { - puts stderr "WARNING: struct::set union no longer dedupes!" - #we could also test a sequence of: struct::set add + puts stderr "WARNING: struct::set union no longer dedupes!" + #we could also test a sequence of: struct::set add } } @@ -2026,9 +2026,9 @@ namespace eval punk::lib { } 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] + } } [info vars] } ] # -- --- --- set cvars [tcl::dict::get $capture vars] @@ -2039,13 +2039,13 @@ namespace eval punk::lib { 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% }] @@ -2075,7 +2075,7 @@ namespace eval punk::lib { append apply_script [string map [list %vname% $vname]\ {upvar 2 %vname% %vname%}\ ] \n - } + } append apply_script $script \n #puts "--> $apply_script" @@ -2110,7 +2110,7 @@ namespace eval punk::lib { # if {[tcl::dict::exists $dictValue {*}$keys]} { # return [tcl::dict::get $dictValue {*}$keys] # } else { - # return [lindex $args end] + # return [lindex $args end] # } #} if {[info commands ::tcl::dict::getdef] eq ""} { @@ -2123,7 +2123,7 @@ namespace eval punk::lib { } } } else { - #we pay a minor perf penalty for the wrap + #we pay a minor perf penalty for the wrap interp alias "" ::punk::lib::dict_getdef "" ::tcl::dict::getdef } @@ -2131,13 +2131,13 @@ namespace eval punk::lib { #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" #} #supports *safe* ultra basic offset expressions as used by lindex etc, but without the 'end' features @@ -2158,14 +2158,14 @@ namespace eval punk::lib { } } - # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side + # showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side proc lindex_resolve {list index} { #*** !doctools #[call [fun lindex_resolve] [arg list] [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 #[para]Users may define procs which accept a list 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]Sometimes the actual integer index is desired. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]lindex_resolve will parse the index expression and return: #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0) @@ -2183,13 +2183,13 @@ namespace eval punk::lib { #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { - #can match +i -i + #can match +i -i if {$index < 0} { return -3 } elseif {$index >= [llength $list]} { - return -2 + return -2 } else { - #integer may still have + sign - normalize with expr + #integer may still have + sign - normalize with expr return [expr {$index}] } } else { @@ -2223,7 +2223,7 @@ namespace eval punk::lib { set index [expr {([llength $list]-1) - $offset}] } if {$index < 0} { - return -3 + return -3 } else { return $index } @@ -2258,30 +2258,30 @@ namespace eval punk::lib { #[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2) #[para] returns -1 for out of range at either end, or a valid integer index #[para] 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 Tcl which has the builtin lseq command + #[para] This is only likely to be faster than average over lindex_resolve 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 + #[para] For pure integer indices the performance should be equivalent #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ - # - which + # - which #for {set i 0} {$i < [llength $list]} {incr i} { # lappend indices $i - #} + #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { - #can match +i -i + #can match +i -i #avoid even the lseq overhead when the index is simple if {$index < 0 || ($index >= [llength $list])} { #even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method. return -1 } else { - #integer may still have + sign - normalize with expr + #integer may still have + sign - normalize with expr return [expr {$index}] } - } + } if {[llength $list]} { set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. - #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) + #if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?) } else { set indices [list] } @@ -2290,7 +2290,7 @@ namespace eval punk::lib { #we have no way to determine if out of bounds is at lower vs upper end return -1 } else { - return $idx + return $idx } } proc lindex_get {list index} { @@ -2308,26 +2308,26 @@ namespace eval punk::lib { 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]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. + #[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] 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) + 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 + [\xF0-\xF4] [\x80-\xBF]{0,2} #possible prefix for ) $ } $bytes @@ -2347,7 +2347,7 @@ namespace eval punk::lib { 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) + #[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 :-) ^ (?: @@ -2362,7 +2362,7 @@ namespace eval punk::lib { 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] 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. @@ -2377,9 +2377,9 @@ namespace eval punk::lib { [\xF0-\xF4] [\x80-\xBF]{3} # Four-byte chars (U+10000-U+10FFFF, not supported by Tcl 8.5) ) + } $rawbytes completeChars]} { - return $completeChars - } - return "" + return $completeChars + } + return "" } proc hex2dec {args} { #*** !doctools @@ -2403,10 +2403,10 @@ namespace eval punk::lib { 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} { @@ -2427,7 +2427,7 @@ namespace eval punk::lib { 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}}]] + 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]]] @@ -2460,7 +2460,7 @@ namespace eval punk::lib { 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] { @@ -2504,7 +2504,7 @@ namespace eval punk::lib { #[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 + #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 expr {log($x)/log($b)} } proc factors {x} { @@ -2513,14 +2513,14 @@ namespace eval punk::lib { #[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]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]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. + #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]* 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 @@ -2537,7 +2537,7 @@ namespace eval punk::lib { proc oddFactors {x} { #*** !doctools #[call [fun oddFactors] [arg x]] - #[para]Return a list of odd integer factors of x, sorted in ascending order + #[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] @@ -2572,7 +2572,7 @@ namespace eval punk::lib { set max [expr {sqrt($x)}] while {$j <= $max} { if {$x % $j == 0} { - return [expr {$x / $j}] + return [expr {$x / $j}] } incr j 2 } @@ -2597,14 +2597,14 @@ namespace eval punk::lib { if {$other % 2 == 0} { set god $j } else { - set god [expr {$x / $j}] + set god [expr {$x / $j}] #lowest j - so other side must be highest break } } incr j 2 } - return $god + return $god } proc greatestOddFactor {x} { #*** !doctools @@ -2660,7 +2660,7 @@ namespace eval punk::lib { #[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]] + return [factors [gcd $x $y]] } #experimental only - there are better/faster ways @@ -2701,8 +2701,8 @@ namespace eval punk::lib { 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. + #[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 } @@ -2720,7 +2720,7 @@ namespace eval punk::lib { proc substring_count {str substring} { #*** !doctools #[call [fun substring_count] [arg str] [arg substring]] - #[para]Search str and return number of occurrences of 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} @@ -2736,7 +2736,7 @@ namespace eval punk::lib { #[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] + return [tcl::dict::merge [tcl::dict::merge $main $defaults] $main] } proc askuser {question} { @@ -2744,7 +2744,7 @@ namespace eval punk::lib { #[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]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 @@ -2755,12 +2755,12 @@ namespace eval punk::lib { # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { # puts "Proceeding" # } else { - # puts "Cancelled by user" + # puts "Cancelled by user" # } #[example_end] puts stdout $question flush stdout - set stdin_state [fconfigure stdin] + set stdin_state [chan configure stdin] if {[catch { package require punk::console set console_raw [tsv::get console is_raw] @@ -2769,7 +2769,7 @@ namespace eval punk::lib { set console_raw 0 } try { - fconfigure stdin -blocking 1 + chan configure stdin -blocking 1 if {$console_raw} { punk::console::disableRaw set answer [gets stdin] @@ -2778,7 +2778,7 @@ namespace eval punk::lib { set answer [gets stdin] } } finally { - fconfigure stdin -blocking [tcl::dict::get $stdin_state -blocking] + chan configure stdin -blocking [tcl::dict::get $stdin_state -blocking] } return $answer } @@ -2788,7 +2788,7 @@ namespace eval punk::lib { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { - lappend result "" + lappend result "" } else { lappend result $prefix[string trimright $line] } @@ -2827,7 +2827,7 @@ namespace eval punk::lib { } return [join $result \n] } - #A version of textutil::string::longestCommonPrefixList + #A version of textutil::string::longestCommonPrefixList proc longestCommonPrefix {items} { if {[llength $items] <= 1} { return [lindex $items 0] @@ -2844,9 +2844,9 @@ namespace eval punk::lib { } set n [string length $min] set prefix "" - set i -1 + set i -1 while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { - append prefix $c + append prefix $c } return $prefix } @@ -2855,7 +2855,7 @@ namespace eval punk::lib { proc linesort {args} { #*** !doctools #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] - #[para]Sort lines in 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} { @@ -2871,7 +2871,7 @@ namespace eval punk::lib { #*** !doctools #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] #[para]This simply joines 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]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 @@ -2903,8 +2903,8 @@ namespace eval punk::lib { #*** !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 + #[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 @@ -2928,7 +2928,7 @@ namespace eval punk::lib { } #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 + #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) @@ -2938,14 +2938,14 @@ namespace eval punk::lib { } $args]] 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" + error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] set text [string map {\r\n \n} $text] ;#review - option? @@ -2957,7 +2957,7 @@ namespace eval punk::lib { -commandprefix ""\ -ansiresets auto\ -ansireplays 0\ - ] + ] foreach {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets - -ansireplays { @@ -2989,16 +2989,16 @@ namespace eval punk::lib { } if {"trimall" in $opt_block} { #no other block options make sense in combination with this - set opt_block [list "trimall"] + set opt_block [list "trimall"] } - #TODO + #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } - + # -- --- --- --- --- --- set opt_line [tcl::dict::get $opts -line] @@ -3056,7 +3056,7 @@ namespace eval punk::lib { } } elseif {$tl_left} { foreach ln $nlsplit { - lappend linelist [string trimleft $ln] + lappend linelist [string trimleft $ln] } } elseif {$tl_right} { foreach ln $nlsplit { @@ -3074,7 +3074,7 @@ namespace eval punk::lib { set last "-" } else { if {$last ne ""} { - lappend linelist "" + lappend linelist "" } set last "" } @@ -3090,11 +3090,11 @@ namespace eval punk::lib { set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { - break + break } else { set lastempty $idx } - incr idx + incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] @@ -3107,7 +3107,7 @@ namespace eval punk::lib { set i 0 foreach ln $revlinelist { if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] + set linelist [lreverse [lrange $revlinelist $i end]] break } incr i @@ -3131,13 +3131,13 @@ namespace eval punk::lib { } #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 + #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" + set RST "\x1b\[0m" } else { set RST "" } @@ -3157,7 +3157,7 @@ namespace eval punk::lib { } } else { - #INLINE punk::ansi::codetype::is_sgr_reset + #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 @@ -3176,30 +3176,30 @@ namespace eval punk::lib { #leave replaycodes as is for next line set nextreplay $replaycodes } else { - set tail $RST + 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 + 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 + 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 + #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 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 + set tail $RST #determine effective replay for line set codestack [list start] foreach code $ansisplits { @@ -3211,7 +3211,7 @@ namespace eval punk::lib { 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. + #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 @@ -3241,7 +3241,7 @@ namespace eval punk::lib { } } else { set nextreplay $replaycodes - } + } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay @@ -3260,7 +3260,7 @@ namespace eval punk::lib { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] - } + } set linelist $transformed } @@ -3271,14 +3271,14 @@ namespace eval punk::lib { 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 + #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" + error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] set text [string map {\r\n \n} $text] ;#review - option? @@ -3290,7 +3290,7 @@ namespace eval punk::lib { -commandprefix ""\ -ansiresets auto\ -ansireplays 0\ - ] + ] foreach {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets - -ansireplays { @@ -3322,16 +3322,16 @@ namespace eval punk::lib { } if {"trimall" in $opt_block} { #no other block options make sense in combination with this - set opt_block [list "trimall"] + set opt_block [list "trimall"] } - #TODO + #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } - + # -- --- --- --- --- --- set opt_line [tcl::dict::get $opts -line] @@ -3389,7 +3389,7 @@ namespace eval punk::lib { } } elseif {$tl_left} { foreach ln $nlsplit { - lappend linelist [string trimleft $ln] + lappend linelist [string trimleft $ln] } } elseif {$tl_right} { foreach ln $nlsplit { @@ -3407,7 +3407,7 @@ namespace eval punk::lib { set last "-" } else { if {$last ne ""} { - lappend linelist "" + lappend linelist "" } set last "" } @@ -3423,11 +3423,11 @@ namespace eval punk::lib { set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { - break + break } else { set lastempty $idx } - incr idx + incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] @@ -3440,7 +3440,7 @@ namespace eval punk::lib { set i 0 foreach ln $revlinelist { if {$ln ne ""} { - set linelist [lreverse [lrange $revlinelist $i end]] + set linelist [lreverse [lrange $revlinelist $i end]] break } incr i @@ -3464,13 +3464,13 @@ namespace eval punk::lib { } #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 + #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" + set RST "\x1b\[0m" } else { set RST "" } @@ -3490,7 +3490,7 @@ namespace eval punk::lib { } } else { - #INLINE punk::ansi::codetype::is_sgr_reset + #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 @@ -3507,28 +3507,28 @@ namespace eval punk::lib { #leave replaycodes as is for next line set nextreplay $replaycodes } else { - set tail $RST + 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 + 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 + 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 + #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 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 + set tail $RST #determine effective replay for line set codestack [list start] foreach {pt code} $ansisplits { @@ -3540,7 +3540,7 @@ namespace eval punk::lib { 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. + #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 @@ -3570,7 +3570,7 @@ namespace eval punk::lib { } } else { set nextreplay $replaycodes - } + } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay @@ -3589,7 +3589,7 @@ namespace eval punk::lib { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] - } + } set linelist $transformed } @@ -3600,17 +3600,17 @@ namespace eval punk::lib { 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 + #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 + 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 + #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance set i 0 - set times {} + set times {} if {$iters < 2} {set iters 2} for {set i 0} {$i < $iters} {incr i} { @@ -3629,8 +3629,8 @@ namespace eval punk::lib { set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] } - set sigma [expr {int(sqrt($s2))}] - set average [expr int($average)] + set sigma [expr {int(sqrt($s2))}] + set average [expr {int($average)}] return "$average +/- $sigma microseconds per iteration" } @@ -3673,9 +3673,9 @@ namespace eval punk::lib { default { return [list $dec $c] } - } + } + - } @@ -3686,7 +3686,7 @@ namespace eval punk::lib { 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. + #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" @@ -3701,7 +3701,7 @@ namespace eval punk::lib { set data [tcl::unsupported::disassemble method $obj $method] } } else { - error "show_jump_tables expected a procname or a class/object and method" + error "show_jump_tables expected a procname or a class/object and method" } set result "" set in_jt 0 @@ -3786,10 +3786,10 @@ namespace eval punk::lib { } #todo - get configured user defaults if {$delim eq ""} { - set delim $default_delim + set delim $default_delim } if {$groupsize eq ""} { - set groupsize $default_groupsize + set groupsize $default_groupsize } lappend results [delimit_number $number $delim $groupsize] @@ -3820,10 +3820,10 @@ namespace eval punk::lib { # 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 [expr $point + 1] end]; + set PostDecimal [string range $number $point+1 end]; set PostDecimalP 1; } else { - set point [expr [string length $number] + 1] + set point [expr {[string length $number] + 1}] set PostDecimal ""; set PostDecimalP 0; } @@ -3834,16 +3834,16 @@ namespace eval punk::lib { incr ind; } set FirstNonSpace $ind; - set LastSpace [expr $FirstNonSpace - 1]; + 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 [expr $point -1]]; + 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 Phase [expr {$Length % $GroupSize}] + set PhaseMinusOne [expr {$Phase -1}]; set DelimitedMain ""; #First we deal with the extra stuff. @@ -3851,7 +3851,7 @@ namespace eval punk::lib { append DelimitedMain [string range $MainNumber 0 $PhaseMinusOne]; } set FirstInGroup $Phase; - set LastInGroup [expr $FirstInGroup + $GroupSize -1]; + set LastInGroup [expr {$FirstInGroup + $GroupSize -1}]; while {$LastInGroup < $Length} { if {$FirstInGroup > 0} { append DelimitedMain $delim; @@ -3869,7 +3869,7 @@ namespace eval punk::lib { } } - + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib ---}] @@ -3884,10 +3884,10 @@ tcl::namespace::eval punk::lib::flatgrid { #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 {$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]] @@ -3895,7 +3895,7 @@ tcl::namespace::eval punk::lib::flatgrid { set rows [list] set i 1 foreach s [lrange $splits 0 end-1] { - lappend rows [lrange $padded_list $s [lindex $splits $i]-1] + lappend rows [lrange $padded_list $s [lindex $splits $i]-1] incr i } return $rows @@ -3958,16 +3958,20 @@ tcl::namespace::eval punk::lib::flatgrid { } } +tcl::namespace::eval punk::lib::test { + +} + # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #todo - way to generate 'internal' docs separately? #*** !doctools #[section Internal] tcl::namespace::eval punk::lib::system { - #*** !doctools + #*** !doctools #[subsection {Namespace punk::lib::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #[list_begin definitions] @@ -3975,7 +3979,7 @@ tcl::namespace::eval punk::lib::system { ##*** !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) + #[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} { @@ -3988,9 +3992,9 @@ tcl::namespace::eval punk::lib::system { return [list number $most numfactors $mostcount] } proc factorCountBelow_punk {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[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! @@ -4001,9 +4005,9 @@ tcl::namespace::eval punk::lib::system { return $tally } proc factorCountBelow_numtheory {n} { - ##*** !doctools + ##*** !doctools #[call [fun factorCountBelow] [arg n]] - #[para]For numbers 1 to n - keep a tally of the total count of factors + #[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) @@ -4070,7 +4074,7 @@ tcl::namespace::eval punk::lib::system { lappend innerpartials "" } else { if {[lindex $waiting end] eq {"}} { - #this quote is endquote + #this quote is endquote set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { @@ -4078,7 +4082,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting {"} lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4089,7 +4093,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\]" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4098,7 +4102,7 @@ tcl::namespace::eval punk::lib::system { lappend waiting "\}" lappend innerpartials "" } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } @@ -4109,13 +4113,13 @@ tcl::namespace::eval punk::lib::system { set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } } } } else { - set p ${p}${c} + set p ${p}${c} lset innerpartials end $p } set escaped 0 @@ -4192,20 +4196,20 @@ tcl::namespace::eval punk::lib::system { } #get info about punk nestindex key ie type: list,dict,undetermined - # pdict devel + # pdict devel proc nestindex_info {args} { set argd [punk::args::get_dict { -parent -default "" - nestindex + nestindex } $args] 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 + 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 @@ -4221,11 +4225,11 @@ namespace eval ::punk::args::register { lappend ::punk::args::register::NAMESPACES ::punk::lib } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::lib [tcl::namespace::eval punk::lib { variable pkg punk::lib variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/base-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/base-0.1.tm index c5ec5551..69f2f5cb 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/base-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/base-0.1.tm @@ -18,7 +18,7 @@ namespace eval punk::mix::base { set extension "" } #--------- - + uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] } proc _cli {args} { @@ -69,7 +69,7 @@ namespace eval punk::mix::base { } #puts stderr "arglen:[llength $args]" #puts stdout "_unknown '$ns' '$args'" - + set d_commands [get_commands -extension $extension] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] @@ -98,11 +98,11 @@ namespace eval punk::mix::base { } tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns } else { - if {[regexp {.*[*?].*} $subcommand]} { + if {[regexp {.*[*?].*} $subcommand]} { set d_commands [get_commands -extension $from_ns] set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] set matched_commands [lsearch -all -inline $all_commands $subcommand] - set commands "" + set commands "" foreach m $matched_commands { append commands $m \n } @@ -113,12 +113,12 @@ namespace eval punk::mix::base { } proc _split_args {arglist} { #don't assume arglist is fully paired. - set posn [lsearch $arglist -extension] + set posn [lsearch $arglist -extension] set opts [list] if {$posn >= 0} { if {$posn+2 <= [llength $arglist]} { set opts [list -extension [lindex $arglist $posn+1]] - set argsremaining [lreplace $arglist $posn $posn+1] + set argsremaining [lreplace $arglist $posn $posn+1] } else { #no value supplied to -extension error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." @@ -151,7 +151,7 @@ namespace eval punk::mix::base { if {![string length $extension]} { set extension [namespace qualifiers [lindex [info level -1] 0]] } - + set maincommands [list] #extension may still be blank e.g if punk::mix::base::get_commands called directly if {[string length $extension]} { @@ -164,7 +164,7 @@ namespace eval punk::mix::base { } foreach c $nscommands { set cmd [namespace tail $c] - lappend maincommands $cmd + lappend maincommands $cmd } set maincommands [lsort $maincommands] } @@ -190,29 +190,29 @@ namespace eval punk::mix::base { set basecommands [lsort $basecommands] - return [list main $maincommands base $basecommands] + return [list main $maincommands base $basecommands] } proc help {args} { #' **%ensemblecommand% help** *args* - #' + #' #' Help for ensemble commands in the command line interface - #' - #' + #' + #' #' Arguments: - #' + #' #' * args - first word of args is the helptopic requested - usually a command name #' - calling help with no arguments will list available commands - #' + #' #' Returns: help text (text) - #' + #' #' Examples: - #' + #' #' ``` #' %ensemblecommand% help #' ``` - #' - #' - + #' + #' + #extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| # >} inspect -label a {| @@ -220,7 +220,7 @@ namespace eval punk::mix::base { # pipecase ,0/1/#= $switchargs {| # e/0 # >} .=>. {set e} - # pipecase /1,1/1/#= $switchargs + # pipecase /1,1/1/#= $switchargs #} |@@ok/result> " opts $opts] } @@ -620,7 +620,7 @@ namespace eval punk::mix::base { if {$path eq $base} { #attempting to cksum at root/volume level of a filesystem.. extra work - #This needs fixing for general use.. not necessarily just for project repos + #This needs fixing for general use.. not necessarily just for project repos puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" return [list error unsupported_path opts $opts] } @@ -671,8 +671,8 @@ namespace eval punk::mix::base { set archivename $tmplocation/[punk::mix::util::tmpfile].tar cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) - - #temp emission to stdout.. todo - repl telemetry channel + + #temp emission to stdout.. todo - repl telemetry channel puts stdout "cksum_path: creating temporary tar archive for $path" puts -nonewline stdout " at: $archivename ..." set tsstart [clock millis] @@ -692,7 +692,7 @@ namespace eval punk::mix::base { set ms [expr {$tsend - $tsstart}] puts stdout " tar::create done ($ms ms)" puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing" - } + } if {$ftype eq "file"} { set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)" @@ -718,7 +718,7 @@ namespace eval punk::mix::base { set cksum [{*}$cksum_command $path] } } else { - error "cksum_path unsupported $opts for path type [file type $path]" + error "cksum_path unsupported $opts for path type [file type $path]" } } set result [dict create] @@ -733,7 +733,7 @@ namespace eval punk::mix::base { #base can be empty string in which case paths must be absolute #expect dict_path_cksum to be a dict keyed on relpath where each value is a dictionary with keys cksum and opts # ie subdict for can be created from output of cksum_path (for already known values not requiring filling) - # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) + # or cksum "" opts [cksum_default_opts] or cksum "" opts {} (for cksum to be filled using supplied cksum opts if any) proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { if {$base eq ""} { set error_paths [list] @@ -775,7 +775,7 @@ namespace eval punk::mix::base { } } if {$base ne ""} { - set fullpath [file join $base $path] + set fullpath [file join $base $path] } else { set fullpath $path } @@ -820,7 +820,7 @@ namespace eval punk::mix::base { #Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will honour valid-looking prefilled cksum values (ie will pass them through) #base is the presumed location to store the checksum file. The caller should retain (normalize if relative) proc get_relativecksum_from_base {base specifiedpath args} { - if {$base ne ""} { + if {$base ne ""} { #targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it #we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix if {[file pathtype $specifiedpath] eq "relative"} { @@ -846,9 +846,9 @@ namespace eval punk::mix::base { #absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" } - set targetpath $specifiedpath + set targetpath $specifiedpath set storedpath [punk::path::relative $base $specifiedpath] - + } } else { if {[file type $specifiedpath] eq "relative"} { @@ -863,7 +863,7 @@ namespace eval punk::mix::base { # #NOTE: specifiedpath can be a relative path (to cwd) when base is empty - #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc + #OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc #possibly also: base: somewhere targetpath: ../elsewhere/etc # #todo - write tests @@ -881,7 +881,7 @@ namespace eval punk::mix::base { set ckopts [cksum_filter_opts {*}$args] set ckinfo [cksum_path $targetpath {*}$ckopts] - + set keyvals $args ;# REVIEW dict set keyvals cksum [dict get $ckinfo cksum] #dict set keyvals cksum_all_opts [dict get $ckinfo opts] @@ -891,7 +891,7 @@ namespace eval punk::mix::base { } #set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop - #storedpath is relative if possible + #storedpath is relative if possible return [dict create $storedpath $keyvals] } @@ -910,7 +910,7 @@ namespace eval punk::mix::base { dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] } - #buildruntime.exe obsolete.. + #buildruntime.exe obsolete.. set fullpath_buildruntime $buildfolder/buildruntime.exe set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] @@ -944,7 +944,7 @@ namespace eval punk::mix::base { } proc get_all_build_cksums_stored {path} { set buildfolder [get_build_workdir $path] - + set vfscontainer [file dirname $buildfolder] set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] set dict_cksums [dict create] @@ -963,7 +963,7 @@ namespace eval punk::mix::base { } set vfscontainer [file dirname $vfsfolder] set buildfolder $vfscontainer/_build - set dict_vfs [get_vfs_build_cksums $vfsfolder] + set dict_vfs [get_vfs_build_cksums $vfsfolder] set data "" dict for {path cksum} $dict_vfs { append data "$path $cksum" \n diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm index 5d38fad8..3cf64b33 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/cli-0.3.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::mix::cli 0.3.1 +# Application punk::mix::cli 0.3.1 # Meta platform tcl # Meta license # @@ Meta End @@ -19,7 +19,7 @@ ##e.g package require frobz package require punk::repo package require punk::ansi -package require punkcheck ;#checksum and/or timestamp records +package require punkcheck ;#checksum and/or timestamp records @@ -33,7 +33,7 @@ namespace eval punk::mix::cli { namespace ensemble create variable initialised 0 - #lazy _init - called by punk::mix::base::_cli when ensemble used + #lazy _init - called by punk::mix::base::_cli when ensemble used proc _init {args} { variable initialised if {$initialised} { @@ -52,7 +52,7 @@ namespace eval punk::mix::cli { catch { package require punk::mix::commandset::project punk::overlay::import_commandset project . ::punk::mix::commandset::project - punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection } if {[catch { package require punk::mix::commandset::layout @@ -91,12 +91,12 @@ namespace eval punk::mix::cli { } proc stat {{workingdir ""} args} { - dict set args -v 0 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 0 + punk::mix::cli::lib::get_status $workingdir {*}$args } proc status {{workingdir ""} args} { - dict set args -v 1 - punk::mix::cli::lib::get_status $workingdir {*}$args + dict set args -v 1 + punk::mix::cli::lib::get_status $workingdir {*}$args } @@ -128,13 +128,13 @@ namespace eval punk::mix::cli { set project_base [punk::repo::find_candidate] set sourcefolder $project_base/src puts stderr "WARNING - project not under git or fossil control" - puts stderr "Using base folder $project_base" + puts stderr "Using base folder $project_base" } else { set sourcefolder $startdir } } - #review - why can't we be anywhere in the project? + #review - why can't we be anywhere in the project? #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { puts stderr "dev make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" @@ -157,7 +157,7 @@ namespace eval punk::mix::cli { if {![string length $project_base]} { puts stderr "WARNING no git or fossil repository detected." - puts stderr "Using base folder $startdir" + puts stderr "Using base folder $startdir" set project_base $startdir } @@ -178,7 +178,7 @@ namespace eval punk::mix::cli { } } #cd $sourcefolder - + #use run so that stdout visible as it goes if {![catch {run --timeout=55000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { #todo - notify if exit because of timeout! @@ -198,7 +198,7 @@ namespace eval punk::mix::cli { puts stdout "OK make finished " return true } - } + } proc Kettle {args} { tailcall lib::kettle_call lib {*}$args @@ -241,7 +241,7 @@ namespace eval punk::mix::cli { # -- --- --- --- --- --- --- --- --- --- --- --- --- --- if {$opt_strict} { if {[regexp {[A-Z]} $modulename]} { - error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" + error "$opt_errorprefix '$modulename' contains uppercase which is not recommended as per tip 590, and option -strict is set to 1" } } @@ -272,7 +272,7 @@ namespace eval punk::mix::cli { } elseif {[regexp {[A-Z]} $modulename]} { set msg "module names containing uppercase are not recommended (see tip 590).\n" append msg "Please retype the module name '$modulename' to proceed.\n" - append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" + append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n" append msg "Retype it all in lowercase to use recommended naming" set answer [util::askuser $msg] if {[regexp {[A-Z]} $answer]} { @@ -285,11 +285,11 @@ namespace eval punk::mix::cli { } set modulename $answer } else { - #user has resupplied modulename all as lowercase + #user has resupplied modulename all as lowercase if {$answer eq [string tolower $modulename]} { set finalised 1 } else { - #.. but it doesn't match original - require rerun + #.. but it doesn't match original - require rerun } set modulename $answer } @@ -332,7 +332,7 @@ namespace eval punk::mix::cli { if {[string first "::" $projectname] >= 0} { error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" } - return $projectname + return $projectname } proc validate_name_not_empty_or_spaced {name args} { set opts [list\ @@ -394,7 +394,7 @@ namespace eval punk::mix::cli { set result "" if {$workingdir ne ""} { if {[file pathtype $workingdir] ne "absolute"} { - set workingdir [file normalize $workingdir] + set workingdir [file normalize $workingdir] } set active_dir $workingdir } else { @@ -403,10 +403,10 @@ namespace eval punk::mix::cli { set defaults [dict create\ -v 1\ ] - set opts [dict merge $defaults $args] - # -- --- --- --- --- --- --- --- --- + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- set opt_v [dict get $opts -v] - # -- --- --- --- --- --- --- --- --- + # -- --- --- --- --- --- --- --- --- set repopaths [punk::repo::find_repos [pwd]] @@ -417,7 +417,7 @@ namespace eval punk::mix::cli { append result [dict get $repopaths warnings] lassign [lindex $repos 0] repopath repotypes if {"fossil" in $repotypes} { - #review - multiple process launches to fossil a bit slow on windows.. + #review - multiple process launches to fossil a bit slow on windows.. #could we query global db in one go instead? # set fossil_prog [auto_execok fossil] @@ -444,14 +444,14 @@ namespace eval punk::mix::cli { if {"project" in $repotypes} { #punk project if {![catch {package require textblock; package require patternpunk}]} { - set result [textblock::join -- [>punk . logo] " " $result] + set result [textblock::join -- [>punk . logo] " " $result] append result \n - } - } + } + } set timeline [exec fossil timeline -n 5 -t ci] set timeline [string map {\r\n \n} $timeline] - append result $timeline + append result $timeline if {$opt_v} { set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] append result \n [punk::repo::workingdir_state_summary $repostate] @@ -516,7 +516,7 @@ namespace eval punk::mix::cli { puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" exit 2 } - set srcdirname [file tail $srcdir] + set srcdirname [file tail $srcdir] set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir if {[llength $subdirlist] == 0} { @@ -578,7 +578,7 @@ namespace eval punk::mix::cli { } set fileparts [split [file rootname $modpath] -] #set tmfile_versionsegment [lindex $fileparts end] - lassign [split_modulename_version $modpath] basename tmfile_versionsegment + lassign [split_modulename_version $modpath] basename tmfile_versionsegment if {$tmfile_versionsegment eq ""} { #split_modulename_version version part will be empty if not valid tcl version #last segment doesn't look even slightly versiony - fail. @@ -634,8 +634,8 @@ namespace eval punk::mix::cli { set modulefile $buildfolder/$basename-$module_build_version.tm - $build_event targetset_init INSTALL $podtree_copy - $build_event targetset_addsource $current_source_dir/$modpath + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath if {$tmfile_versionsegment eq $magicversion} { $build_event targetset_addsource $versionfile } @@ -667,7 +667,7 @@ namespace eval punk::mix::cli { if {[file exists $tmfile]} { set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm file rename $tmfile $newname - set tmfile $newname + set tmfile $newname } set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd set data [string map [list $magicversion $module_build_version] $data] @@ -745,12 +745,12 @@ namespace eval punk::mix::cli { $build_event targetset_end SKIPPED } $build_event destroy - $build_installer destroy + $build_installer destroy - #JMN - review + #JMN - review if {!$had_error} { - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm - $event targetset_addsource $modulefile + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile if {\ [llength [dict get [$event targetset_source_changes] changed]]\ || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ @@ -759,12 +759,12 @@ namespace eval punk::mix::cli { $event targetset_started # -- --- --- --- --- --- if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} - lappend module_list $modulefile + lappend module_list $modulefile if {[catch { file copy -force $modulefile $target_module_dir } errMsg]} { puts stderr "FAILED to copy zip modpod module $modulefile to $target_module_dir" - $event targetset_end FAILED -note "could not copy $modulefile" + $event targetset_end FAILED -note "could not copy $modulefile" } else { puts stderr "Copied zip modpod module $modulefile to $target_module_dir" # -- --- --- --- --- --- @@ -782,7 +782,7 @@ namespace eval punk::mix::cli { } tarjar { #basename may still contain #tarjar- - #to be obsoleted - update modpod to (optionally) use vfs::tar + #to be obsoleted - update modpod to (optionally) use vfs::tar } file { set m $modpath @@ -808,12 +808,12 @@ namespace eval punk::mix::cli { if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #rebuild the .tm from the #tarjar + #rebuild the .tm from the #tarjar if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - + } else { - + } #REVIEW - should be in same structure/depth as $target_module_dir in _build? @@ -824,22 +824,22 @@ namespace eval punk::mix::cli { set tmfile $buildfolder/$basename-$module_build_version.tm file delete -force $buildfolder/#tarjar-$basename-$module_build_version file delete -force $tmfile - - + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version # #bsdtar doesn't seem to work.. or I haven't worked out the right options? #exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version package require tar - tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version if {![file exists $tmfile]} { puts stdout "ERROR: failed to build tarjar file $tmfile" exit 4 } #copy the file? - #set target $target_module_dir/$basename-$module_build_version.tm + #set target $target_module_dir/$basename-$module_build_version.tm #file copy -force $tmfile $target - + lappend module_list $tmfile } else { #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. @@ -851,7 +851,7 @@ namespace eval punk::mix::cli { # #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm $event targetset_addsource $versionfile $event targetset_addsource $current_source_dir/$m @@ -902,7 +902,7 @@ namespace eval punk::mix::cli { #------------------------------ } - + continue } ##------------------------------ @@ -917,7 +917,7 @@ namespace eval punk::mix::cli { #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] #set changed_list [dict get $changed_unchanged changed] #---------- - $event targetset_init INSTALL $target_module_dir/$m + $event targetset_init INSTALL $target_module_dir/$m $event targetset_addsource $current_source_dir/$m if {\ [llength [dict get [$event targetset_source_changes] changed]]\ @@ -981,7 +981,7 @@ namespace eval punk::mix::cli { } if {$CALLDEPTH == 0} { $event destroy - $installer destroy + $installer destroy } return $module_list } @@ -1017,7 +1017,7 @@ namespace eval punk::mix::cli { } dict set kettle_reset_args $p $arglist } - } + } } #call kettle_reinit to ensure recipes point to current project @@ -1095,14 +1095,14 @@ namespace eval punk::mix::cli { kettle_reinit } } - set first [lindex $args 0] + set first [lindex $args 0] if {[string match @* $first]} { error "deck kettle doesn't support special operations - try calling tclsh kettle directly" } if {$first eq "-f"} { set args [lassign $args __ path] } else { - set path $startdir/build.tcl + set path $startdir/build.tcl } set opts [list] @@ -1123,9 +1123,9 @@ namespace eval punk::mix::cli { } } - #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names + #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) - #REVIEW - needs to be updated to keep in sync with kettle. + #REVIEW - needs to be updated to keep in sync with kettle. set knownopts [list\ --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ @@ -1202,7 +1202,7 @@ namespace eval punk::mix::cli { package require punk::mix::base package require punk::overlay if {[catch { - punk::overlay::custom_from_base [namespace current] ::punk::mix::base + punk::overlay::custom_from_base [namespace current] ::punk::mix::base } errM]} { puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" error "punk::mix::cli error: $errM" @@ -1213,9 +1213,9 @@ namespace eval punk::mix::cli { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::cli [namespace eval punk::mix::cli { variable version - set version 0.3.1 + set version 0.3.1 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.0.tm index dab5312f..63b5335c 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix/templates-0.1.0.tm @@ -47,7 +47,7 @@ namespace eval punk::mix::templates { lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. #review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. - #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. + #we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. return $decls } } @@ -86,9 +86,9 @@ namespace eval punk::mix::templates { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::templates [namespace eval punk::mix::templates { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file 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 79150d6c..8e4699dc 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 @@ -57,7 +57,7 @@ namespace eval punk::mix::util { incr i set last_opt $i } else { - set last_opt [expr {$i - 1}] + set last_opt [expr {$i - 1}] break } } @@ -73,7 +73,7 @@ namespace eval punk::mix::util { #puts stderr "opts: $opts paths: $paths" - #let's proceed, but warn the user if an apparent option is in paths + #let's proceed, but warn the user if an apparent option is in paths foreach opt [list -encoding -eofchar -translation] { if {$opt in $paths} { puts stderr "fcat WARNING: apparent option $opt found after file argument(s) (expected them before filenames). Passing to fileutil::cat anyway - but for at least some versions, these options may be ignored. commandline 'fcat $args'" @@ -142,7 +142,7 @@ namespace eval punk::mix::util { } #---------------------------------------- - #namespace import ::punk::ns::nsimport_noclobber + #namespace import ::punk::ns::nsimport_noclobber proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { set source_ns [namespace qualifiers $pattern] @@ -153,7 +153,7 @@ namespace eval punk::mix::util { set nscaller [uplevel 1 {namespace current}] set ns [punk::nsjoin $nscaller $ns] } - set a_export_patterns [namespace eval $source_ns {namespace export}] + set a_export_patterns [namespace eval $source_ns {namespace export}] set a_commands [info commands $pattern] set a_tails [lmap v $a_commands {namespace tail $v}] set a_exported_tails [list] @@ -359,9 +359,9 @@ namespace eval punk::mix::util { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::mix::util [namespace eval punk::mix::util { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm index 140f2678..bce44dee 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/nav/fs-0.1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::nav::fs 0 0.1.0] #[copyright "2024"] #[titledesc {punk::nav::fs console filesystem navigation}] [comment {-- Name section and table of contents description --}] -#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] +#[moddesc {fs nav}] [comment {-- Description at end of page heading --}] #[require punk::nav::fs] #[keywords module filesystem terminal] #[description] @@ -117,9 +117,9 @@ tcl::namespace::eval punk::nav::fs { #Both tcl's notion of pwd and VIRTUAL_CWD can be out of sync with the process CWD. This happens when in a VFS. #We can also have VIRTUAL_CWD navigate to spaces that Tcl's cd can't - review - variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint + variable VIRTUAL_CWD ;#cwd that tracks pwd except when in zipfs locations that are not at or below a mountpoint if {![interp issafe]} { - set VIRTUAL_CWD [pwd] + set VIRTUAL_CWD [pwd] } else { set VIRTUAL_CWD "" } @@ -127,25 +127,25 @@ tcl::namespace::eval punk::nav::fs { variable VIRTUAL_CWD set cwd [pwd] if {$cwd ne $VIRTUAL_CWD} { - puts stderr "pwd: $cwd" + puts stderr "pwd: $cwd" } return $::punk::nav::fs::VIRTUAL_CWD } - #TODO - maintain per 'volume/server' CWD - #e.g cd and ./ to: - # d: + #TODO - maintain per 'volume/server' CWD + #e.g cd and ./ to: + # d: # //zipfs: # //server # https://example.com # should return to the last CWD for that volume/server - + #VIRTUAL_CWD follows pwd when changed via cd set stackrecord [commandstack::rename_command -renamer punk::nav::fs cd {args} { if {![catch { $COMMANDSTACKNEXT {*}$args } errM]} { - set ::punk::nav::fs::VIRTUAL_CWD [pwd] + set ::punk::nav::fs::VIRTUAL_CWD [pwd] } else { error $errM } @@ -153,7 +153,7 @@ tcl::namespace::eval punk::nav::fs { #*** !doctools #[subsection {Namespace punk::nav::fs}] - #[para] Core API functions for punk::nav::fs + #[para] Core API functions for punk::nav::fs #[list_begin definitions] @@ -170,7 +170,7 @@ tcl::namespace::eval punk::nav::fs { #This seems unfortunate - as a multithreaded set of test runs might otherwise have made some sense.. but perhaps for tests more serious isolation is a good idea. #It also seems common to cd when loading certain packages e.g tls from starkit. #While in most/normal cases the library will cd back to the remembered working directory after only a brief time - there seem to be many opportunities for issues - #if the repl is used to launch/run a number of things in the one process + #if the repl is used to launch/run a number of things in the one process proc d/ {args} { variable VIRTUAL_CWD @@ -205,7 +205,7 @@ tcl::namespace::eval punk::nav::fs { } set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] - set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) + set symlinkcount [llength [dict get $matchinfo links]] ;#doesn't include windows shelllinks (.lnk) #set location [file normalize [dict get $matchinfo location]] set location [dict get $matchinfo location] @@ -217,7 +217,7 @@ tcl::namespace::eval punk::nav::fs { set filesizes [lsearch -all -inline -not $filesizes na] set filebytes [tcl::mathop::+ {*}$filesizes] lappend result filebytes [punk::lib::format_number $filebytes] - } + } if {[punk::nav::fs::system::codethread_is_running]} { if {[llength [info commands ::punk::console::titleset]]} { #if ansi is off - punk::console::titleset will try 'local' api method - which can fail @@ -252,18 +252,18 @@ tcl::namespace::eval punk::nav::fs { set a1 [lindex $args 0] switch -exact -- $a1 { . - ./ { - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } .. - ../ { if {$VIRTUAL_CWD eq "//zipfs:/" && ![string match //zipfs:/* [pwd]]} { #exit back to last nonzipfs path that was in use set VIRTUAL_CWD [pwd] - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } - #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) - # [file join //server ..] would become /server/.. - use normjoin to get //server - # file dirname //server/share would stay as //server/share + #we need to use normjoin to allow navigation to //server instead of just to //server/share (//server browsing unimplemented - review) + # [file join //server ..] would become /server/.. - use normjoin to get //server + # file dirname //server/share would stay as //server/share #set up1 [file dirname $VIRTUAL_CWD] set up1 [punk::path::normjoin $VIRTUAL_CWD ..] if {[string match //zipfs:/* $up1]} { @@ -277,7 +277,7 @@ tcl::namespace::eval punk::nav::fs { cd $up1 #set VIRTUAL_CWD [file normalize $a1] } - tailcall punk::nav::fs::d/ + tailcall punk::nav::fs::d/ } } @@ -318,13 +318,13 @@ tcl::namespace::eval punk::nav::fs { } } if {[file type $target] eq "directory"} { - set VIRTUAL_CWD $target + set VIRTUAL_CWD $target } } tailcall punk::nav::fs::d/ } set curdir $VIRTUAL_CWD - } else { + } else { set curdir [pwd] } @@ -365,7 +365,7 @@ tcl::namespace::eval punk::nav::fs { set location $path set glob * if {$searchspec_relative} { - set searchbase [pwd] + set searchbase [pwd] } else { set searchbase $path } @@ -373,19 +373,19 @@ tcl::namespace::eval punk::nav::fs { set location [file dirname $path] set glob [file tail $path] ;#search for exact match file if {$searchspec_relative} { - set searchbase [pwd] + set searchbase [pwd] } else { set searchbase [file dirname $path] } } } - set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] + set matchinfo [dirfiles_dict -searchbase $searchbase -tailglob $glob -with_sizes {f d l} -with_times {f d l} $location] #puts stderr "=--->$matchinfo" set location [file normalize [dict get $matchinfo location]] if {[string match //xzipfs:/* $location] || $location ne $last_location} { - #REVIEW - zipfs test disabled with leading x + #REVIEW - zipfs test disabled with leading x #emit previous result if {[dict size $this_result]} { dict set this_result filebytes [punk::lib::format_number [dict get $this_result filebytes]] @@ -398,7 +398,7 @@ tcl::namespace::eval punk::nav::fs { set this_result [dict create] set dircount 0 set filecount 0 - } + } incr dircount [llength [dict get $matchinfo dirs]] incr filecount [llength [dict get $matchinfo files]] @@ -406,7 +406,7 @@ tcl::namespace::eval punk::nav::fs { dict set this_result location $location dict set this_result dircount $dircount dict set this_result filecount $filecount - + set filesizes [dict get $matchinfo filesizes] if {[llength $filesizes]} { set filesizes [lsearch -all -inline -not $filesizes na] @@ -468,7 +468,7 @@ tcl::namespace::eval punk::nav::fs { } set normpath [file normalize $path] cd $normpath - set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] + set matchinfo [dirfiles_dict -searchbase $normpath -with_sizes {f d l} -with_times {f d l} $normpath] set dircount [llength [dict get $matchinfo dirs]] set filecount [llength [dict get $matchinfo files]] set location [file normalize [dict get $matchinfo location]] @@ -479,7 +479,7 @@ tcl::namespace::eval punk::nav::fs { set filesizes [lsearch -all -inline -not $filesizes na] set filebytes [tcl::mathop::+ {*}$filesizes] lappend result filebytes [punk::lib::format_number $filebytes] - } + } set out [dirfiles_dict_as_lines -stripbase 1 $matchinfo] #return $out\n[pwd] @@ -583,7 +583,7 @@ tcl::namespace::eval punk::nav::fs { set ext [file extension $path] set extlower [string tolower $ext] if {$extlower in $tcl_extensions} { - set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first set ::argv0 $path set ::argc [llength $newargs] set ::argv $newargs @@ -609,7 +609,7 @@ tcl::namespace::eval punk::nav::fs { } } if {$tcl_indicator} { - set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. + set newargs [lrange $args 1 end] ;#todo - fix to allow script in position other than first. set ::argv0 $path set ::argc [llength $newargs] set ::argv $newargs @@ -645,7 +645,7 @@ tcl::namespace::eval punk::nav::fs { } proc dirfiles {args} { set argd [punk::args::get_by_id ::punk::nav::fs::dirfiles $args] - lassign [dict values $argd] leaders opts values_dict + lassign [dict values $argd] leaders opts values_dict set opt_stripbase [dict get $opts -stripbase] set opt_formatsizes [dict get $opts -formatsizes] @@ -663,11 +663,11 @@ tcl::namespace::eval punk::nav::fs { #dirfiles_dict would handle simple cases of globs within paths anyway - but we need to explicitly set tailglob here in all branches so that next level doesn't need to do file vs dir checks to determine user intent. #(dir-listing vs file-info when no glob-chars present is inherently ambiguous so we test file vs dir to make an assumption - more explicit control via -tailglob can be done manually with dirfiles_dict) if {$relativepath} { - set searchbase [pwd] + set searchbase [pwd] if {!$has_tailglobs} { if {[file isdirectory [file join $searchbase $searchspec]]} { set location [file join $searchbase $searchspec] - set tailglob * + set tailglob * } else { set location [file dirname [file join $searchbase $searchspec]] set tailglob [file tail $searchspec] ;#use exact match as a glob - will retrieve size,attributes etc. @@ -700,29 +700,29 @@ tcl::namespace::eval punk::nav::fs { return [dirfiles_dict_as_lines -stripbase $opt_stripbase -formatsizes $opt_formatsizes $contents] } - #todo - package as punk::nav::fs + #todo - package as punk::nav::fs #todo - in thread #todo - streaming version #glob patterns in path prior to final segment should already be resolved before using dirfiles_dict - as the underlying filesystem mechanisms can't do nested globbing themselves. #dirfiles_dict will assume the path up to the final segment is literal even if globchars are included therein. #final segment globs will be recognised only if -tailglob is passed as empty string #if -tailglob not supplied and last segment has globchars - presume searchspec parendir is the container and last segment is globbing within that. - #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * + #if -tailglob not supplied and last segment has no globchars - presume searchspec is a container(directory) and use glob * #caller should use parentdir as location and set tailglob to search-pattern or exact match if location is intended to match a file rather than a directory #examples: # somewhere/files = search is effectively somewhere/files/* (location somewhere/files glob is *) # somewhere/files/* = (as above) - # -tailglob * somewhere/files = (as above) + # -tailglob * somewhere/files = (as above) # # -tailglob "" somewhere/files = search somewhere folder for exactly 'files' (location somewhere glob is files) # -tailglob files somewhere = (as above) # # somewhere/f* = search somewhere folder for f* (location somewhere glob is f*) - # -tailglob f* somewhere = (as above) - # + # -tailglob f* somewhere = (as above) + # # This somewhat clumsy API is so that simple searches can be made in a default sensible manner without requiring extra -tailglob argument for the common cases - with lack of trailing glob segment indicating a directory listing # - but we need to distinguish somewhere/files as a search of that folder vs somewhere/files as a search for exactly 'files' within somewhere, hence the -tailglob option to fine-tune. - # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. + # - this also in theory allows file/directory names to contain glob chars - although this is probably unlikely and/or unwise and not likely to be usable on all platforms. # #if caller supplies a tailglob as empty string - presume the caller hasn't set location to parentdir - and that last element is the search pattern. # -searchbase is always passed through - and is only used to construct a location path if a relative searchspec was supplied @@ -733,7 +733,7 @@ tcl::namespace::eval punk::nav::fs { -searchbase -default "" -tailglob -default "\uFFFF" #with_sizes & with_times must accept 0|1|f|d|l where f = files d = dirs l = links (punk::du) - -with_sizes -default "\uFFFF" -type string + -with_sizes -default "\uFFFF" -type string -with_times -default "\uFFFF" -type string @values -min 0 -max -1 -type string } @@ -743,7 +743,7 @@ tcl::namespace::eval punk::nav::fs { #puts stderr "searchspecs: $searchspecs [llength $searchspecs]" #puts stdout "arglist: $opts" - + if {[llength $searchspecs] > 1} { #review - spaced paths ? error "dirfiles_dict: multiple listing not *yet* supported" @@ -757,7 +757,7 @@ tcl::namespace::eval punk::nav::fs { # -- --- --- --- --- --- --- #we don't want to normalize.. - #for example if the user supplies ../ we want to see ../result + #for example if the user supplies ../ we want to see ../result set is_relativesearchspec [expr {[file pathtype $searchspec] eq "relative"}] if {$opt_searchbase eq ""} { @@ -770,7 +770,7 @@ tcl::namespace::eval punk::nav::fs { switch -- $opt_tailglob { "" { if {$searchspec eq ""} { - set location + set location } else { if {$is_relativesarchspec} { #set location [file dirname [file join $opt_searchbase $searchspec]] @@ -821,13 +821,13 @@ tcl::namespace::eval punk::nav::fs { set location $searchspec } } - set match_contents $opt_tailglob + set match_contents $opt_tailglob } } #puts stdout "searchbase: $searchbase searchspec:$searchspec" - #file attr //cookit:/ returns {-vfs 1 -handle {}} + #file attr //cookit:/ returns {-vfs 1 -handle {}} #we will treat it differently for now - use generic handler REVIEW set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit. if {[llength [package provide vfs]]} { @@ -873,11 +873,11 @@ tcl::namespace::eval punk::nav::fs { #we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name? set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob) } else { - #we could use 'file attr' here to test if {-vfs 1} - #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) + #we could use 'file attr' here to test if {-vfs 1} + #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) #instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume } - + } } @@ -885,7 +885,7 @@ tcl::namespace::eval punk::nav::fs { #relative vs absolute? review - cwd valid for //zipfs:/ ?? set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } elseif {$in_cookit} { - #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ + #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ #don't use twapi #could possibly use du_dirlisting_tclvfs REVIEW #files and folders are all returned with the -types hidden option for glob on windows @@ -928,12 +928,12 @@ tcl::namespace::eval punk::nav::fs { lappend dirs $vfsmount } } - } + } #NOTE: -types {hidden d} * may return . & .. on unix platforms - but will not show them on windows. #A mounted vfs exe (e.g sometclkit.exe) may be returned by -types {hidden d} on windows - but at the same time has "-hidden 0" in the result of file attr. - + #non-unix platforms may have attributes to indicate hidden status even if filename doesn't have leading dot. #mac & windows have these #windows doesn't consider dotfiles as hidden - mac does (?) @@ -946,8 +946,8 @@ tcl::namespace::eval punk::nav::fs { set flaggedhidden [punk::lib::lunique_unordered $flaggedhidden] } - set dirs [lsort $dirs] ;#todo - natsort - + set dirs [lsort $dirs] ;#todo - natsort + #foreach d $dirs { @@ -958,7 +958,7 @@ tcl::namespace::eval punk::nav::fs { #glob -types {hidden} will not always return the combination of glob -types {hidden f} && -types {hidden d} (on windows anyway) - # -- --- + # -- --- #can't lsort files without lsorting filesizes #Note - the sort by index would convert an empty filesizes list to a list of empty strings - one for each entry in files #We want to preserve the empty list if that's what the dirlisting mechanism returned (presumably because -with_sizes was 0 or explicitly excluded files) @@ -971,22 +971,22 @@ tcl::namespace::eval punk::nav::fs { set sorted_filesizes [list] foreach i $sortorder { lappend sorted_files [lindex $files $i] - lappend sorted_filesizes [lindex $filesizes $i] + lappend sorted_filesizes [lindex $filesizes $i] } } set files $sorted_files set filesizes $sorted_filesizes - # -- --- + # -- --- #jmn foreach nm [list {*}$dirs {*}$files] { if {[punk::winpath::illegalname_test $nm]} { lappend nonportable $nm - } + } } - set front_of_dict [dict create location $location searchbase $opt_searchbase] + set front_of_dict [dict create location $location searchbase $opt_searchbase] set listing [dict merge $front_of_dict $listing] set updated [dict create dirs $dirs files $files filesizes $filesizes nonportable $nonportable flaggedhidden $flaggedhidden underlayfiles $underlayfiles underlayfilesizes $underlayfilesizes] @@ -1045,7 +1045,7 @@ tcl::namespace::eval punk::nav::fs { set prefix_test_list [tcl::prefix all $searchbases [lindex $shortest_to_longest 0 0]] #if shortest doesn't match all searchbases - we have no common base if {[llength $prefix_test_list] == [llength $searchbases]} { - set common_base [lindex $shortest_to_longest 0 0]; #we + set common_base [lindex $shortest_to_longest 0 0]; #we } } } @@ -1082,11 +1082,11 @@ tcl::namespace::eval punk::nav::fs { } set $fileset $stripped } - #Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. + #Note: without fkeys we would need to remember to use common_base to rebuild (and file normalize!) the key when we need to query the dict-based elements: sizes & times - because we didn't strip those keys. } # -- --- --- --- --- --- --- --- --- --- --- - #assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out + #assign symlinks to the dirs or files collection (the punk::du system doesn't sort this out #As at 2024-09 for windows symlinks - Tcl can't do file readlink on symlinks created with mklink /D name target (SYMLINKD) or mklink name target (SYMLINK) #We can't read the target information - best we can do is classify it as a file or a dir #we can't use 'file type' as that will report just 'link' - but file isfile and file isdirectory work and should work for links on all platforms - REVIEW @@ -1110,7 +1110,7 @@ tcl::namespace::eval punk::nav::fs { } } } else { - #fallback if no target_type + #fallback if no target_type if {[file isfile $s]} { lappend file_symlinks $s #will be appended in finfo_plus later @@ -1125,9 +1125,9 @@ tcl::namespace::eval punk::nav::fs { } #we now have the issue that our symlinks aren't sorted within the dir/file categorisation - they currently will have to appear at beginning or end - TODO # -- --- --- --- --- --- --- --- --- --- --- - - - #todo - sort whilst maintaining order for metadata? + + + #todo - sort whilst maintaining order for metadata? #we need to co-sort files only with filesizes (other info such as times is keyed on fname so cosorting not required) @@ -1135,7 +1135,7 @@ tcl::namespace::eval punk::nav::fs { if {$opt_formatsizes} { set filesizes [punk::lib::format_number $filesizes] ;#accepts a list and will process each } - + #col2 (file info) with subcolumns set widest2a [tcl::mathfunc::max {*}[lmap v [list {*}$files {*}$file_symlinks ""] {string length $v}]] @@ -1162,7 +1162,7 @@ tcl::namespace::eval punk::nav::fs { set mtime [dict get $contents times $key m] set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] } else { - #set ts [string repeat { } 19] + #set ts [string repeat { } 19] set ts "$key vs [dict keys [dict get $contents times]]" } set note "" @@ -1181,7 +1181,7 @@ tcl::namespace::eval punk::nav::fs { set mtime [dict get $contents times $key m] set ts [tcl::clock::format $mtime -format "%Y-%m-%d %H:%M:%S"] } else { - set ts "[string repeat { } 19]" + set ts "[string repeat { } 19]" } set note "link" ;#default only if {[dict exists $contents linkinfo $key linktype]} { @@ -1207,24 +1207,24 @@ tcl::namespace::eval punk::nav::fs { set fname [dict get $fdict file] if {[file extension $fname] eq ".lnk"} { if {![catch {package require punk::winlnk}]} { - set shortcutinfo [punk::winlnk::file_get_info $fname] + set shortcutinfo [punk::winlnk::file_get_info $fname] set target_type "file" ;#default/fallback if {[dict exists $shortcutinfo link_target]} { - set is_valid_lnk 1 + set is_valid_lnk 1 set tgt [dict get $shortcutinfo link_target] if {[file exists $tgt]} { #file type could return 'link' - we will use isfile/isdirectory if {[file isfile $tgt]} { set target_type file } elseif {[file isdirectory $tgt]} { - set target_type directory + set target_type directory } else { set target_type file ;## ? } } else { #todo - see if punk::winlnk has info about the type at the time of linking #for now - treat as file - } + } } else { #no link_target - probably an ordinary file - but there could have been some other error in reading the binary windows lnk format. set is_valid_lnk 0 @@ -1239,7 +1239,7 @@ tcl::namespace::eval punk::nav::fs { } directory { #target of link is a dir - for display/categorisation purposes we want to see it as a dir - #will be styled later based on membership of dir_shortcuts + #will be styled later based on membership of dir_shortcuts lappend dirs $fname lappend dir_shortcuts $fname } @@ -1292,7 +1292,7 @@ tcl::namespace::eval punk::nav::fs { set fdisp "" if {[string length $d]} { if {$d in $flaggedhidden} { - set d1 [punk::ansi::a+ cyan normal] + set d1 [punk::ansi::a+ cyan normal] } if {$d in $vfsmounts} { if {$d in $flaggedhidden} { @@ -1313,7 +1313,7 @@ tcl::namespace::eval punk::nav::fs { } } else { if {$d in $nonportable} { - set d1 [punk::ansi::a+ red bold] + set d1 [punk::ansi::a+ red bold] } } #dlink-style & dshortcut_style are for underlines - can be added with colours already set @@ -1336,11 +1336,11 @@ tcl::namespace::eval punk::nav::fs { } lappend displaylist [overtype::left $col1 $d1$d$RST]$f1$fdisp$RST } - + return [punk::lib::list_as_lines $displaylist] - } + } - #pass in base and platform to head towards purity/testability. + #pass in base and platform to head towards purity/testability. #this function can probably never be pure in such a simple form - as it needs to read state from the os storage system configuration #consider haskells approach of well-typed paths for cross-platform paths: https://hackage.haskell.org/package/path #review: punk::winpath calls cygpath! @@ -1360,8 +1360,8 @@ tcl::namespace::eval punk::nav::fs { set path_absolute [punk::unixywindows::towinpath $path] #puts stderr "winpath: $path" } else { - #todo handle volume-relative paths with volume specified c:etc c: - #note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd + #todo handle volume-relative paths with volume specified c:etc c: + #note - tcl doesn't handle this properly anyway.. the win32 api should 'remember' the per-volume cwd #not clear whether tcl can/will fix this - but it means these paths are dangerous. #The cwd of the process can get out of sync with what tcl thinks is the working directory when you swap drives #Arguably if ...? @@ -1421,14 +1421,14 @@ tcl::namespace::eval punk::nav::fs::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::nav::fs::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 + # #[para]Description of utility1 + # return 1 #} @@ -1446,7 +1446,7 @@ tcl::namespace::eval punk::nav::fs::lib { tcl::namespace::eval punk::nav::fs::system { #*** !doctools #[subsection {Namespace punk::nav::fs::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API #ordinary emission of chunklist when no repl proc emit_chunklist {chunklist} { @@ -1471,18 +1471,18 @@ tcl::namespace::eval punk::nav::fs::system { proc codethread_is_running {} { if {[info commands ::punk::repl::codethread::is_running] ne ""} { - return [punk::repl::codethread::is_running] + return [punk::repl::codethread::is_running] } return 0 } } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::nav::fs [tcl::namespace::eval punk::nav::fs { variable pkg punk::nav::fs variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm index ebc24234..cc99157b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.1.tm @@ -8,7 +8,7 @@ global run_commandstr "" set stdin_info [chan configure stdin] if {[dict exists $stdin_info -inputmode]} { - #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. + #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. # tcl_interactive used by repl to determine if stderr output prompt to be printed. # (that way, piping commands into stdin should not produce prompts for each command) set tcl_interactive 1 @@ -63,7 +63,7 @@ if {![info exists ::env(TERM)]} { #todo - move to less generic namespace ie punk::repl namespace eval repl { - variable codethread + variable codethread if {![info exists codethread]} { set codethread "" } @@ -122,12 +122,12 @@ namespace eval punk::repl { puts stderr "^^^^^^^^^^^^^^^^^^^" } proc bgerror {args} { - set message [lindex $args 0] + set message [lindex $args 0] set errdict [lindex $args 1] puts stderr "\n*> repl background error: '$message'" #puts stderr "*> [set ::errorInfo]" puts stderr "*> errorinfo: [dict get $errdict -errorinfo]" - set stdinreader [fileevent stdin readable] + set stdinreader [chan event stdin readable] if {![string length $stdinreader]} { puts stderr "*> stdin reader inactive" } else { @@ -159,8 +159,8 @@ proc ::punk::repl::init_signal_handlers {} { variable signal_control_c_msg switch -- [lindex $args 0] { ctrl-c { - #puts stderr "->event $args" - flush stderr + #puts stderr "->event $args" + flush stderr incr signal_control_c #rputs stderr "* console_control: $args" if {[tsv::get console is_raw]} { @@ -170,7 +170,7 @@ proc ::punk::repl::init_signal_handlers {} { #review - dodgy.. we just want to interrupt child processes but then still be able to interrupt repl set ::punk::repl::signal_control_c 0 set preverr [string map {"child killed" "child_killed"} $::errorInfo] - catch {error $preverr} ;#for errorInfo display + catch {error $preverr} ;#for errorInfo display return 42 } else { #how to let rawmode loop handle it? It doesn't seem to get through if we return 0 @@ -183,7 +183,7 @@ proc ::punk::repl::init_signal_handlers {} { puts stderr "signal ctrl-c error get_size error:$errM" } - if {$signal_control_c < 3} { + if {$signal_control_c < 3} { set remaining [expr {3 - $signal_control_c}] if {[catch { punk::repl::console_controlnotification "[a+ web-orange]ctrl-c ($remaining more to quit, enter to continue)[a]" $console_width $console_height @@ -198,12 +198,12 @@ proc ::punk::repl::init_signal_handlers {} { puts stderr "signal ctrl-c error console_controlnotification error:$errM" } flush stderr - after 25 + after 25 quit return 1 } elseif {$signal_control_c > 5} { #fallback if quit didn't work - #puts stderr "signal ctrl-c $signal_control_c received - sending to default handler" + #puts stderr "signal ctrl-c $signal_control_c received - sending to default handler" if {[catch { punk::repl::console_controlnotification "ctrl-c $signal_control_c received - sending to default handler" $console_width $console_height } errM]} { @@ -214,7 +214,7 @@ proc ::punk::repl::init_signal_handlers {} { return 0 } - return 1 + return 1 #after 200 {exit 42} ;#temp #return 42 } @@ -224,8 +224,8 @@ proc ::punk::repl::init_signal_handlers {} { if {[lindex $::errorCode 0] eq "CHILDKILLED"} { set signal_control_c 0 set preverr [string map {"child killed" "child_killed"} $::errorInfo] - catch {error $preverr} ;#for errorInfo display - return 42 + catch {error $preverr} ;#for errorInfo display + return 42 } if {[catch { lassign [punk::console::get_size] _w console_width _h console_height @@ -252,7 +252,7 @@ proc ::punk::repl::init_signal_handlers {} { puts stderr "signal ctrl-c error console_controlnotification error:$errM" } flush stderr - after 25 + after 25 quit return 1 } elseif {$signal_control_c == 4} { @@ -280,7 +280,7 @@ proc ::punk::repl::init_signal_handlers {} { } } twapi::set_console_control_handler ::punk::repl::handler_console_control - #we can't yet emit from an event with proper prompt handling - + #we can't yet emit from an event with proper prompt handling - #repl::rputs stdout "twapi loaded" } else { #repl::rputs stderr " Failed to load twapi" @@ -360,7 +360,7 @@ proc repl::start {inchan args} { #review if {$codethread eq ""} { error "start - no codethread. call init first. (options -safe 0|1)" - } + } variable commandstr # --- @@ -398,9 +398,9 @@ proc repl::start {inchan args} { namespace eval ::punk::repl::codethread {} set ::punk::repl::codethread::running 1 namespace eval ::punk::ns::ns_current {} - set ::punk::ns::ns_current %ns1% + set ::punk::ns::ns_current %ns1% } - }] + }] set commandstr "" # --- @@ -409,10 +409,10 @@ proc repl::start {inchan args} { set editbuf_linenum_submitted 0 set editbuf_active_index 0 # --- - + if {$::punk::console::ansi_wanted == 2} { if {[::punk::console::test_can_ansi]} { - set ::punk::console::ansi_wanted 1 + set ::punk::console::ansi_wanted 1 } else { set ::punk::console::ansi_wanted -1 } @@ -420,14 +420,14 @@ proc repl::start {inchan args} { puts stderr "-->repl::start active on $inchan $args replthread:[thread::id] codethread:$codethread" set prompt_config [punk::repl::get_prompt_config] doprompt "P% " - fileevent $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] + chan event $inchan readable [list [namespace current]::repl_handler $inchan $prompt_config] set reading 1 - + #catch { # set punk::console::tabwidth [punk::console::get_tabstop_apparent_width] #} vwait [namespace current]::done - fileevent $inchan readable {} + chan event $inchan readable {} #puts stderr "-->start done = $::repl::done" @@ -458,7 +458,7 @@ proc repl::start {inchan args} { } thread::cancel $codethread thread::cond destroy $codethread_cond ;#race if we destroy cond before child thread has exited - as it can send a -async quit - set codethread "" + set codethread "" set codethread_cond "" punk::console::mode line ;#review - revert to line mode on final exit - but we may be exiting a nested repl puts "end repl::start" @@ -498,7 +498,7 @@ proc repl::reopen_stdin {} { puts stderr "restarting repl on inputchannel:$s" return [repl::start $s -title "reopen_stdin a"] } else { - #/dev/tty - reference to the controlling terminal for a process + #/dev/tty - reference to the controlling terminal for a process #review/test set s [open "/dev/tty" r] } @@ -506,7 +506,7 @@ proc repl::reopen_stdin {} { repl::start stdin -title "reopen_stdin b" } -#todo - avoid putting this in gobal namespace? +#todo - avoid putting this in gobal namespace? #collisions with other libraries apps? proc punk::repl::quit {args} { set ::repl::done "quit {*}$args" @@ -518,7 +518,7 @@ proc punk::repl::quit {args} { proc repl::reopen_stdinX {} { #windows - todo unix package require twapi - + if 0 { if {[catch {package require Memchan} errM]} { #package require tcl::chan::fifo2 @@ -527,52 +527,52 @@ proc repl::reopen_stdinX {} { set x [tcl::chan::fifo] } else { #lassign [fifo2] a b - set x [fifo] + set x [fifo] } #first channel opened after stdin closed becomes stdin #use a fifo or fifo2 because [chan pipe] assigns the wrong end first! - #a will be stdin + #a will be stdin } #these can't replace proper stdin (filehandle 0) because they're not 'file backed' or 'os level' #try opening a named pipe server to become stdin set pipename {\\.\pipe\stdin_%id%} set pipename [string map [list %id% [pid]] $pipename] - - - + + + package require tcl::chan::fifo - + chan close stdin - lassign [tcl::chan::fifo] a - - + lassign [tcl::chan::fifo] a + + puts stderr "newchan: $a" puts stderr "|test> $a [chan conf $a]" - + #set server [twapi::namedpipe_server $pipename] #set client [twapi::namedpipe_client $pipename] ;#open a client and connect to the server we just made puts stderr "chan names: [chan names]" - + #by now $server not valid? - #set server stdin - + #set server stdin + #chan configure $server -buffering line -encoding unicode #chan configure $client -buffering line -encoding unicode - + #puts stderr "|test>ns-server $server [chan conf $server]" #puts stderr "|test>ns-client $client [chan conf $client]" - + set conin [twapi::get_console_handle stdin] twapi::set_standard_handle stdin $conin - + set h_in [twapi::get_standard_handle stdin] - + puts stderr "|test> $a [chan conf $a]" - + #chan configure $client -blocking 0 after 2 repl::start $a - + } #add to sliding buffer of last x chars emmitted to screen by repl @@ -642,17 +642,17 @@ proc repl::newout2 {} { #-------------------------------------- proc repl::doprompt {prompt {col {green bold}}} { - #prompt to stderr. + #prompt to stderr. #We can pipe commands into repl's stdin without the prompt interfering with the output. #Although all command output for each line goes to stdout - not just what is emitted with puts - + if {$::tcl_interactive} { flush stdout; #we are writing this prompt on stderr, but stdout could still be writing to screen #our first char on stderr is based on the 'lastchar' of stdout which we have recorded but may not have arrived on screen. #The issue we're trying to avoid is the (stderr)prompt arriving midway through a large stdout chunk #REVIEW - this basic attempt to get stderr/stdout to cooperate is experimental and unlikely to achieve the desired effect in all situations #It the above flush does seem to help though. - #note that our 'flush stdout' tcl call does not wait if stdout is non-blocking + #note that our 'flush stdout' tcl call does not wait if stdout is non-blocking #todo - investigate if the overhead is reasonable for a special channel that accepts stdout and stderr records with a reader to send to console in chunk-sizes we know will be emitted correctly # - reader of such channel could be ok to be blocking (on read? on write to real channels?)... except everything still needs to be interruptable by things like signals? #? - we want ordinary puts to stderr to be prioritized? to arrive on-screen - just not at arbitrary locations within stdout, and still must be correctly ordered wrt all other stderr @@ -682,8 +682,8 @@ proc repl::doprompt {prompt {col {green bold}}} { set prompt [lindex $plines end] } - #this sort of works - but steals some of our stdin data ? review - # + #this sort of works - but steals some of our stdin data ? review + # #lassign [punk::console::get_cursor_pos_list] column row #if {$row != 1} { # set c "\n" @@ -692,7 +692,7 @@ proc repl::doprompt {prompt {col {green bold}}} { set o [a {*}$col] set r [a] puts -nonewline stderr $c$pre$o$prompt$r - screen_last_char_add " " "prompt-stderr" prompt + screen_last_char_add " " "prompt-stderr" prompt flush stderr } } @@ -704,7 +704,7 @@ proc repl::doprompt {prompt {col {green bold}}} { # rputs deliberately doesn't check screen_last_chars before emitting data (unless reporting an error in rputs itself) proc repl::rputs {args} { variable screen_last_chars - variable last_out_was_newline + variable last_out_was_newline variable last_repl_char set pseudo_map [dict create\ @@ -720,7 +720,7 @@ proc repl::rputs {args} { set rputschan [lindex $args 0] #map pseudo-channels to real if {$rputschan in [dict keys $pseudo_map]} { - lset args 0 [dict get $pseudo_map $rputschan] + lset args 0 [dict get $pseudo_map $rputschan] } } elseif {[llength $args] == 1} { set this_tail \n @@ -731,7 +731,7 @@ proc repl::rputs {args} { set rputschan [lindex $args 1] #map pseudo-channels to real if {$rputschan in [dict keys $pseudo_map]} { - lset args 0 [dict get $pseudo_map $rputschan] + lset args 0 [dict get $pseudo_map $rputschan] } } set last_char_info_width 60 @@ -756,7 +756,7 @@ proc repl::rputs {args} { #TODO - something better #failure case: #set x \ud83c\udf1e - #(2 surrogate pairs - treated as single char in tcl8 - fixed in 9 but won't/can't be backported) - + #(2 surrogate pairs - treated as single char in tcl8 - fixed in 9 but won't/can't be backported) - #see also: https://core.tcl-lang.org/tips/doc/trunk/tip/619.md puts stderr "$repl_error" } @@ -816,7 +816,7 @@ proc repl::screen_needs_clearance {} { namespace eval repl { variable startinstance 0 variable loopinstance 0 - variable in_repl_handler [list] + variable in_repl_handler [list] variable last_controlc_count 0 } @@ -831,7 +831,7 @@ namespace eval punk::repl::class { variable o_config variable o_rendered_lines - variable o_remaining ;#? + variable o_remaining ;#? #o_chunk_list & o_chunk_info should make timed viewing of replays possible variable o_chunk_list @@ -850,7 +850,7 @@ namespace eval punk::repl::class { #-- set ch [dict get $configdict rendered_initialchunk] my add_rendered_chunk $ch - } + } set o_context $contextdict #error "[self class].constructor Unable to interpret config '$o_config'" @@ -911,21 +911,21 @@ namespace eval punk::repl::class { if {$o_cursor_col > $line_nextchar_col} { set o_cursor_col $line_nextchar_col } - + set mergedinfo [overtype::renderline -info 1 -expand_right 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $underlay $new0] set result [dict get $mergedinfo result] set o_insert_mode [dict get $mergedinfo insert_mode] set result_col [dict get $mergedinfo cursor_column] set result_row [dict get $mergedinfo cursor_row] - set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v + set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v set unapplied [dict get $mergedinfo unapplied] set instruction [dict get $mergedinfo instruction] set insert_lines_below [dict get $mergedinfo insert_lines_below] set insert_lines_above [dict get $mergedinfo insert_lines_above] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set debug_first_row 2 #puts "merged: $mergedinfo" set debug "add_chunk0" @@ -938,7 +938,7 @@ namespace eval punk::repl::class { } else { #?? } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set o_cursor_col $result_col set cursor_row_idx [expr {$o_cursor_row-1}] @@ -949,7 +949,7 @@ namespace eval punk::repl::class { lf_start { #for normal commandline - we just add a line below lappend o_rendered_lines "" - incr nextrow + incr nextrow set o_cursor_col 1 } } @@ -970,7 +970,7 @@ namespace eval punk::repl::class { set o_rendered_lines [linsert $o_rendered_lines $cursor_row_idx ""] set o_cursor_col 1 } - + set o_cursor_row $nextrow set cursor_row_idx [expr {$o_cursor_row-1}] if {$cursor_row_idx < [llength $o_rendered_lines]} { @@ -991,11 +991,11 @@ namespace eval punk::repl::class { } } #puts stderr "overtype::renderline -info 1 -expand_right 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $activeline '$p'" - set underlay $activeline + set underlay $activeline set line_nextchar_col [expr {[punk::char::string_width $underlay] + 1}] if {$o_cursor_col > $line_nextchar_col} { set o_cursor_col $line_nextchar_col - } + } set mergedinfo [overtype::renderline -info 1 -expand_right 1 -insert_mode $o_insert_mode -cursor_column $o_cursor_col -cursor_row $o_cursor_row $underlay $p] set debug "add_chunk$i" append debug \n $mergedinfo @@ -1007,7 +1007,7 @@ namespace eval punk::repl::class { set o_insert_mode [dict get $mergedinfo insert_mode] set o_cursor_col [dict get $mergedinfo cursor_column] set cmove [dict get $mergedinfo cursor_row] - set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v + set overflow_right [dict get $mergedinfo overflow_right] ;#should be empty if no \v set unapplied [dict get $mergedinfo unapplied] set insert_lines_below [dict get $mergedinfo insert_lines_below] if {[string is integer -strict $cmove]} { @@ -1015,7 +1015,7 @@ namespace eval punk::repl::class { set nextrow [expr {$o_cursor_row + 1}] set o_cursor_col 1 } elseif {$cmove == 1} { - #check for overflow_right and unapplied + #check for overflow_right and unapplied #leave cursor_column } elseif {$cmove >= 1} { @@ -1030,8 +1030,8 @@ namespace eval punk::repl::class { } set o_cursor_row $nextrow if {$insert_lines_below} { - - } + + } set cursor_row_idx [expr {$o_cursor_row-1}] if {$cursor_row_idx < [llength $o_rendered_lines]} { @@ -1042,9 +1042,8 @@ namespace eval punk::repl::class { } lset o_rendered_lines $cursor_row_idx $result - incr i - } - + incr i + } } method add_rendered_chunk {rchunk} { #split only on lf newlines - movement codes and \b \v \r not expected @@ -1053,7 +1052,7 @@ namespace eval punk::repl::class { #but we don't yet have grapheme split info for it if {[regexp {[\v\b\r]} $rchunk]} { - error "[self class].add_rendered_chunk chunk contains \\v or \\b or \\r. Rendered chunk shouldn't contain these characters or ANSI movement codes" + error "[self class].add_rendered_chunk chunk contains \\v or \\b or \\r. Rendered chunk shouldn't contain these characters or ANSI movement codes" } lappend o_chunk_list $rchunk ;#rchunk may contain newlines - that's ok dict set o_chunk_info [expr {[llength $o_chunk_list] -1}] [dict create micros [clock microseconds] type rendered] @@ -1062,15 +1061,15 @@ namespace eval punk::repl::class { #lappend o_chunk_list $rchunk set lastrline [lindex $o_rendered_lines end] - #in renderedlines list merge last line of old with first line of new + #in renderedlines list merge last line of old with first line of new #we can't just cat the newpart on to existing rendered line - the chunk could have split a grapheme (e.g char+combiner(s)) - #we + #we #todo - redo grapheme split on merged line set merged [string cat $lastrline [lindex $newparts 0]] - lset o_rendered_lines end $merged + lset o_rendered_lines end $merged #todo - #each newpart needs its grapheme split info to be stored + #each newpart needs its grapheme split info to be stored #jmn #set o_rendered_lines [concat $o_rendered_lines [lrange $newparts 1 end]] lappend o_rendered_lines {*}[lrange $newparts 1 end] @@ -1111,7 +1110,7 @@ namespace eval punk::repl::class { #todo - index base??? method lines_numbered {args} { - #build a paired list so we don't have to do various calcs on end+ end- etc checking llength + #build a paired list so we don't have to do various calcs on end+ end- etc checking llength #punk::lib::range will use lseq if available - else use it's own slower code set max [llength $o_rendered_lines] ;#assume >=1 set nums [punk::lib::range 1 $max] @@ -1151,7 +1150,7 @@ namespace eval punk::repl::class { #1-based method view_lines {args} { set llist [my lines {*}$args] - return [join $llist \n] + return [join $llist \n] } method view_lines_numbered {args} { set ANSI_linenum [a+ green] @@ -1191,7 +1190,7 @@ namespace eval punk::repl::class { foreach ln $o_rendered_lines { append result [ansistring VIEW -lf 1 -vt 1 $ln] \n ;#should be no lf or vt - but if there is.. we'd better show it } - append result \n "cursor row: $o_cursor_row col: $o_cursor_col" + append result \n "cursor row: $o_cursor_row col: $o_cursor_col" return $result } method last_char {} { @@ -1237,13 +1236,13 @@ namespace eval punk::repl::class { } return $result } - + method debugview_chunks {} { set result "" foreach ln $o_chunk_list { append result [ansistring VIEW -lf 1 -vt 1 $ln] \n } - append result \n "cursor row: $o_cursor_row col: $o_cursor_col" + append result \n "cursor row: $o_cursor_row col: $o_cursor_col" return $result } method view_raw {} { @@ -1310,7 +1309,7 @@ proc punk::repl::repl_handler_restorechannel_if_not_eof {inputchan previous_inpu rputs stderr "|repl>original: [ansistring VIEW $previous_input_state]" rputs stderr "|repl>current : [ansistring VIEW [chan conf $inputchan]]" rputs stderr "\n|repl> Failed to return $inputchan to original state" - rputs stderr "|repl>ERR: $errM" + rputs stderr "|repl>ERR: $errM" } } return [chan conf $inputchan] @@ -1318,7 +1317,7 @@ proc punk::repl::repl_handler_restorechannel_if_not_eof {inputchan previous_inpu proc repl::repl_handler {inputchan prompt_config} { # -- review variable in_repl_handler - set in_repl_handler [list $inputchan $prompt_config] + set in_repl_handler [list $inputchan $prompt_config] # -- variable last_controlc_count @@ -1328,12 +1327,12 @@ proc repl::repl_handler {inputchan prompt_config} { set prompt_reset_flag 0 } - fileevent $inputchan readable {} + chan event $inputchan readable {} upvar ::punk::console::input_chunks_waiting input_chunks_waiting #note -inputmode not available in Tcl 8.6 for chan configure! #According to DKF - -buffering option doesn't affect input channels set rawmode 0 - set original_input_conf [chan configure $inputchan] ;#whether repl is in line or raw mode - we restore the inputchan (stdin) state + set original_input_conf [chan configure $inputchan] ;#whether repl is in line or raw mode - we restore the inputchan (stdin) state if {[dict exists $original_input_conf -inputmode]} { if {[dict get $original_input_conf -inputmode] eq "raw"} { #user or script has apparently put stdin into raw mode - update punk::console::is_raw to match @@ -1344,20 +1343,20 @@ proc repl::repl_handler {inputchan prompt_config} { #set ::punk::console::is_raw 0 tsv::set console is_raw 0 } - #what about enable/disable virtualTerminal ? - #using stdin -inputmode to switch modes won't set virtualterminal input state appropriately + #what about enable/disable virtualTerminal ? + #using stdin -inputmode to switch modes won't set virtualterminal input state appropriately #we expect the state of -inputmode to be 'normal' even though we flip it during the read part of our repl loop #if it's been set to raw - assume it is deliberately done this way as the user could have alternatively called punk::mode raw or punk::console::enableVirtualTerminal #by not doing this automatically - we assume the caller has a reason. } else { #JMN FIX! - #this returns 0 in rawmode on 8.6 after repl thread changes + #this returns 0 in rawmode on 8.6 after repl thread changes #set rawmode [set ::punk::console::is_raw] set rawmode [tsv::get console is_raw] } if {!$rawmode} { - #linemode + #linemode #stdin with line-mode readable events (at least on windows for Tcl 8.7a6 to 9.0a) can get stuck with bytes pending when input longer than 100chars - even though there is a linefeed further on than that. #This potentially affects a reasonable number of Tcl8.7 kit/tclsh binaries out in the wild. @@ -1365,14 +1364,14 @@ proc repl::repl_handler {inputchan prompt_config} { #when in non-blocking mode we will have to read that in to get further - but we don't know if that was the end of line or if there is more - and we may not get a newline even though one was present originally on stdin. #presence of 8.7 buffering bug will result in unrecoverable situation - even switching to raw and using read will not be able to retrieve tail data. #the readable event only gives us 200 bytes (same problem may be at 4k/8k in other versions) - #This occurs whether we use gets or read - + #This occurs whether we use gets or read - set stdinlines [list] if {[dict get $original_input_conf -blocking] ne "0"} { chan configure $inputchan -blocking 0 } set waitingchunk "" - #review - input_chunks_waiting in line mode - + #review - input_chunks_waiting in line mode - if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { #puts stderr "repl_handler input_chunks_waiting($inputchan) while in line mode. Had data:[ansistring VIEW -lf 1 $input_chunks_waiting($inputchan)]" set allwaiting [join $input_chunks_waiting($inputchan) ""] @@ -1404,7 +1403,7 @@ proc repl::repl_handler {inputchan prompt_config} { if {[chan blocked $inputchan]} { #REVIEW - #todo - figure out why we're here. - #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) + #can we even put a spinner so we don't keep emitting lines? We probably can't use any ansi functions that need to get a response on stdin..(like get_cursor_pos) #punk::console::get_size is problematic if -winsize not available on the stdout channel - which is the case for certain 8.6 versions at least.. platform variances? ## can't do this: set screeninfo [punk::console::get_size]; lassign $screeninfo _c cols _r rows set outconf [chan configure stdout] @@ -1415,9 +1414,9 @@ proc repl::repl_handler {inputchan prompt_config} { set msg "${RED}$inputchan chan blocked is true.$RST \{$allwaiting\}" } set cols "" - set rows "" + set rows "" if {[dict exists $outconf -winsize]} { - lassign [dict get $outconf -winsize] cols rows + lassign [dict get $outconf -winsize] cols rows } else { #fallback - try external executable. Which is a bit ugly #tput can't seem to get dimensions (on FreeBSD at least) when not run interactively - ie via exec. (always returns 80x24 no matter if run with <@stdin) @@ -1425,13 +1424,13 @@ proc repl::repl_handler {inputchan prompt_config} { #bizarrely - tput can work with exec on windows if it's installed e.g from msys2 #but can be *slow* compared to unix e.g 400ms+ vs <2ms on FreeBSD ! #stty -a is 400ms+ vs 500us+ on FreeBSD - + if {"windows" eq $::tcl_platform(platform)} { set tputcmd [auto_execok tput] if {$tputcmd ne ""} { if {![catch {exec {*}$tputcmd cols lines} values]} { lassign $values cols rows - } + } } } @@ -1445,7 +1444,7 @@ proc repl::repl_handler {inputchan prompt_config} { #the more parseable: stty -g doesn't give rows/columns if {![catch {exec {*}$sttycmd -a} result]} { lassign [split $result \n] firstline - set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? + set lineparts [split $firstline {;}] ;#we seem to get segments that look well behaved enough to be treated as tcl lists - review - regex? set rowinfo [lsearch -index end -inline $lineparts rows] if {[llength $rowinfo] == 2} { set rows [lindex $rowinfo 0] @@ -1463,14 +1462,14 @@ proc repl::repl_handler {inputchan prompt_config} { #puts -nonewline stdout [punk::ansi::move $rows 4]$msg #use cursorsave_ version which avoids get_cursor_pos_list call set msglen [ansistring length $msg] - punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg + punk::console::cursorsave_move_emitblock_return $rows [expr {$cols - $msglen -1}] $msg } else { - #no mechanism to get console dimensions + #no mechanism to get console dimensions #we are reduced to continuously spewing lines. puts stderr $msg } - after 100 + after 100 } set input_chunks_waiting($inputchan) [list $allwaiting] } @@ -1501,7 +1500,7 @@ proc repl::repl_handler {inputchan prompt_config} { } else { #rawmode if {[info exists input_chunks_waiting($inputchan)] && [llength $input_chunks_waiting($inputchan)]} { - #we could concat and process as if one chunk - but for now at least - we want to preserve the 'chunkiness' + #we could concat and process as if one chunk - but for now at least - we want to preserve the 'chunkiness' set chunkwaiting_zero [lpop input_chunks_waiting($inputchan) 0] ;#pop off lhs of wait list (tcl 8.6 is tcl imp of lpop - a little slower) uplevel #0 [list repl::repl_process_data $inputchan raw-waiting $chunkwaiting_zero [list] $prompt_config] } else { @@ -1531,7 +1530,7 @@ proc repl::repl_handler {inputchan prompt_config} { uplevel #0 [list repl::repl_process_data $inputchan raw-read $chunk [list] $prompt_config] while {[llength $input_chunks_waiting($inputchan)]} { set chunkzero [lpop input_chunks_waiting($inputchan) 0] - if {$chunkzero eq ""} {continue} ;#why empty waiting - and is there any point passing on? + if {$chunkzero eq ""} {continue} ;#why empty waiting - and is there any point passing on? uplevel #0 [list repl::repl_process_data $inputchan raw-waiting $chunkzero [list] $prompt_config] } } @@ -1543,15 +1542,15 @@ proc repl::repl_handler {inputchan prompt_config} { #Re-enable channel read handler only if no waiting chunks - must process in order ################################################################################## if {![llength $input_chunks_waiting($inputchan)]} { - fileevent $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] + chan event $inputchan readable [list ::repl::repl_handler $inputchan $prompt_config] } else { after idle [list ::repl::repl_handler $inputchan $prompt_config] } #################################################### } else { #repl_handler_checkchannel $inputchan - fileevent $inputchan readable {} - set reading 0 + chan event $inputchan readable {} + set reading 0 thread::send -async $::repl::codethread {set ::punk::repl::codethread::running 0} if {$::tcl_interactive} { rputs stderr "\nrepl_handler EOF inputchannel:[chan conf $inputchan]" @@ -1598,7 +1597,7 @@ proc punk::repl::console_debugview {editbuf consolewidth args} { set opt_chunktype [dict get $opts -chunktype] set opt_rightmargin [dict get $opts -rightmargin] - #debugview_raw frame + #debugview_raw frame set RST [a] if {[catch { set info [$editbuf debugview_raw] @@ -1627,10 +1626,10 @@ proc punk::repl::console_debugview {editbuf consolewidth args} { set spacepatch [textblock::block $debug_width $patch_height " "] #puts -nonewline [punk::ansi::cursor_off] punk::console::cursor_off - #use non cursorsave versions - cursor save/restore will interfere with any concurrent ansi rendering that uses save/restore - because save/restore is a single item, not a stack. + #use non cursorsave versions - cursor save/restore will interfere with any concurrent ansi rendering that uses save/restore - because save/restore is a single item, not a stack. set debug_offset [expr {$consolewidth - $debug_width - $opt_rightmargin}] set row_clear [expr {$opt_row -2}] - punk::console::move_emitblock_return $row_clear $debug_offset $spacepatch + punk::console::move_emitblock_return $row_clear $debug_offset $spacepatch punk::console::move_emitblock_return $opt_row $debug_offset $info set topleft [list $debug_offset $opt_row] ;#col,row REVIEW #puts -nonewline [punk::ansi::cursor_on] @@ -1675,7 +1674,7 @@ proc punk::repl::console_editbufview {editbuf consolewidth args} { set editbuf_offset [expr {$consolewidth - $editbuf_width - $opt_rightmargin}] set row_clear [expr {$opt_row -2}] - punk::console::cursorsave_move_emitblock_return $row_clear $editbuf_offset $spacepatch + punk::console::cursorsave_move_emitblock_return $row_clear $editbuf_offset $spacepatch punk::console::cursorsave_move_emitblock_return $opt_row $editbuf_offset $info return [dict create width $editbuf_width] @@ -1719,7 +1718,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config variable editbuf variable editbuf_list variable editbuf_linenum_submitted - + # --- variable reading variable id_outstack @@ -1750,16 +1749,16 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #single loop while to allow break on escape while {$onetime && [string length $chunk] >= 0 } { set onetime 0 - #punk::console::move_emitblock_return 20 120 $chunklen-->[chan conf stdin]<-- + #punk::console::move_emitblock_return 20 120 $chunklen-->[chan conf stdin]<-- #if {$chunklen == 0} { # #document examples of when we expect zero-byte chunk # #1) ctrl-z - # #review + # #review # rputs stderr "->0byte read stdin" # if {[chan eof $inputchan]} { - # fileevent $inputchan readable {} - # set reading 0 + # chan event $inputchan readable {} + # set reading 0 # #set running 0 # if {$::tcl_interactive} { # rputs stderr "\n|repl> EOF on $inputchan." @@ -1769,7 +1768,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config # #JMN # #tailcall repl::reopen_stdin # } - # break + # break #} #set info1 "read $chunklen bytes->[ansistring VIEW -lf 1 -vt 1 $chunk]" @@ -1778,11 +1777,11 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config # terminals (by default) generally use a lone cr to represent enter (LNM reset ie CSI 20l) #(as per above doc: "For compatibility with Digital's software you should keep LNM reset (line feed)") - #You can insert an lf using ctrl-j - and of course stdin could have crlf or lf + #You can insert an lf using ctrl-j - and of course stdin could have crlf or lf #pasting from notepad++ with mixed line endings seems to paste everything ok #we don't really know the source of input keyboard vs paste vs pipe - and whether a read has potentially chopped a crl in half.. #possibly no real way to determine that. We could wait a small time to see if there's more data coming.. and potentially impact performance. - #Instead we'll try to make sense of it here. + #Instead we'll try to make sense of it here. if {$chunklen == 1} { #presume it's a keypress from terminal @@ -1793,25 +1792,25 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config if {[string first \n $chunk] < 0} { set chunk [string map {\r \n} $chunk] } - #else - + #else - #has lf - but what if last char is cr? #It may require user to hit enter - probably ok. - #could be a sequence of cr's from holding enter key + #could be a sequence of cr's from holding enter key } #review - we can receive chars such as escapes or arrow inline with other data even from keyboard if keys are pushed quickly (or automated?) # - so we probably shouldn't really rely on whether a char arrives alone in a chunk as a factor in its behaviour #On the other hand - timing of keystrokes could be legitimate indications of intention in a cli ? - #esc or ctrl-lb + #esc or ctrl-lb if {$chunk eq "\x1b"} { #return - set stdinlines [list "\x1b"] + set stdinlines [list "\x1b"] set commandstr "" - set chunk "" + set chunk "" $editbuf clear_tail screen_last_char_add \x1b stdin escape - break + break } #if ProcessedInput is disabled - we can get ctrl-c, but then we wouldn't be in raw mode and wouldn't be here. @@ -1820,16 +1819,16 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #ctrl-c if {$chunk eq "\x03"} { #::punk::repl::handler_console_control "ctrl-c_via_rawloop" - error "character 03 -> ctrl-c" + error "character 03 -> ctrl-c" } - + if {$chunk eq "\x7f"} { #review - configurable? #translate raw del to backspace del for those terminals that send plain del set chunk "\b\x7f" } elseif {$chunk eq "\x7f\x7f"} { #commonly if key held down we will get 2 dels in a row - #review - could get more in a row depending on hardware/os + #review - could get more in a row depending on hardware/os set chunk "\b\x7f\b\x7f" } elseif {$chunk eq "\x1c"} { #ctrl-bslash @@ -1839,7 +1838,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config after 250 {exit 42} return } elseif {$chunk eq "\x1a"} { - #for now - exit with small delay for tidyup + #for now - exit with small delay for tidyup #ctrl-z #::punk::repl::handler_console_control "ctrl-z_via_rawloop" if {[catch {mode line}]} { @@ -1852,7 +1851,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #we *could* intercept arrow keys here before they are handled in the editbuf #but there should only be the need to do so for situations where we aren't editing a commandline #if {$chunk eq "\x1b\[D"} { - # #rputs stderr "${debugprompt}arrow-left D" + # #rputs stderr "${debugprompt}arrow-left D" # #set commandstr "" # #punk::console::move_back 1 ;#terminal does it anyway? #} @@ -1861,7 +1860,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config $editbuf add_chunk $chunk - #-------------------------- + #-------------------------- # editbuf and debugview rhs frames #for now disable entirely on vt52 - we can only do cursor save restore - nothing that requires responses on stdin (?) if {!$is_vt52 && [set ::punk::console::ansi_available]} { @@ -1870,7 +1869,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #testing each time is very inefficient (1+ms) #unfortunately there isn't an easy way to get such an event on windows console based systems - REVIEW. set do_checkwidth 1 ;#make configurable if performance hit is too severe? TODO - set consolewidth 132 + set consolewidth 132 if {$do_checkwidth} { if {[catch {set consolewidth [dict get [punk::console::get_size] columns]} errM]} { #review @@ -1890,7 +1889,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set clearance [expr {$debug_width + $rightmargin}] set space_occupied [punk::repl::console_editbufview $editbuf $consolewidth -row 10 -rightmargin $clearance] } - #-------------------------- + #-------------------------- set lines_unsubmitted [expr {[$editbuf linecount] - $editbuf_linenum_submitted}] @@ -1915,7 +1914,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config puts -nonewline stdout "\x1b\[B" } flush stdout - + set leftmargin 3 @@ -1944,8 +1943,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config if {[string length $waiting] > 0} { set waiting [a+ yellow bold]$waiting[a] #puts stderr "waiting $waiting" - $editbuf clear_tail - lappend input_chunks_waiting($inputchan) $waiting + $editbuf clear_tail + lappend input_chunks_waiting($inputchan) $waiting } } if {$editbuf_linenum_submitted == 0} { @@ -1958,7 +1957,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config if {$nextsubmit_line_num < $last_line_num} { foreach ln [$editbuf lines $nextsubmit_line_num end-1] { lappend stdinlines $ln - incr editbuf_linenum_submitted + incr editbuf_linenum_submitted } } } @@ -1970,11 +1969,11 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config rputs stderr "trap1 POSIX '$e' eopts:'$eopts" flush stderr } on error {repl_error erropts} { - rputs stderr "error1 in repl_handler: $repl_error" + rputs stderr "error1 in repl_handler: $repl_error" rputs stderr "-------------" rputs stderr "$::errorInfo" rputs stderr "-------------" - set stdinreader [fileevent $inputchan readable] + set stdinreader [chan event $inputchan readable] if {![string length $stdinreader]} { rputs stderr "*> $inputchan reader inactive" } else { @@ -2013,7 +2012,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config if {$linenum == 0} { doprompt "E% " {yellow bold} set line "" - #screen_last_char_add " " empty empty + #screen_last_char_add " " empty empty } else { doprompt "\nE% " {yellow bold} #screen_last_char_add "\n" empty empty ;#add \n to indicate noclearance required @@ -2026,7 +2025,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #set commandstr "" } if {$line eq "\x1b\[D"} { - #rputs stderr "${debugprompt}arrow-left D" + #rputs stderr "${debugprompt}arrow-left D" #set commandstr "" #punk::console::move_back 1 } @@ -2070,7 +2069,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config } else { #append commandstr $line #puts "0=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" - append commandstr $line + append commandstr $line } #puts "=============>[string length $commandstr] bytes , [string map [list \r -r- \n -n-] $commandstr] , info complete:[info complete $line]" @@ -2092,7 +2091,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set errstack [list] - #oneshot repl debug + #oneshot repl debug set wordparts [regexp -inline -all {\S+} $commandstr] lassign $wordparts cmd_firstword cmd_secondword if {$cmd_firstword eq "debugrepl"} { @@ -2143,9 +2142,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #work around weird behaviour in tcl 8.6 & 8.7a5 (at least) part1 #https://wiki.tcl-lang.org/page/representation #/scriptlib/tests/listrep_bug.tcl - #after the uplevel #0 $commandstr call + #after the uplevel #0 $commandstr call # vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value - #review - although the rep change is weird - what actual problem was caused aside from an unexpected shimmer? + #review - although the rep change is weird - what actual problem was caused aside from an unexpected shimmer? #probably just that the repl can't then be used to debug representation issues and possibly that the performance is not ideal for list pipeline commands(?) #now that we eval in another thread and interp - we seem to lose the list rep anyway. #(unless we also save the script in that interp too in a run_command_cache) @@ -2157,7 +2156,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set repl_runid [tsv::incr repl runid] tsv::set repl runchunks-$repl_runid [list] ;#last_run_display catch { - #REVIEW - when we launch a subshell and run more than 10 commands, + #REVIEW - when we launch a subshell and run more than 10 commands, #we delete runchunks from the outer shell that we'll return to! #we should use a toplevel key pertaining to the shell/subshell instead of just 'repl' tsv::unset repl runchunks-[expr {$repl_runid - 10}] @@ -2178,7 +2177,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #} variable codethread - variable codethread_cond + variable codethread_cond variable codethread_mutex lappend errstack [shellfilter::stack::add stderr tee_to_var -settings {-varname ::repl::output_stderr}] @@ -2186,7 +2185,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #chan configure stdout -buffering none #JMN - fileevent $inputchan readable {} + chan event $inputchan readable {} set reading 0 #don't let unknown use 'args' to convert commandstr to list #=============================================================================== @@ -2206,7 +2205,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config while {[set status [tsv::get codethread_$codethread status]] == -1} { thread::cond wait $codethread_cond $codethread_mutex 50 update ;#we need a full update here to allow interrupts to be processed - #While update is often considered risky - here we know our input channel readable event has been disabled - so re-entrancy shouldn't be possible. + #While update is often considered risky - here we know our input channel readable event has been disabled - so re-entrancy shouldn't be possible. #however - child thread can send quit - transferring processing from here back to repl::start - which then ends - making a mess (child not yet finished when trying to tidy up) #we should give the child a way to quit by setting a tsv we pick up here *after the while loop* - and then we can set done. } @@ -2283,9 +2282,9 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config screen_last_char_add "\uFFFF" clearance "clearance after direct unknown call" if {[tsv::llength repl runchunks-$repl_runid]} { if {$status == 0} { - set result [tsv::get repl runchunks-$repl_runid] ;#last_run_display + set result [tsv::get repl runchunks-$repl_runid] ;#last_run_display } else { - + } set result_is_chunk_list 1 } @@ -2302,11 +2301,11 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set cdisplay [punk::ansi::ansistring::VIEW -lf 1 -vt 1 $c] #assertion cdisplay has no raw newlines if {[punk::char::ansifreestring_width $cdisplay] == 1} { - set cdisplay "$cdisplay " ;#make 2 wide + set cdisplay "$cdisplay " ;#make 2 wide } if {[string match repl-debugreport* $whatinfo]} { - #exclude noise debug_repl_emit - but still show the last_char - set whysummary "" + #exclude noise debug_repl_emit - but still show the last_char + set whysummary "" } else { #set whysummary [string map [list \n "-n-"] $whyinfo] set whysummary [punk::ansi::ansistring::VIEW -lf 1 -vt 1 $whyinfo] @@ -2328,11 +2327,11 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #puts stderr "'$::repl::output_stdout' lastoutchar:'$lastoutchar' result:'$result'" - #$command is an unevaluated script at this point - # so may not be a well formed list e.g 'set x [list a "b"]' + #$command is an unevaluated script at this point + # so may not be a well formed list e.g 'set x [list a "b"]' #- lindex $command would sometimes fail #if {[lindex $command 0] eq "runx"} {} - + if { [string equal -length [string length "d/ "] "d/ " $commandstr] || \ @@ -2358,10 +2357,10 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config } # -- --- --- --- --- --- --- --- --- --- - ##an attempt to preserve underlying rep + ##an attempt to preserve underlying rep ##this is not for performance - just to be less disruptive to underlying rep to aid in learning/debugging # -- --- --- --- --- --- --- --- --- --- - # JN 2023 - The lrange operation is destructive to path internal representation + # JN 2023 - The lrange operation is destructive to path internal representation # The lrange operation is destructive to strings with leading/trailing newlines # -- --- --- --- --- --- --- --- --- --- #set saved_errorCode $::errorCode @@ -2374,12 +2373,12 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config # set is_result_empty [expr {[llength $result_as_list] == 0}] #} # -- --- --- --- --- --- --- --- --- --- - #set resultrep [::tcl::unsupported::representation $result] + #set resultrep [::tcl::unsupported::representation $result] set is_result_empty [expr {$result eq ""}] - + #catch {puts stderr "yy--->[rep $::arglej]"} - + set reading 1 if {!$is_result_empty} { if {$status == 0} { @@ -2418,7 +2417,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config } else { #----------------------------------------------------------- # avoid repl forcing string rep of simple results. This is just to aid analysis using tcl::unsupported::representation - #set rparts [split $result {}] + #set rparts [split $result {}] #if {[lsearch $rparts \n] < 0} { # #type of $result unaffected # rputs "$resultprompt $result" @@ -2427,7 +2426,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config # rputs $resultprompt[string map [list \n "\n$resultprompt"] $result] #} #----------------------------------------------------------- - + #we have copied rawresult using append with empty string - so our string interaction with result var here shouldn't affect the returned value #empty-string result handled in other branch if {![tsv::llength repl runchunks-$repl_runid]} { @@ -2437,7 +2436,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set flat [string map [list \r\n "" \n ""] $result] if {[string length $flat] == [string length $result]} { #no line-endings in data - rputs "$resultprompt$result" + rputs "$resultprompt$result" } else { #if {[string index $result end] eq "\n"} { # set result [string range $result 0 end-1] @@ -2453,7 +2452,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config set h [textblock::height $result] set promptcol [string repeat $resultprompt\n $h] set promptcol [string range $promptcol 0 end-1] - #promptcol is uniform-width lines, result may not be. We are ok to join with ragged rhs col here, so use join_basic instead of join + #promptcol is uniform-width lines, result may not be. We are ok to join with ragged rhs col here, so use join_basic instead of join rputs [textblock::join_basic -- $promptcol $result] #orig @@ -2486,7 +2485,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config } } } - + set c [a yellow bold] set n [a] rputs stderr $c$result$n @@ -2497,7 +2496,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #doprompt "P% " "green normal" if {$linenum == 0} { doprompt "P% " "green normal" - screen_last_char_add " " empty empty + screen_last_char_add " " empty empty } else { doprompt "\nP% " "green normal" screen_last_char_add "\n" empty empty ;#add \n to indicate noclearance required @@ -2530,7 +2529,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #append commandstr \n if {$::punk::repl::signal_control_c} { set ::punk::repl::signal_control_c 0 - fileevent $inputchan readable {} + chan event $inputchan readable {} rputs stderr "* console_control: control-c" flush stderr set c [a yellow bold] @@ -2542,12 +2541,12 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config flush stdout } else { - #Incomplete command + #Incomplete command # parse and determine outermost unclosed quote/bracket and include in prompt if {$linenum == $maxlinenum} { if {$rawmode} { #review - #we haven't put the data following last le into commandstr - but we want to display proper completion status prior to enter being hit or more data coming in. + #we haven't put the data following last le into commandstr - but we want to display proper completion status prior to enter being hit or more data coming in. #this could give spurious results for large pastes where buffering chunks it in odd places.? #it does however give sensible output for the common case of a small paste where the last line ending wasn't included set waiting [punk::lib::system::incomplete $commandstr[$editbuf line end]] @@ -2572,14 +2571,14 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config if {$maxlinenum == -1} { #when in raw mode - no linefeed yet received #rputs stderr "repl: no complete input line: $commandstr" - #screen_last_char_add "\n" empty empty + #screen_last_char_add "\n" empty empty + + screen_last_char_add [string index [$editbuf line end] end] stdinchunk stdinchunk - screen_last_char_add [string index [$editbuf line end] end] stdinchunk stdinchunk - } - #fileevent $inputchan readable [list repl::repl_handler $inputchan $prompt_config] + #chan event $inputchan readable [list repl::repl_handler $inputchan $prompt_config] #catch {puts stderr "zend--->[rep $::arglej]"} @@ -2587,11 +2586,11 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config rputs stderr "trap POSIX '$e' eopts:'$eopts" flush stderr } on error {repl_error erropts} { - rputs stderr "error in repl_handler: $repl_error" + rputs stderr "error in repl_handler: $repl_error" rputs stderr "-------------" rputs stderr "$::errorInfo" rputs stderr "-------------" - set stdinreader [fileevent $inputchan readable] + set stdinreader [chan event $inputchan readable] if {![string length $stdinreader]} { rputs stderr "*> $inputchan reader inactive" } else { @@ -2664,7 +2663,7 @@ namespace eval repl { error "repl:init codethread: $codethread already exists. use -force 1 to override" } set codethread [thread::create -preserved] - #review - naming of the possibly 2 cond variables parent and child thread + #review - naming of the possibly 2 cond variables parent and child thread set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread) set codethread_mutex [thread::mutex create] @@ -2683,13 +2682,13 @@ namespace eval repl { set init_script { set ::argv0 %argv0% set ::argv %argv% - set ::argc %argc% + set ::argc %argc% tcl::tm::remove {*}[tcl::tm::list] tcl::tm::add {*}[lreverse %tmlist%] ;#Must be added in reverse order to get same order as original list! #this sets the auto_path in the thread but outside of the code interp that will be created. #It will also need to be added in that interp - set ::auto_path %autopath% + set ::auto_path %autopath% set tclmajorv [lindex [split [tcl::info::tclversion] .] 0] #jmn2 #puts stdout "CODETHREAD tm list" @@ -2744,13 +2743,13 @@ namespace eval repl { #it will need to delegate to a call here in the main interp of the codethread using an installed alias set md5version [package require md5] #we also need to 'package provide md5 $md5version' in the safe interp itself so that it won't override - + #punk::configure_unknown ;#must be called because we hacked the tcl 'unknown' proc #child codethread (outside of code interp) needs to know details of the calling repl set ::punk::repl::codethread::replthread %replthread% ;#point to thread id of parent thread (repl) - set ::punk::repl::codethread::replthread_cond %replthread_cond% + set ::punk::repl::codethread::replthread_cond %replthread_cond% set ::punk::repl::codethread::replthread_interp %replthread_interp% # -- --- --- --- @@ -2759,7 +2758,7 @@ namespace eval repl { # -- --- --- --- namespace eval ::repl::interphelpers { proc quit {args} { - #child codethreads run in a 'code' interp therefore if they started another repl - it is within the 'code' interp in that thread + #child codethreads run in a 'code' interp therefore if they started another repl - it is within the 'code' interp in that thread # whereas the first repl launched in the process runs in root interp "" thread::send -async %replthread% [list interp eval %replthread_interp% ::punk::repl::quit] } @@ -2787,8 +2786,8 @@ namespace eval repl { if {[llength $args]} { #colour call was not a query set new_state [thread::send %replthread% [list punk::console::colour {*}$args]] - if {[expr {$new_state}] ne [expr {$colour_state}]} { - interp eval code [list punk::console::colour {*}$args] ;#align code interp's view of colour state with repl thread + if {[expr {$new_state}] ne [expr {$colour_state}]} { + interp eval code [list punk::console::colour {*}$args] ;#align code interp's view of colour state with repl thread #we don't want to run a raw script directly in our code interp if we're using variables #because we will potentially collide with user vars in that context (or create vars there) - so use apply @@ -2836,7 +2835,7 @@ namespace eval repl { #punk repl tsv wrappers proc set_repl_last_unknown args { - tsv::set repl last_unknown {*}$args + tsv::set repl last_unknown {*}$args } proc get_repl_runid args { if {[tsv::exists repl runid]} { @@ -2864,9 +2863,9 @@ namespace eval repl { puts stderr "safebase: $msg" } } - + namespace eval ::repl::interphelpers::repl_ensemble { - namespace export {[a-z]*} + namespace export {[a-z]*} namespace ensemble create namespace ensemble configure [namespace current] -unknown ::repl::interphelpers::repl_ensemble_unknown variable replinfo @@ -2882,8 +2881,8 @@ namespace eval repl { thread::send %replthread% $script } proc stack {} { - set iname %replthread_interp% - set tid %replthread% + set iname %replthread_interp% + set tid %replthread% lappend stack [list thread $tid interp $iname] while {$iname eq "code"} { set iname [thread::send $tid {set ::punk::repl::codethread::replthread_interp}] @@ -2894,7 +2893,7 @@ namespace eval repl { } } namespace eval ::repl::interphelpers::subshell_ensemble { - namespace export {[a-z]*} + namespace export {[a-z]*} namespace ensemble create proc punk {} { set ts_start [clock seconds] @@ -2943,8 +2942,8 @@ namespace eval repl { #flush stdout set args %args% - set safe [dict get $args -safe] - set safelog [dict get $args -safelog] + set safe [dict get $args -safe] + set safelog [dict get $args -safelog] set paths [list] if {[dict exists $args -paths]} { set paths [dict get $args -paths] @@ -2960,9 +2959,9 @@ namespace eval repl { code alias "file normalize" "file normalize" code alias "file dirname" "file dirname" code alias "file exists" "file exists" - code alias ::tcl::file::normalize ::tcl::file::normalize - code alias ::tcl::file::dirname ::tcl::file::dirname - code alias ::tcl::file::exists ::tcl::file::exists + code alias ::tcl::file::normalize ::tcl::file::normalize + code alias ::tcl::file::dirname ::tcl::file::dirname + code alias ::tcl::file::exists ::tcl::file::exists #code alias ::punk::console::colour ::punk::console::colour } punksafe { @@ -2972,9 +2971,9 @@ namespace eval repl { code alias "file normalize" "file normalize" code alias "file dirname" "file dirname" code alias "file exists" "file exists" - code alias ::tcl::file::normalize ::tcl::file::normalize - code alias ::tcl::file::dirname ::tcl::file::dirname - code alias ::tcl::file::exists ::tcl::file::exists + code alias ::tcl::file::normalize ::tcl::file::normalize + code alias ::tcl::file::dirname ::tcl::file::dirname + code alias ::tcl::file::exists ::tcl::file::exists code alias ::punk::console::colour ::punk::console::colour } punk - 0 { @@ -2983,7 +2982,7 @@ namespace eval repl { punkisland { interp create code #todo - #when no island paths specified - should be like safebase, but without folder hiding and with expanded read to ::auto_path folders + #when no island paths specified - should be like safebase, but without folder hiding and with expanded read to ::auto_path folders } } @@ -3095,7 +3094,7 @@ namespace eval repl { if {[file exists $path]} { set data [readFile $path] code eval [list info script $path] - code eval $data + code eval $data code eval [list info script $prior_infoscript] } else { error "safe - failed to find $path" @@ -3120,7 +3119,7 @@ namespace eval repl { #interp eval code { # set ::argv0 %argv0% # set ::auto_path %autopath% - #} + #} interp eval code [list set ::tcl_platform(os) $::tcl_platform(os)] interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)] interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)] @@ -3161,7 +3160,7 @@ namespace eval repl { set ::argv {} #puts stdout "safebase interp" #flush stdout - } + } interp eval code [list set ::tcl_platform(os) $::tcl_platform(os)] interp eval code [list set ::tcl_platform(osVersion) $::tcl_platform(osVersion)] interp eval code [list set ::tcl_platform(machine) $::tcl_platform(machine)] @@ -3200,16 +3199,16 @@ namespace eval repl { safe::interpAddToAccessPath code [file join $termbase ansi] safe::interpAddToAccessPath code [file join $termbase ansi code] } - #safe::interpAddToAccessPath code NUL + #safe::interpAddToAccessPath code NUL if {$safelog ne ""} { #setting setLogCmd here gives potentially interesting feedback regarding behaviour of things such as glob - safe::setLogCmd $safelog + safe::setLogCmd $safelog } #code invokehidden source c:/repo/jn/shellspy/modules/punk/lib-0.1.1.tm code alias detok ::safe::DetokPath code ;#temp - this violates the point of the {$p(:X:)} paths - #review - exit should do something slightly different + #review - exit should do something slightly different # see ::safe::interpDelete code alias exit ::repl::interphelpers::quit @@ -3298,7 +3297,7 @@ namespace eval repl { #puts stderr "loading natsort" #natsort has 'application mode' which can exit. #Requiring it shouldn't trigger application - but zipfs/vfs interactions confused it in some early versions - package require natsort + package require natsort #package require punk ;# Thread #package require shellrun ;#subcommand exists of file @@ -3321,13 +3320,13 @@ namespace eval repl { error "$errM" } - } + } } punk - 0 { interp eval code { #safe !=1 and safe !=2, tmlist: %tmlist% - set ::argv0 %argv0% + set ::argv0 %argv0% set ::argv %argv% set ::argc %argc% set ::auto_path %autopath% @@ -3339,12 +3338,12 @@ namespace eval repl { #review #we have to blow some time on a rescan to provide more deterministic ordering (match behaviour of initial thread regarding pkg precedence) #review - can we speed that scan up? - ##catch {package require flobrudder-nonexistant} + ##catch {package require flobrudder-nonexistant} # -- --- if {[catch { package require vfs - package require vfs::zip + package require vfs::zip } errM]} { puts stderr "repl code interp can't load vfs,vfs::zip" } @@ -3359,7 +3358,7 @@ namespace eval repl { #puts stderr "loading natsort" #natsort has 'application mode' which can exit. #Requiring it shouldn't trigger application - but zipfs/vfs interactions confused it in some early versions - package require natsort + package require natsort #catch {package require packageTrace} package require punk package require punk::args @@ -3404,7 +3403,7 @@ namespace eval repl { #JMN #code alias cmdtype ::repl::interphelpers::cmdtype - #temporary debug aliases - deliberate violation of safety provided by safe interp + #temporary debug aliases - deliberate violation of safety provided by safe interp code alias escapeeval ::repl::interphelpers::escapeeval @@ -3431,11 +3430,11 @@ namespace eval repl { error $errMsg } } - #init - don't auto init - require init with possible options e.g -safe + #init - don't auto init - require init with possible options e.g -safe } package provide punk::repl [namespace eval punk::repl { variable version - set version 0.1.1 + set version 0.1.1 }] #repl::start $program_read_stdin_pipe 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 feee9d87..a64eef0f 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 @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::repl::codethread 0 0.1.1] #[copyright "2024"] #[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] -#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] +#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] #[require punk::repl::codethread] #[keywords module repl] #[description] -#[para] This is part of the infrastructure required for the punk::repl to operate +#[para] This is part of the infrastructure required for the punk::repl to operate # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -122,7 +122,7 @@ tcl::namespace::eval punk::repl::codethread { #*** !doctools #[subsection {Namespace punk::repl::codethread}] - #[para] Core API functions for punk::repl::codethread + #[para] Core API functions for punk::repl::codethread #[list_begin definitions] @@ -130,13 +130,13 @@ tcl::namespace::eval punk::repl::codethread { #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" #} variable run_command_cache @@ -145,7 +145,7 @@ tcl::namespace::eval punk::repl::codethread { #if {[catch {interp children}]} { # #8.6.10 doesn't have it.. when was it introduced? #} else { - + #} proc is_running {} { @@ -153,14 +153,14 @@ tcl::namespace::eval punk::repl::codethread { return $running } proc runscript {script} { - + #puts stderr "->runscript" - variable replthread_cond + variable replthread_cond #variable output_stdout "" #variable output_stderr "" #expecting to be called from a thread::send in parent repl - ie in the toplevel interp so that the sub-interp "code" is available - #if a thread::send is done from the commandline in a codethread - Tcl will + #if a thread::send is done from the commandline in a codethread - Tcl will if {![interp exists code] || ![info exists replthread_cond]} { #in case someone tries calling from codethread directly - don't do anything or change any state #(direct caller could create an interp named code at the level "" -> "code" -"code" and add a replthread_cond value to avoid this check - but it probably won't do anything useful) @@ -233,12 +233,12 @@ tcl::namespace::eval punk::repl::codethread { flush stderr #interp transfer code $errhandle "" - #flush $errhandle + #flush $errhandle #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stdout]] end] #set lastoutchar [string index [punk::ansi::ansistrip [interp eval code [list set ::punk::repl::codethread::output_stdout]]] end] - set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] + set lastoutpart [interp eval code {string range $::punk::repl::codethread::output_stdout end-100 end}] #note we could be in a *large* ansi segment such as sixel data - #review - why do we need to ansistrip? + #review - why do we need to ansistrip? set lastoutchar [string index [punk::ansi::ansistrip $lastoutpart] end] #set lasterrchar [string index [punk::ansi::ansistrip [interp eval code set ::punk::repl::codethread::output_stderr]] end] @@ -247,7 +247,7 @@ tcl::namespace::eval punk::repl::codethread { #puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" set tid [thread::id] - tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] + tsv::set codethread_$tid info [list lastoutchar $lastoutchar lasterrchar $lasterrchar] tsv::set codethread_$tid status $status tsv::set codethread_$tid result $result tsv::set codethread_$tid errorcode $::errorCode @@ -277,14 +277,14 @@ tcl::namespace::eval punk::repl::codethread::lib { tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::repl::codethread::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 + # #[para]Description of utility1 + # return 1 #} @@ -302,17 +302,17 @@ tcl::namespace::eval punk::repl::codethread::lib { tcl::namespace::eval punk::repl::codethread::system { #*** !doctools #[subsection {Namespace punk::repl::codethread::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::repl::codethread [tcl::namespace::eval punk::repl::codethread { variable pkg punk::repl::codethread variable version - set version 0.1.1 + set version 0.1.1 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/sshrun-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/sshrun-0.1.0.tm index 1b91629b..0e708817 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/sshrun-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/sshrun-0.1.0.tm @@ -8,7 +8,7 @@ # @@ Meta Begin # Application punk::sshrun 0.1.0 # Meta platform tcl -# Meta license ISC +# Meta license ISC # @@ Meta End # Copyright (c) 2009 Jose F. Nieves @@ -33,14 +33,14 @@ #[manpage_begin punkshell_module_punk::sshrun 0 0.1.0] #[copyright "2009"] #[titledesc {Tcl procedures to execute tcl scripts in remote hosts}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk::sshrun tclssh clone}] [comment {-- Description at end of page heading --}] +#[moddesc {punk::sshrun tclssh clone}] [comment {-- Description at end of page heading --}] #[require punk::sshrun] #[keywords module ssh] #[description] -#[para] This is a clone of tclssh by Jose F. Nieves +#[para] This is a clone of tclssh by Jose F. Nieves #[para] The original repo is at: https://bitbucket.org/noaaport/tclssh/src/master/ #[para] This version is namespaced under punk::sshrun specifically for the Punk shell project - and may lag the original project or diverge. -#[para] You are encouraged to use the original Tclssh source from the above URL for your own projects +#[para] You are encouraged to use the original Tclssh source from the above URL for your own projects # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -49,7 +49,7 @@ #[para] overview of punk::sshrun #[para] SYNOPSIS #[para] package require punk::sshrun -#[para] - +#[para] - #[para] punk::sshrun::connect [lb]-t [rb] [lb]-- [rb] [lb]@[rb] #[para] Defaults: -t tclsh #[subsection Concepts] @@ -127,22 +127,22 @@ namespace eval punk::sshrun { #*** !doctools #[subsection {Namespace punk::sshrun}] - #[para] Core API functions for punk::sshrun + #[para] Core API functions for punk::sshrun #[list_begin definitions] proc connect {args} { #*** !doctools #[call connect [arg args]] - #[para] Must be called first. + #[para] Must be called first. #[para] This proc opens an io channel to the tclsh in the remote host (via ssh) that is kept in an internal variable for subsequent use. - #[para] The file handle can be retrieved if desired through the command: get_filehandle {host} + #[para] The file handle can be retrieved if desired through the command: get_filehandle {host} variable ssh; set usage {connect [-t ] [-- ] [@]}; set optlist {{t.arg "tclsh"}}; - + array set option [::cmdline::getoptions args $optlist $usage]; set cmd [concat "|ssh" $args $option(t) 2>@ stdout]; set F [open $cmd r+]; @@ -200,7 +200,7 @@ namespace eval punk::sshrun { # [call send [arg host]] # [para]This proc does the equivalent of a # [example { - # puts [join \n] + # puts [join \n] # flush # }] variable ssh; @@ -242,9 +242,9 @@ namespace eval punk::sshrun { # [example { # [gets line] # }] - upvar $line_varname line; + upvar $line_varname line; variable ssh; - + system::_verify_connection $host; set r [gets $ssh($host,F) line]; return $r; @@ -264,9 +264,9 @@ namespace eval punk::sshrun { # [para](see the send_exit proc above) # [para]The function returns the number of lines read (0 if nothing is read before encoutering eof) # - upvar $output_varname output; + upvar $output_varname output; variable ssh; - + system::_verify_connection $host; set r 0; @@ -283,11 +283,11 @@ namespace eval punk::sshrun { #*** !doctools # [call pop_read [arg host] [arg numbytes] [arg output_varname]] # [para] Returns: numbytes read. If numbytes is not positive, then read is called without the numbytes argument. - upvar $output_varname output; + upvar $output_varname output; variable ssh; - + system::_verify_connection $host; - + if {$numbytes <= 0} { set output [read $ssh($host,F)]; } else { @@ -306,7 +306,7 @@ namespace eval punk::sshrun { # }] variable ssh; system::_verify_connection $host; - fileevent $ssh($host,F) $readable_writable $script; + chan event $ssh($host,F) $readable_writable $script; } proc hfconfigure {host args} { @@ -314,7 +314,7 @@ namespace eval punk::sshrun { # [call hconfigure [arg host] [arg args]] variable ssh; system::_verify_connection $host; - eval fconfigure $ssh($host,F) $args; + eval chan configure $ssh($host,F) $args; } proc rexec {host script output_varname} { @@ -322,8 +322,8 @@ namespace eval punk::sshrun { # [call rexec [arg host] [arg script] [arg output_varname]] # [para] shortcut for: # [example { - # ssh::rexec_nopop $host $script - # ssh::pop_all $host outputvar + # ssh::rexec_nopop $host $script + # ssh::pop_all $host outputvar # }] upvar $output_varname output; rexec_nopop $host $script; @@ -392,7 +392,7 @@ namespace eval punk::sshrun { # [call get_filehandle [arg host]] variable ssh; system::_verify_connection $host; - + return $ssh($host,F); } @@ -410,14 +410,14 @@ namespace eval punk::sshrun::lib { namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::sshrun::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 + # #[para]Description of utility1 + # return 1 #} @@ -435,7 +435,7 @@ namespace eval punk::sshrun::lib { namespace eval punk::sshrun::system { #*** !doctools #[subsection {Namespace punk::sshrun::system}] - #[para] Internal functions that are not part of the API + #[para] Internal functions that are not part of the API # # private @@ -452,11 +452,11 @@ namespace eval punk::sshrun::system { } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::sshrun [namespace eval punk::sshrun { variable pkg punk::sshrun variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/timeinterval-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/timeinterval-0.1.0.tm index 8c674bd3..e0a8dd80 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/timeinterval-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/timeinterval-0.1.0.tm @@ -16,7 +16,7 @@ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements -##e.g package require frobz +package require punk::args @@ -27,40 +27,65 @@ # namespace eval punk::timeinterval { - proc clock_scan_interval { seconds delta units } { - # clock_scan_interval formats $seconds to a string for processing by clock scan - # then returns new timestamp in seconds - set stamp [clock format $seconds -format "%Y%m%dT%H%M%S"] - if { $delta < 0 } { - append stamp " - " [expr { abs( $delta ) } ] " " $units - } else { - append stamp " + " $delta " " $units - } - return [clock scan $stamp] - } - - namespace export difference - #wrap in dict + #The free-form 'clock scan' is deprecated. It worked in 8.4 to 8.6/8.7 (and earlier?) - but doesn't work in tcl9 + #proc clock_scan_interval { seconds delta units } { + # # clock_scan_interval formats $seconds to a string for processing by clock scan + # # then returns new timestamp in seconds + # set stamp [clock format $seconds -format "%Y%m%dT%H%M%S"] + # if { $delta < 0 } { + # append stamp " - " [expr { abs( $delta ) } ] " " $units + # } else { + # append stamp " + " $delta " " $units + # } + # return [clock scan $stamp] + #} + + #proc clock_scan_interval { seconds delta units } { + # #8.6+ + # clock add $seconds $delta $units + #} - proc difference {s1 s2} { - lassign [interval_ymdhs $s1 $s2] Y M D h m s - return [dict create years $Y months $M days $D hours $h minutes $m seconds $s] - } + namespace export difference - proc interval_ymdhs { s1 s2 } { - # interval_ymdhs calculates the interval of time between - # the earliest date and the last date - # by starting to count at the earliest date. + lappend PUNKARGS [list { + @id -id "::punk::timeinterval::difference" + @cmd -name "punk::timeinterval::difference" -help\ + "difference calculates the interval of time between + the earliest date and the last date + by starting to count at the earliest date. + It returns a dictionary with keys: + years months days hours minutes seconds" + @opts + -maxunit -default years -choices {years months days hours minutes seconds} -help\ + "If maxunit is specified, the resulting dict will still contain all keys, + but keys for larger units will be zero. + e.g when -maxunit is months, years will be zero but months could be + something like 36. + " + -timezone -default "" -help\ + "If unspecified, the timezone will be the + current time zone on the system" + @values -min 2 -max 2 + s1 + s2 + }] + proc difference {args} { + set argd [punk::args::parse $args withid ::punk::timeinterval::difference] + lassign [dict values $argd] leaders opts values received + set maxunit [dict get $opts -maxunit] + set timezone [dict get $opts -timezone] + set s1 [dict get $values s1] + set s2 [dict get $values s2] # This proc has audit features. It will automatically # attempt to correct and report any discrepancies it finds. # if s1 and s2 aren't in seconds, convert to seconds. if { ![string is integer -strict $s1] } { - set s1 [clock scan $s1] + set s1 [clock scan $s1 -timezone $timezone] } if { ![string is integer -strict $s2] } { - set s2 [clock scan $s2] + set s2 [clock scan $s2 -timezone $timezone] } # postgreSQL intervals determine month length based on earliest date in interval calculations. @@ -68,7 +93,7 @@ namespace eval punk::timeinterval { set sn_list [lsort -integer [list $s1 $s2]] set s1 [lindex $sn_list 0] set s2 [lindex $sn_list 1] - + # Arithmetic is done from most significant to least significant # The interval is spanned in largest units first. # A new position s1_pN is calculated for the Nth move along the interval. @@ -77,212 +102,240 @@ namespace eval punk::timeinterval { # Calculate years from s1_p0 to s2 set y_count 0 set s1_p0 $s1 - set s2_y_check $s1_p0 - while { $s2_y_check <= $s2 } { - set s1_p1 $s2_y_check - set y $y_count - incr y_count - set s2_y_check [clock_scan_interval $s1_p0 $y_count years] - } - # interval s1_p0 to s1_p1 counted in y years + if {$maxunit eq "years"} { + set s2_y_check $s1_p0 + while { $s2_y_check <= $s2 } { + set s1_p1 $s2_y_check + set y $y_count + incr y_count + set s2_y_check [clock add $s1_p0 $y_count years -timezone $timezone] + } + # interval s1_p0 to s1_p1 counted in y years - # is the base offset incremented one too much? - set s2_y_check [clock_scan_interval $s1 $y years] - if { $s2_y_check > $s2 } { - set y [expr { $y - 1 } ] - set s2_y_check [clock_scan_interval $s1 $y years] - } - # increment s1 (s1_p0) forward y years to s1_p1 - if { $y == 0 } { - set s1_p1 $s1 + # is the base offset incremented one too much? + set s2_y_check [clock add $s1 $y years -timezone $timezone] + if { $s2_y_check > $s2 } { + set y [expr { $y - 1 } ] + set s2_y_check [clock add $s1 $y years -timezone $timezone] + } + # increment s1 (s1_p0) forward y years to s1_p1 + if { $y == 0 } { + set s1_p1 $s1 + } else { + set s1_p1 [clock add $s1 $y years -timezone $timezone] + } } else { - set s1_p1 [clock_scan_interval $s1 $y years] + set y 0 + set s1_p1 $s1 } # interval s1 to s1_p1 counted in y years # Calculate months from s1_p1 to s2 set m_count 0 set s2_m_check $s1_p1 - while { $s2_m_check <= $s2 } { - set s1_p2 $s2_m_check - set m $m_count - incr m_count - set s2_m_check [clock_scan_interval $s1_p1 $m_count months] + set s1_p2 $s1_p1 ;#? + set m 0 + if {$maxunit in {years months}} { + while { $s2_m_check <= $s2 } { + set s1_p2 $s2_m_check + set m $m_count + incr m_count + set s2_m_check [clock add $s1_p1 $m_count months -timezone $timezone] + } } # interval s1_p1 to s1_p2 counted in m months - # Calculate interval s1_p2 to s2 in days - # day_in_sec [expr { 60 * 60 * 24 } ] - # 86400 - # Since length of month is not relative, use math. - # Clip any fractional part. - set d [expr { int( ( $s2 - $s1_p2 ) / 86400. ) } ] - # Ideally, this should always be true, but daylight savings.. - # so, go backward one day and make hourly steps for last day. - if { $d > 0 } { - incr d -1 + + set d 0 + set s1_p3 $s1_p2 + if {$maxunit in {years months days}} { + # Calculate interval s1_p2 to s2 in days + # day_in_sec [expr { 60 * 60 * 24 } ] + # 86400 + # Since length of month is not relative, use math. + # Clip any fractional part. + set d [expr { int( ( $s2 - $s1_p2 ) / 86400. ) } ] + # Ideally, this should always be true, but daylight savings.. + # so, go backward one day and make hourly steps for last day. + if { $d > 0 } { + incr d -1 + } + # Move interval from s1_p2 to s1_p3 + set s1_p3 [clock add $s1_p2 $d days -timezone $timezone] } - # Move interval from s1_p2 to s1_p3 - set s1_p3 [clock_scan_interval $s1_p2 $d days] # s1_p3 is less than a day from s2 - # Calculate interval s1_p3 to s2 in hours - # hour_in_sec [expr { 60 * 60 } ] - # 3600 - set h [expr { int( ( $s2 - $s1_p3 ) / 3600. ) } ] - # Move interval from s1_p3 to s1_p4 - set s1_p4 [clock_scan_interval $s1_p3 $h hours] - # s1_p4 is less than an hour from s2 + set h 0 + set s1_p4 $s1_p3 + if {$maxunit in {years months days hours}} { + # Calculate interval s1_p3 to s2 in hours + # hour_in_sec [expr { 60 * 60 } ] + # 3600 + set h [expr { int( ( $s2 - $s1_p3 ) / 3600. ) } ] + # Move interval from s1_p3 to s1_p4 + set s1_p4 [clock add $s1_p3 $h hours -timezone $timezone] + # s1_p4 is less than an hour from s2 + } # Sometimes h = 24, yet is already included as a day! # For example, this case: - # interval_ymdhs 20010410T000000 19570613T000000 + # difference 20010410T000000 19570613T000000 # from Age() example in PostgreSQL documentation: # http://www.postgresql.org/docs/9.1/static/functions-datetime.html # psql test=# select age(timestamp '2001-04-10', timestamp '1957-06-13'); - # age + # age # ------------------------- # 43 years 9 mons 27 days # (1 row) # According to LibreCalc, the difference is 16007 days - #puts "s2=s1+16007days? [clock format [clock_scan_interval $s1 16007 days] -format %Y%m%dT%H%M%S]" - # ^ this calc is consistent with 16007 days + #puts "s2=s1+16007days? [clock format [clock add $s1 16007 days] -format %Y%m%dT%H%M%S]" + # ^ this calc is consistent with 16007 days # So, let's ignore the Postgresql irregularity for now. # Here's more background: # http://www.postgresql.org/message-id/5A86CA18-593F-4517-BB83-995115A6A402@morth.org # http://www.postgresql.org/message-id/200707060844.l668i89w097496@wwwmaster.postgresql.org # So, Postgres had a bug.. - # Sanity check: if over 24 or 48 hours, push it up to a day unit - set h_in_days [expr { int( $h / 24. ) } ] - if { $h >= 1 } { - # adjust hours to less than a day - set h [expr { $h - ( 24 * $h_in_days ) } ] - incr d $h_in_days - set h_correction_p 1 - } else { - set h_correction_p 0 + if {$maxunit in {years months days}} { + # Sanity check: if over 24 or 48 hours, push it up to a day unit + set h_in_days [expr { int( $h / 24. ) } ] + if { $h >= 1 } { + # adjust hours to less than a day + set h [expr { $h - ( 24 * $h_in_days ) } ] + incr d $h_in_days + set h_correction_p 1 + } else { + set h_correction_p 0 + } } - # Calculate interval s1_p4 to s2 in minutes - # minute_in_sec [expr { 60 } ] - # 60 - set mm [expr { int( ( $s2 - $s1_p4 ) / 60. ) } ] - # Move interval from s1_p4 to s1_p5 - set s1_p5 [clock_scan_interval $s1_p4 $mm minutes] - # Sanity check: if 60 minutes, push it up to an hour unit - if { $mm >= 60 } { - # adjust 60 minutes to 1 hour - # puts "interval_ymdhs: debug info mm - 60, h + 1" - set mm [expr { $mm - 60 } ] - incr h - set mm_correction_p 1 - } else { - set mm_correction_p 0 + set mm 0 + set s1_p5 $s1_p4 + if {$maxunit in {years months days hours minutes}} { + # Calculate interval s1_p4 to s2 in minutes + # minute_in_sec [expr { 60 } ] + # 60 + set mm [expr { int( ( $s2 - $s1_p4 ) / 60. ) } ] + # Move interval from s1_p4 to s1_p5 + set s1_p5 [clock add $s1_p4 $mm minutes -timezone $timezone] + } + + if {$maxunit in {years months days hours}} { + # Sanity check: if 60 minutes, push it up to an hour unit + if { $mm >= 60 } { + # adjust 60 minutes to 1 hour + # puts "difference: debug info mm - 60, h + 1" + set mm [expr { $mm - 60 } ] + incr h + set mm_correction_p 1 + } else { + set mm_correction_p 0 + } } # Calculate interval s1_p5 to s2 in seconds set s [expr { int( $s2 - $s1_p5 ) } ] - # Sanity check: if 60 seconds, push it up to one minute unit - if { $s >= 60 } { - # adjust 60 minutes to 1 hour - set s [expr { $s - 60 } ] - incr mm - set s_correction_p 1 - } else { - set s_correction_p 0 + if {$maxunit in {years months days hours minutes}} { + # Sanity check: if 60 seconds, push it up to one minute unit + if { $s >= 60 } { + # adjust 60 minutes to 1 hour + set s [expr { $s - 60 } ] + incr mm + set s_correction_p 1 + } else { + set s_correction_p 0 + } } - set return_list [list $y $m $d $h $mm $s] + #set return_list [list $y $m $d $h $mm $s] + set return_list [dict create years $y months $m days $d hours $h minutes $mm seconds $s] # test results by adding difference to s1 to get s2: - set i 0 - set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] set signs_inconsistent_p 0 - foreach unit {years months days hours minutes seconds} { - set t_term [lindex $return_list $i] - if { $t_term != 0 } { + set diffterms [list] + dict for {unit t_term} $return_list { + if {$t_term != 0} { if { $t_term > 0 } { - append s1_test " + $t_term $unit" + lappend diffterms +$t_term $unit } else { - append s1_test " - [expr { abs( $t_term ) } ] $unit" + lappend diffterms -[expr { abs( $t_term ) }] $unit set signs_inconsistent_p 1 } } - incr i } - - set s2_test [clock scan $s1_test] - # puts "test s2 '$s2_test' from: '$s1_test'" - set counter 0 + + + #set s2_test [clock scan $s1_test] + set s2_test [clock add $s1 {*}$diffterms -timezone $timezone] + + # puts "test s2 '$s2_test' from: '$s1_test'" + set counter 0 while { $s2 ne $s2_test && $counter < 30 } { set s2_diff [expr { $s2_test - $s2 } ] - puts "\ninterval_ymdhs: debug s1 $s1 s2 $s2 y $y m $m d $d h $h s $s s2_diff $s2_diff" + puts "difference: debug s1 $s1 s2 $s2 y $y m $m d $d h $h s $s s2_diff $s2_diff" set absdiff [expr {abs($s2_diff)}] if { $absdiff > 86399 } { if { $s2_diff > 0 } { incr d -1 - puts "interval_ymdhs: debug, audit adjustment. decreasing 1 day to $d" + puts "difference: debug, audit adjustment. decreasing 1 day to $d" } else { incr d - puts "interval_ymdhs: debug, audit adjustment. increasing 1 day to $d" + puts "difference: debug, audit adjustment. increasing 1 day to $d" } } elseif { $absdiff > 3599 } { if { $s2_diff > 0 } { incr h -1 - puts "interval_ymdhs: debug, audit adjustment. decreasing 1 hour to $h" + puts "difference: debug, audit adjustment. decreasing 1 hour to $h" } else { incr h - puts "interval_ymdhs: debug, audit adjustment. increasing 1 hour to $h" + puts "difference: debug, audit adjustment. increasing 1 hour to $h" } } elseif { $absdiff > 59 } { if { $s2_diff > 0 } { incr mm -1 - puts "interval_ymdhs: debug, audit adjustment. decreasing 1 minute to $mm" + puts "difference: debug, audit adjustment. decreasing 1 minute to $mm" } else { incr mm - puts "interval_ymdhs: debug, audit adjustment. increasing 1 minute to $mm" + puts "difference: debug, audit adjustment. increasing 1 minute to $mm" } } elseif { $absdiff > 0 } { if { $s2_diff > 0 } { incr s -1 - puts "interval_ymdhs: debug, audit adjustment. decreasing 1 second to $s" + puts "difference: debug, audit adjustment. decreasing 1 second to $s" } else { incr s - puts "interval_ymdhs: debug, audit adjustment. increasing 1 second to $s" + puts "difference: debug, audit adjustment. increasing 1 second to $s" } } - - set return_list [list $y $m $d $h $mm $s] + + set return_list [dict create years $y months $m days $d hours $h minutes $mm seconds $s] # set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]] - + # test results by adding difference to s1 to get s2: - set i 0 - set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] - foreach unit {years months days hours minutes seconds} { - set t_term [lindex $return_list $i] + set diffterms [list] + dict for {unit t_term} $return_list { if { $t_term != 0 } { if { $t_term > 0 } { - append s1_test " + $t_term $unit" + lappend diffterms +$t_term $unit } else { - append s1_test " - [expr { abs( $t_term ) } ] $unit" + lappend diffterms -[expr { abs( $t_term ) }] $unit } } - incr i } - set s2_test [clock scan $s1_test] + set s2_test [clock add $s1 {*}$diffterms -timezone $timezone] + incr counter } - if { ( $counter > 0 || $signs_inconsistent_p ) && ( $h_correction_p || $mm_correction_p || $s_correction_p ) } { - # puts "interval_ymdhs: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}" - } + #if { ( $counter > 0 || $signs_inconsistent_p ) && ( $h_correction_p || $mm_correction_p || $s_correction_p ) } { + # puts "difference: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}" + #} if { $signs_inconsistent_p } { - puts "\ninterval_ymdhs: signs inconsistent y $y m $m d $d h $h mm $mm s $s" + puts "\punk::timeinterval::difference - signs inconsistent y $y m $m d $d h $h mm $mm s $s" } if { $s2 eq $s2_test } { return $return_list @@ -290,23 +343,19 @@ namespace eval punk::timeinterval { set s2_diff [expr { $s2_test - $s2 } ] puts "debug s1 $s1 s1_p1 $s1_p1 s1_p2 $s1_p2 s1_p3 $s1_p3 s1_p4 $s1_p4" puts "debug y $y m $m d $d h $h mm $mm s $s" - puts "interval_ymdhs error: s2 is '$s2' but s2_test is '$s2_test' a difference of ${s2_diff} from s1 '$s1_test'." - # error "result audit fails" "error: s2 is $s2 but s2_test is '$s2_test' a difference of ${s2_diff} from: '$s1_test'." + puts "punk::timeinterval::difference - error: s2 is '$s2' but s2_test is '$s2_test' a difference of ${s2_diff} from s1 '$s1_test'." + error "punk::timeinterval::difference result audit fail" "error: s2 is $s2 but s2_test is '$s2_test' a difference of ${s2_diff} from: '$s1_test'." } } - proc interval_ymdhs_w_units { t1 t2 } { - # interval_ymdhs_w_units - # returns interval_ymdhs values with units - set v_list [interval_ymdhs $t2 $t1] - set i 0 - set a "" - foreach f {years months days hours minutes seconds} { - append a "[lindex $v_list $i] $f \n" - incr i - } - return $a - } + +} + +tcl::namespace::eval punk::timeinterval::experimental { + #The interval_remains.. functions were part of the original code from the wiki + #Updated to use clock add etc - but the result seems to be off by one for the value of days - review + #The original purpose of these functions isn't clearly understood - perhaps it was just a different + #mechanism to calculate the interval as a crosscheck? proc interval_remains_ymdhs { s1 s2 } { @@ -328,7 +377,7 @@ namespace eval punk::timeinterval { set sn_list [lsort -decreasing -integer [list $s1 $s2]] set s1 [lindex $sn_list 0] set s2 [lindex $sn_list 1] - + # Arithmetic is done from most significant to least significant # The interval is spanned in largest units first. # A new position s1_pN is calculated for the Nth move along the interval. @@ -342,7 +391,7 @@ namespace eval punk::timeinterval { set s1_p1 $s2_y_check set y $y_count incr y_count -1 - set s2_y_check [clock_scan_interval $s1_p0 $y_count years] + set s2_y_check [clock add $s1_p0 $y_count years] } # interval s1_p0 to s1_p1 counted in y years @@ -354,7 +403,7 @@ namespace eval punk::timeinterval { set s1_p2 $s2_m_check set m $m_count incr m_count -1 - set s2_m_check [clock_scan_interval $s1_p1 $m_count months] + set s2_m_check [clock add $s1_p1 $m_count months] } # interval s1_p1 to s1_p2 counted in m months @@ -371,7 +420,7 @@ namespace eval punk::timeinterval { } # Move interval from s1_p2 to s1_p3 - set s1_p3 [clock_scan_interval $s1_p2 $d days] + set s1_p3 [clock add $s1_p2 $d days] # s1_p3 is less than a day from s2 @@ -380,7 +429,7 @@ namespace eval punk::timeinterval { # 3600 set h [expr { int( ceil( ( $s2 - $s1_p3 ) / 3600. ) ) } ] # Move interval from s1_p3 to s1_p4 - set s1_p4 [clock_scan_interval $s1_p3 $h hours] + set s1_p4 [clock add $s1_p3 $h hours] # s1_p4 is less than an hour from s2 # Sanity check: if over 24 or 48 hours, push it up to a day unit @@ -399,7 +448,7 @@ namespace eval punk::timeinterval { # 60 set mm [expr { int( ceil( ( $s2 - $s1_p4 ) / 60. ) ) } ] # Move interval from s1_p4 to s1_p5 - set s1_p5 [clock_scan_interval $s1_p4 $mm minutes] + set s1_p5 [clock add $s1_p4 $mm minutes] # Sanity check: if 60 minutes, push it up to an hour unit if { $mm <= -60 } { @@ -430,21 +479,25 @@ namespace eval punk::timeinterval { # test results by adding difference to s1 to get s2: set i 0 - set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] + #set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] set signs_inconsistent_p 0 + set diffterms [list] foreach unit {years months days hours minutes seconds} { set t_term [lindex $return_list $i] if { $t_term != 0 } { if { $t_term > 0 } { - append s1_test " + $t_term $unit" + #append s1_test " + $t_term $unit" + lappend diffterms +$t_term $unit set signs_inconsistent_p 1 } else { - append s1_test " - [expr { abs( $t_term ) } ] $unit" + #append s1_test " - [expr { abs( $t_term ) } ] $unit" + lappend diffterms -[expr { abs( $t_term ) } ] $unit } } incr i } - set s2_test [clock scan $s1_test] + #set s2_test [clock scan $s1_test] + set s2_test [clock add $s1 {*}$diffterms] set counter 0 while { $s2 ne $s2_test && $counter < 3 } { @@ -484,29 +537,33 @@ namespace eval punk::timeinterval { puts "interval_remains_ymdhs: debug, audit adjustment. increasing 1 second to $s" } } - + set return_list [list $y $m $d $h $mm $s] # set return_list [list [expr { abs($y) } ] [expr { abs($m) } ] [expr { abs($d) } ] [expr { abs($h) } ] [expr { abs($mm) } ] [expr { abs($s) } ]] - + # test results by adding difference to s1 to get s2: set i 0 - set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] + #set s1_test [clock format $s1 -format "%Y%m%dT%H%M%S"] + set diffterms [list] foreach unit {years months days hours minutes seconds} { set t_term [lindex $return_list $i] if { $t_term != 0 } { if { $t_term > 0 } { - append s1_test " + $t_term $unit" + #append s1_test " + $t_term $unit" + lappend diffterms +$t_term $unit } else { - append s1_test " - [expr { abs( $t_term ) } ] $unit" + #append s1_test " - [expr { abs( $t_term ) } ] $unit" + lappend diffterms -[expr { abs( $t_term ) } ] $unit } } incr i } - set s2_test [clock scan $s1_test] + #set s2_test [clock scan $s1_test] + set s2_test [clock add $s1 {*}$diffterms] incr counter } if { ( $counter > 0 || $signs_inconsistent_p ) && ( $h_correction_p || $mm_correction_p || $s_correction_p ) } { - # puts "interval_remains_ymdhs: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}" + # puts "interval_remains_ymdhs: Corrections in the main calculation were applied: h ${h_correction_p}, mm ${mm_correction_p}, s ${s_correction_p}" } if { $signs_inconsistent_p } { puts "\ninterval_remains_ymdhs: signs inconsistent y $y m $m d $d h $h mm $mm s $s" @@ -523,10 +580,11 @@ namespace eval punk::timeinterval { } + proc interval_remains_ymdhs_w_units { t1 t2 } { # interval_remains_ymdhs_w_units # returns interval_remains_ymdhs values with units - set v_list [interval_ymdhs $t2 $t1] + set v_list [interval_remains_ymdhs $t2 $t1] set i 0 set a "" foreach f {years months days hours minutes seconds} { @@ -541,9 +599,105 @@ namespace eval punk::timeinterval { +# == === === === === === === === === === === === === === === +# Sample 'about' function with punk::args documentation +# == === === === === === === === === === === === === === === +tcl::namespace::eval punk::timeinterval { + tcl::namespace::export {[a-zA-Z]*} ;# Convention: export all lowercase + variable PUNKARGS + variable PUNKARGS_aliases + lappend PUNKARGS [list { + @id -id "(package)punk::timeinterval" + @package -name "punk::timeinterval" -help\ + "time interval from wiki" + }] + namespace eval argdoc { + #namespace for custom argument documentation + proc package_name {} { + return punk::timeinterval + } + proc about_topics {} { + #info commands results are returned in an arbitrary order (like array keys) + set topic_funs [info commands [namespace current]::get_topic_*] + set about_topics [list] + foreach f $topic_funs { + set tail [namespace tail $f] + lappend about_topics [string range $tail [string length get_topic_] end] + } + #Adjust this function or 'default_topics' if a different order is required + return [lsort $about_topics] + } + proc default_topics {} {return [list Description *]} + + # ------------------------------------------------------------- + # get_topic_ functions add more to auto-include in about topics + # ------------------------------------------------------------- + proc get_topic_Description {} { + punk::args::lib::tstr [string trim { + package punk::timeinterval + basic time interval calculations + } \n] + } + proc get_topic_License {} { + return "X11" + } + proc get_topic_Version {} { + return "$::punk::timeinterval::version" + } + proc get_topic_Contributors {} { + set authors {{various "https://wiki.tcl-lang.org/page/Measuring+time+intervals+%28between+two+timestamps%29+with+months+etc"} {Julian Noble }} + set contributors "" + foreach a $authors { + append contributors $a \n + } + if {[string index $contributors end] eq "\n"} { + set contributors [string range $contributors 0 end-1] + } + return $contributors + } + proc get_topic_notes {} { + punk::args::lib::tstr -return string { + X11 license - is MIT with additional clause regarding use of contributor names. + } + } + # ------------------------------------------------------------- + } + # we re-use the argument definition from punk::args::standard_about and override some items + set overrides [dict create] + dict set overrides @id -id "::punk::timeinterval::about" + dict set overrides @cmd -name "punk::timeinterval::about" + dict set overrides @cmd -help [string trim [punk::args::lib::tstr { + About punk::timeinterval + }] \n] + dict set overrides topic -choices [list {*}[punk::timeinterval::argdoc::about_topics] *] + dict set overrides topic -choicerestricted 1 + dict set overrides topic -default [punk::timeinterval::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict + set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] + lappend PUNKARGS [list $newdef] + proc about {args} { + package require punk::args + #standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on + set argd [punk::args::parse $args withid ::punk::timeinterval::about] + lassign [dict values $argd] _leaders opts values _received + punk::args::package::standard_about -package_about_namespace ::punk::timeinterval::argdoc {*}$opts {*}[dict get $values topic] + } +} +# end of sample 'about' function +# == === === === === === === === === === === === === === === + + +# ----------------------------------------------------------------------------- +# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked +# ----------------------------------------------------------------------------- +# variable PUNKARGS +# variable PUNKARGS_aliases +namespace eval ::punk::args::register { + #use fully qualified so 8.6 doesn't find existing var in global namespace + lappend ::punk::args::register::NAMESPACES ::punk::timeinterval +} @@ -553,9 +707,9 @@ namespace eval punk::timeinterval { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::timeinterval [namespace eval punk::timeinterval { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/punk/winrun-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/winrun-0.1.0.tm index 69aea9c9..6f0383f8 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/winrun-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/winrun-0.1.0.tm @@ -37,7 +37,7 @@ namespace eval punk::winrun { } proc readchild_handler {chan hpid} { - #fileevent $chan readable {} + #chan event $chan readable {} set data [read $chan 4096] while {![chan blocked $chan] && ![eof $chan]} { append data [read $chan 4096] @@ -46,19 +46,19 @@ namespace eval punk::winrun { flush stdout if {![eof $chan]} { puts stdout "not eof $chan [fconfigure $chan] chan blocked:[chan blocked $chan]" - #fileevent $chan readable [list punk::winrun::readchild_handler $chan $hpid] + #chan event $chan readable [list punk::winrun::readchild_handler $chan $hpid] } else { #puts "eof: waiting exit process" set punk::winrun::waitresult [twapi::wait_on_handle $hpid -wait -1] } } proc readchilderr_handler {chan} { - fileevent $chan readable {} + chan event $chan readable {} set data [read $chan] puts stderr "err: $data" flush stderr if {![eof $chan]} { - fileevent $chan readable [list punk::winrun::readchild_handler $chan] + chan event $chan readable [list punk::winrun::readchild_handler $chan] } } @@ -81,13 +81,13 @@ namespace eval punk::winrun { #after 1000 chan configure $readout -blocking 0 - fileevent $readout readable [list readchild_handler $readout $hpid] + chan event $readout readable [list readchild_handler $readout $hpid] puts stdout "input: [chan configure $writein]" puts $writein "puts stdout blah;" flush $writein puts $writein "flush stdout" flush $writein - puts $writein "puts exiting" + puts $writein "puts exiting" puts $writein "after 10;exit 4" flush $writein #puts stdout x--[read $readout] @@ -106,13 +106,13 @@ namespace eval punk::winrun { if {$waitresult eq "timeout"} { puts stderr "tw_run: timeout waiting for process" } - fileevent $readout readable {} - fileevent $readerr readable {} + chan event $readout readable {} + chan event $readerr readable {} set code [twapi::get_process_exit_code $hpid] twapi::close_handle $htid twapi::close_handle $hpid - return [dict create exitcode $code] + return [dict create exitcode $code] } proc wait_on {hpid} { set punk::winrun::waitresult [twapi::wait_on_handle $hpid -wait -1] @@ -130,7 +130,7 @@ namespace eval punk::winrun { set code [twapi::get_process_exit_code $hpid] twapi::close_handle $htid twapi::close_handle $hpid - return [dict create exitcode $code] + return [dict create exitcode $code] } #completely raw to windows createprocess API - caller will really need to understand what they're doing. @@ -205,10 +205,10 @@ namespace eval punk::winrun { append cmdline {"} set chars [split $w ""] set wordlen [string length $w] - set nlast [expr {$wordlen -1}] + set nlast [expr {$wordlen -1}] for {set n 0} {$n<$wordlen} {incr n} { set char [lindex $chars $n] - set num_backslashes 0 + set num_backslashes 0 while {$char eq "\\" && $n<$nlast} { incr num_backslashes incr n @@ -216,7 +216,7 @@ namespace eval punk::winrun { } if {$n > $nlast} { append cmdline [string repeat "\\" [expr {$num_backslashes * 2}]] - break + break } elseif {$char eq {"}} { #escape all backslashes and the following double-quote append cmdline [string repeat "\\" [expr {$num_backslashes * 2 + 1}]] $char @@ -234,7 +234,7 @@ namespace eval punk::winrun { puts stdout --cmdline->$cmdline } # ----------------- - #tw_run $cmdline + #tw_run $cmdline #assertion - can be treated as tcl list ? return $cmdline } @@ -333,8 +333,8 @@ namespace eval punk::winrun { if {[lindex $chars $n+1] eq {"}} { incr n ;#move to second {"} } else { - set copychar false - set in_doublequote_part 0 + set copychar false + set in_doublequote_part 0 } } else { set copychar false @@ -350,7 +350,7 @@ namespace eval punk::winrun { break } if {$copychar} { - append p [lindex $chars $n] + append p [lindex $chars $n] } } set rem [string range $cmdline $n+1 end] @@ -362,7 +362,7 @@ namespace eval punk::winrun { tw_run [quote_win {*}$args] } - #an experiment - this is essentially an identity transform unless flags are set. - result afer cmd.exe processes escapes is the same as running raw with no quoting + #an experiment - this is essentially an identity transform unless flags are set. - result afer cmd.exe processes escapes is the same as running raw with no quoting #this follows the advice of 'don't let cmd see any double quotes unescaped' - but that's effectively a pretty useless strategy. #The -useprequoted and -usepreescaped flags are the only difference #these rely on the fact we can prepend a caret to each argument without affecting the resulting string - and use that as an indicator to treat specific input 'arguments' differently i.e by keeping existing escapes only. @@ -385,7 +385,7 @@ namespace eval punk::winrun { set cmdline "" set i 0 - set meta_chars [list {"} "(" ")" ^ < > & |] + set meta_chars [list {"} "(" ")" ^ < > & |] #note that %var% and !var! work the same whether within a double quote section or not if {$disallowvars} { lappend meta_chars % ! @@ -398,8 +398,8 @@ namespace eval punk::winrun { foreach w $tcl_list { set qword "" set wordlen [string length $w] - set nlast [expr {$wordlen -1}] - set chars [split $w ""] + set nlast [expr {$wordlen -1}] + set chars [split $w ""] set wordlen [string length $w] set nlast [expr {$wordlen -1}] @@ -514,14 +514,14 @@ namespace eval punk::winrun { #?? } #if %var% was in original string - a variable named %"var"% can be substituted after we have done our quoting. - #no matter what quoting scheme we use - there will be a corresponding string between %'s that can in theory be exploited if + #no matter what quoting scheme we use - there will be a corresponding string between %'s that can in theory be exploited if if {$in_quotes} { #note that the *intended* quoting will be opposite to the resultant quoting from wrapping with quote_win #therefore, counterintuitively we can enable the var when in_quotes is true here, and &cmd won't run. #double quotes in the var don't seem to cause cmd.exe to change it's concept of in_quotes so &cmd also won't run - #However.. backspace can can break quoting. e.g \b&cmd + #However.. backspace can can break quoting. e.g \b&cmd if {$allowvars} { - append qword [lindex $chars $n] + append qword [lindex $chars $n] } else { append qword {"} [lindex $chars $n] {"} ;#add in pairs so we don't disturb structure for argv } @@ -544,7 +544,7 @@ namespace eval punk::winrun { if {$in_quotes} { append qword {"^^"} ;#add quotes in pairs so we don't disturb structure for argv } else { - append qword {^^} + append qword {^^} } } else { if {[lindex $chars $n] in $meta_chars} { @@ -559,7 +559,7 @@ namespace eval punk::winrun { } } append cmdline $qword " " - + } set cmdline [string range $cmdline 0 end-1] if {$verbose} { @@ -567,32 +567,32 @@ namespace eval punk::winrun { } return $cmdline } - # - This approach with repeated double quotes gives inconsistent behaviour between twapi CommandLineToArgvW and tclsh - + # - This approach with repeated double quotes gives inconsistent behaviour between twapi CommandLineToArgvW and tclsh - #prepare arguments that are given to cmd.exe such that they will be passed through to an executable that uses standard windows commandline parsing such as CommandLineToArgvW #for each arg: #double up any backslashes that precede double quotes, double up existing double quotes - then wrap in a single set of double quotes if argument had any quotes in it. #This doesn't use \" or ^ style escaping - but the 2008+ argv processing on windows supposedly does what we want with doubled-up quotes and slashes, and cmd.exe passes them through - #In practice - it seems less consistent/reliable + #In practice - it seems less consistent/reliable proc quote_cmdpassthru_test {args} { lassign [internal::get_run_opts $args] _r runopts _c cmdargs set allowvars [expr {"-allowvars" in $runopts}] set verbose [expr {"-verbose" in $runopts}] set tcl_list [lmap v $cmdargs {internal::objclone $v}] - set meta_chars [list {"} "(" ")" ^ < > & |] + set meta_chars [list {"} "(" ")" ^ < > & |] if {!$allowvars} { lappend meta_chars % ! } set cmdline "" foreach w $tcl_list { - set chars [split $w ""] + set chars [split $w ""] set wordlen [llength $chars] #set nlast [expr {$wordlen -1}] set qword "" for {set n 0} {$n<$wordlen} {incr n} { set num_slashes 0 while {[lindex $chars $n] eq "\\" && $n<$wordlen} { - incr num_slashes + incr num_slashes incr n } if {[lindex $chars $n] eq {"}} { @@ -615,7 +615,7 @@ namespace eval punk::winrun { return $cmdline } - #caret quoting of all meta_chars + #caret quoting of all meta_chars proc quote_cmdblock {args} { lassign [internal::get_run_opts $args] _r runopts _c cmdargs set allowvars [expr {"-allowvars" in $runopts}] @@ -624,7 +624,7 @@ namespace eval punk::winrun { set tcl_list [lmap v $cmdargs {internal::objclone $v}] set cmdline "" set i 0 - set meta_chars [list "(" ")" ^ < > & |] + set meta_chars [list "(" ")" ^ < > & |] if {!$allowvars} { lappend meta_chars % ! } @@ -633,8 +633,8 @@ namespace eval punk::winrun { } foreach w $tcl_list { set wordlen [string length $w] - set nlast [expr {$wordlen -1}] - set chars [split $w ""] + set nlast [expr {$wordlen -1}] + set chars [split $w ""] foreach char $chars { if {$char in $meta_chars} { append cmdline "^$char" @@ -663,8 +663,8 @@ namespace eval punk::winrun { set cmd_in_quotes 0 foreach w $tcl_list { set wordlen [string length $w] - set nlast [expr {$wordlen -1}] - set chars [split $w ""] + set nlast [expr {$wordlen -1}] + set chars [split $w ""] foreach char $chars { if {$char eq {"}} { append cmdline {^"} @@ -704,7 +704,7 @@ namespace eval punk::winrun { #round-trip test - #use standard(!) win arg quoting first - then deconstruct using the win32 api, and the tcl implementation + #use standard(!) win arg quoting first - then deconstruct using the win32 api, and the tcl implementation proc testrawline {rawcmdline} { puts "input string : $rawcmdline" set win_argv [unquote_win $rawcmdline] @@ -770,7 +770,7 @@ namespace eval punk::winrun { #get_run_opts - allow completely arbitrary commandline following controlling flags - with no collision issues if end-of-opts flag "--" is used. #singleton flags allowed preceding commandline. (no support for option-value pairs in the controlling flags) - #This precludes use of executable beginning with a dash unless -- provided as first argument or with only known run-opts preceding it. + #This precludes use of executable beginning with a dash unless -- provided as first argument or with only known run-opts preceding it. #This should allow any first word for commandlist even -- itself if a protective -- provided at end of any arguments intended to control the function. proc get_run_opts {arglist} { if {[catch { @@ -852,7 +852,7 @@ namespace eval punk::winrun { set nscaller [uplevel 1 {namespace current}] set ns [punk::nsjoin $nscaller $ns] } - set a_export_patterns [namespace eval $source_ns {namespace export}] + set a_export_patterns [namespace eval $source_ns {namespace export}] set a_commands [info commands $pattern] set a_tails [lmap v $a_commands {namespace tail $v}] set a_exported_tails [list] @@ -893,9 +893,9 @@ namespace eval punk::winrun { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punk::winrun [namespace eval punk::winrun { variable version - set version 0.1.0 + set version 0.1.0 }] return \ No newline at end of file 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 db8a3db5..fbf9a4e4 100644 --- a/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punkcheck-0.1.0.tm @@ -69,7 +69,7 @@ namespace eval punkcheck { } - proc load_records_from_file {punkcheck_file} { + proc load_records_from_file {punkcheck_file} { set record_list [list] if {[file exists $punkcheck_file]} { set tdlscript [punk::mix::util::fcat $punkcheck_file] @@ -86,7 +86,7 @@ namespace eval punkcheck { set linecount [llength [split $newtdl \n]] #puts stdout $newtdl set fd [open $punkcheck_file w] - fconfigure $fd -translation binary + chan configure $fd -translation binary puts -nonewline $fd $newtdl close $fd return [list recordcount [llength $recordlist] linecount $linecount] @@ -94,7 +94,7 @@ namespace eval punkcheck { #todo - work out way to use same punkcheck file for multiple installers running concurrently. Thread? - #an installtrack objects represents an installation path from sourceroot to targetroot + #an installtrack objects represents an installation path from sourceroot to targetroot #The source and target folders should be as specific as possible but it is valid to specify for example c:/ -> c:/ (or / -> /) if source and targets within the installation operation are spread around. # set objname [namespace current]::installtrack @@ -104,7 +104,7 @@ namespace eval punkcheck { #FILEINFO record - target fileset with body records: INSTALL-RECORD,INSTALL-INPROGRESS,INSTALL-SKIPPED,DELETE-RECORD,DELETE-INPROGRESS,MODIFY-INPROGRESS,MODIFY-RECORD #each FILEINFO body being a list of SOURCE records oo::class create targetset { - variable o_targets + variable o_targets variable o_keep_installrecords variable o_keep_skipped variable o_keep_inprogress @@ -132,7 +132,7 @@ namespace eval punkcheck { -keep_inprogress $o_keep_inprogress\ body $o_records } - + #retrieve last completed record for the fileset ie exclude SKIPPED,INSTALL-INPROGRESS,DELETE-INPROGRESS,MODIFY-INPROGRESS method get_last_record {fileset_record} { set body [dict_getwithdefault $fileset_record body [list]] @@ -189,11 +189,11 @@ namespace eval punkcheck { } set o_ts_end [dict get $opts -tsend] set o_types [dict get $opts -types] - set o_configdict [dict get $opts -config] + set o_configdict [dict get $opts -config] set o_rel_sourceroot $rel_sourceroot set o_rel_targetroot $rel_targetroot - } + } destructor { #puts "[self] destructor called" } @@ -339,14 +339,14 @@ namespace eval punkcheck { set installing_record [lindex $fileinfo_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset fileinfo_body end $installing_record - + return [dict set o_fileset_record body $fileinfo_body] } else { #legacy call @@ -368,7 +368,7 @@ namespace eval punkcheck { } set status [string toupper $status] - set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] + set statusdict [dict create OK RECORD SKIPPED SKIPPED FAILED FAILED] if {$o_operation_start_ts eq ""} { error "[self] targetset_end $status - no current operation - call targetset_started first" } @@ -383,7 +383,7 @@ namespace eval punkcheck { error "targetset_end $status error. targetlist mismatch between file : $targetlist vs $o_targets" } set operation_end_ts [clock microseconds] - set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] + set elapsed_us [expr {$operation_end_ts - $o_operation_start_ts}] set file_record_body [dict get $o_fileset_record body] set installing_record [lindex $file_record_body end] set punkcheck_file [$o_installer get_checkfile] @@ -414,12 +414,12 @@ namespace eval punkcheck { } } set cksum_us [expr {[clock microseconds] - $ts_begin_cksum}] - dict set installing_record -targets_cksums $new_targets_cksums + dict set installing_record -targets_cksums $new_targets_cksums dict set installing_record -cksum_all_opts $cksum_all_opts dict set installing_record -cksum_us $cksum_us } lset file_record_body end $installing_record - dict set o_fileset_record body $file_record_body + dict set o_fileset_record body $file_record_body set o_fileset_record [punkcheck::recordlist::file_record_prune $o_fileset_record] set oldrecordinfo [punkcheck::recordlist::get_file_record $targetlist $record_list] @@ -436,8 +436,8 @@ namespace eval punkcheck { set o_operation "" return $o_fileset_record } - #can supply empty cksum value - # - that will influence the opts used if there is no existing install record + #can supply empty cksum value + # - that will influence the opts used if there is no existing install record method targetset_cksumcache_set {path_cksum_dict} { set o_path_cksum_cache $path_cksum_dict } @@ -504,12 +504,12 @@ namespace eval punkcheck { variable o_ts variable o_keep_events variable o_checkfile - variable o_sourceroot + variable o_sourceroot variable o_rel_sourceroot variable o_targetroot variable o_rel_targetroot variable o_record_list - variable o_active_event + variable o_active_event variable o_events constructor {installername punkcheck_file} { set o_active_event "" @@ -546,7 +546,7 @@ namespace eval punkcheck { #$o_events add $e [dict get $e -id] $o_events add $eobj [dict get $e -id] } - + } destructor { #puts "[self] destructor called" @@ -562,7 +562,7 @@ namespace eval punkcheck { } #call set_source_target before calling start_event/end_event - #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. + #each event can have different source->target pairs - but may often have same, so set on installtrack as defaults. Only persisted in event records. method set_source_target {sourceroot targetroot} { if {[file pathtype $sourceroot] ne "absolute"} { error "[self] set_source_target error: sourceroot must be absolute path. Received '$sourceroot'" @@ -605,7 +605,7 @@ namespace eval punkcheck { } method save_installer_record {} { set file_records [punkcheck::load_records_from_file $o_checkfile] - + set this_installer_record [my as_record] set persistedinfo [punkcheck::recordlist::get_installer_record $o_name $file_records] @@ -658,13 +658,13 @@ namespace eval punkcheck { set resultinfo [punkcheck::recordlist::get_installer_record $o_name $o_record_list] } method get_recordlist {} { - return $o_recordlist + return $o_recordlist } method end_event {} { if {$o_active_event eq ""} { error "[self] end_event error - no active event" } - $o_active_event end + $o_active_event end } method get_event {} { return $o_active_event @@ -720,7 +720,7 @@ namespace eval punkcheck { append msg "Call in order:" \n append msg " start_installer_event (get dict with eventid and recordset keys)" append msg " installfile_begin (to return a new INSTALLING record) - must pass in a valid eventid" \n - append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n + append msg " installfile_add_source_and_fetch_metadata (1+ times to update SOURCE record with checksum/timestamp info from source)" \n append msg " ( - possibly with same algorithm as previous installrecord)" \n append msg " ( - todo - search/load metadata for this source from other FILEINFO records for same installer)" \n append msg "Finalize by calling:" \n @@ -749,7 +749,7 @@ namespace eval punkcheck { set punkcheck_file [file join $punkcheck_folder/.punkcheck] set record_list [load_records_from_file $punkcheck_file] - + set resultinfo [punkcheck::recordlist::get_installer_record $installername $record_list] set installer_record_position [dict get $resultinfo position] if {$installer_record_position == -1} { @@ -805,7 +805,7 @@ namespace eval punkcheck { #validate any passed cached_cksums foreach cacheinfo $cached_cksums { if {[llength $cacheinfo] % 2 != 0} { - error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" + error "installfile_add_source_and_fetch_metadata error.If cached_cksums is supplied, it must be a list of dicts containing keys cksum & opts" } dict for {k v} $cacheinfo { switch -- $k { @@ -814,7 +814,7 @@ namespace eval punkcheck { #todo - validate $v keys } default { - error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" + error "installfile_add_source_and_fetch_metadata error. Unrecognised key $k. Known keys {cksum opts}" } } @@ -837,7 +837,7 @@ namespace eval punkcheck { } } } - #check that this relpath not already added as child of *-INPROGRESS + #check that this relpath not already added as child of *-INPROGRESS set file_record_body [dict_getwithdefault $file_record body [list]] ;#new file_record may have no body set installing_record [lindex $file_record_body end] set already_present_record [lib::install_record_get_matching_source_record $installing_record $source_relpath] @@ -871,14 +871,14 @@ namespace eval punkcheck { #use first entry in cached_cksums if we can if {[llength $cached_cksums]} { set use_cache 1 - set use_cache_record [lindex $cached_cksums 0] + set use_cache_record [lindex $cached_cksums 0] } } #todo - accept argument of cached source cksum info (for client calling multiple targets with same source in quick succession e.g when building .vfs kits with multiple runtimes) #if same cksum_opts - then use cached data instead of checksumming here. - #allow nonexistant as a source + #allow nonexistant as a source set fpath [file join $punkcheck_folder $source_relpath] if {![file exists $fpath]} { set ftype "missing" @@ -939,14 +939,14 @@ namespace eval punkcheck { set installing_record [lindex $file_record_body end] set ts_start [dict get $installing_record -ts] - set ts_now [clock microseconds] + set ts_now [clock microseconds] set metadata_us [expr {$ts_now - $ts_start}] - + dict set installing_record -metadata_us $metadata_us dict set installing_record -ts_start_transfer $ts_now lset file_record_body end $installing_record - + dict set file_record body $file_record_body @@ -983,7 +983,7 @@ namespace eval punkcheck { dict set installing_record tag "INSTALL-RECORD" lset file_record_body end $installing_record - dict set file_record body $file_record_body + dict set file_record body $file_record_body set file_record [punkcheck::recordlist::file_record_prune $file_record] @@ -1016,8 +1016,8 @@ namespace eval punkcheck { set tsnow [clock microseconds] set elapsed_us [expr {$tsnow - $ts_start}] dict set installing_record -elapsed_us $elapsed_us - dict set installing_record tag "INSTALL-SKIPPED" - + dict set installing_record tag "INSTALL-SKIPPED" + lset file_record_body end $installing_record dict set file_record body $file_record_body @@ -1076,7 +1076,7 @@ namespace eval punkcheck { #should work on *-INPROGRESS or INSTALL(etc) record - don't restrict tag to INSTALL proc install_record_get_matching_source_record {install_record source_relpath} { - set body [dict_getwithdefault $install_record body [list]] + set body [dict_getwithdefault $install_record body [list]] foreach src $body { if {[dict get $src tag] eq "SOURCE"} { if {[dict_getwithdefault $src -path ""] eq $source_relpath} { @@ -1124,7 +1124,7 @@ namespace eval punkcheck { set do_normalize 1 } } else { - #case differences in volumes is common on windows + #case differences in volumes is common on windows set do_normalize 1 } if {$do_normalize} { @@ -1207,7 +1207,7 @@ namespace eval punkcheck { if {[dict exists $dictValue {*}$keys]} { return [dict get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } lappend PUNKARGS [list { @@ -1273,11 +1273,11 @@ namespace eval punkcheck { # -overwrite newer-targets will copy files with older source timestamp over newer target timestamp and those missing at the target (a form of 'restore' operation) # -overwrite older-targets will copy files with newer source timestamp over older target timestamp and those missing at the target # -overwrite all-targets will copy regardless of timestamp at target - # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed + # -overwrite installedsourcechanged-targets will copy if the target doesn't exist or the source changed # -overwrite synced-targets will copy if the target doesn't exist or the source changed and the target cksum is the same as the last INSTALL-RECORD -targets_cksums entry # review - timestamps unreliable - # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? - # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) + # - what about slightly mismatched system clocks and mounted filesystems? caller responsibility to verify first? + # if timestamp exactly equal - should we check content-hash? This is presumably only likely to occur deliberately(maliciously?) # e.g some process that digitally signs or otherwise modifies a file and preserves update timestmp? # if such a content-mismatch - what default behaviour and what options would make sense? # probably it's reasonable that only all-targets would overwrite such files. @@ -1369,7 +1369,7 @@ namespace eval punkcheck { if {[llength [file split $af]] > 1} { error "punkcheck::install received invalid -antiglob_file entry '$af'. -antiglob_file entries are meant to match to a file name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_dir_core [dict get $opts -antiglob_dir_core] if {$opt_antiglob_dir_core eq "\uFFFF"} { @@ -1383,7 +1383,7 @@ namespace eval punkcheck { if {[llength [file split $ad]] > 1} { error "punkcheck::install received invalid -antiglob_dir entry '$ad'. -antiglob_dir entries are meant to match to a directory name at any level so cannot contain path separators" } - } + } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_antiglob_paths [dict get $opts -antiglob_paths] ;#todo - combine with config file in source tree .punkcheckpublish (?) #antiglob_paths will usually contain file separators - and may contain glob patterns within each segment @@ -1482,7 +1482,7 @@ namespace eval punkcheck { } else { set store_source_cksums 0 } - + @@ -1545,12 +1545,12 @@ namespace eval punkcheck { } if {$suppress == 0} { lappend match_list $m - } + } } #sample .punkcheck file record (raw form) to make the code clearer #punk::tdl converts to dict form e.g: tag FILEINFO -targets filename body sublist - #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS + #Valid installrecord types are INSTALL-RECORD SKIPPED INSTALL-INPROGRESS, MODIFY-RECORD MODIFY-INPROGRESS DELETE-RECORD DELETE-INPROGRESS # #FILEINFO -targets jjjetc-0.1.0.tm -keep_installrecords 2 -keep_skipped 1 -keep_inprogress 2 { # INSTALL-RECORD -tsiso 2023-09-20T07:30:30 -ts 1695159030266610 -installer punk::mix::cli::build_modules_from_source_to_base -metadata_us 18426 -ts_start_transfer 1695159030285036 -transfer_us 10194 -elapsed_us 28620 { @@ -1563,15 +1563,15 @@ namespace eval punkcheck { # } #} - if {[llength $match_list]} { + if {[llength $match_list]} { #example - target dir has a file where there is a directory at the source if {[file exists $current_target_dir] && ([file type $current_target_dir] ni [list directory])} { error "punkcheck::install target subfolder $current_target_dir exists but is not of type 'directory'. Type current target folder: [file type $current_target_dir]" } } - + #proc get_relativecksum_from_base_and_fullpath {base fullpath args} - + #puts stdout "Current target dir: $current_target_dir" foreach m $match_list { @@ -1581,7 +1581,7 @@ namespace eval punkcheck { set punkcheck_target_relpath [file join $target_relative_to_punkcheck_dir $m] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing file - globmatchpath $antipath vs $relative_source_path" + #puts "testing file - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched $current_source_dir set is_antipath 1 @@ -1598,7 +1598,7 @@ namespace eval punkcheck { #puts stdout " rel_target: $punkcheck_target_relpath" - + set fetch_filerec_result [punkcheck::recordlist::get_file_record $punkcheck_target_relpath $punkcheck_records] #change to use extract_or_create_fileset_record ? set existing_filerec_posn [dict get $fetch_filerec_result position] @@ -1614,7 +1614,7 @@ namespace eval punkcheck { set filerec [dict get $fetch_filerec_result record] } set filerec [punkcheck::recordlist::file_record_set_defaults $filerec] - + #new INSTALLREC must be tagged as INSTALL-INPROGRESS to use recordlist::installfile_ method set new_install_record [dict create tag INSTALL-INPROGRESS -tsiso $ts_start_iso -ts $ts_start -installer $opt_installer -eventid $punkcheck_eventid] dict lappend filerec body $new_install_record ;#can't use recordlist::file_record_add_installrecord as '*-INPROGRESS' isn't a final tag - so pruning would be mucked up. No need to prune now anyway. @@ -1630,7 +1630,7 @@ namespace eval punkcheck { #different volume or root } #Note this isn't a recordlist function - so it doesn't purely operate on the records - #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. + #this hits the filesystem for the sourcepath - gets checksums/timestamps depending on config. #It doesn't save to .punkcheck (the only punkcheck::installfile_ method which doesn't) set filerec [punkcheck::installfile_add_source_and_fetch_metadata $punkcheck_folder $relative_source_path $filerec] @@ -1697,7 +1697,7 @@ namespace eval punkcheck { } else { #either cksum is different or we were unable to verify the record. Either way we can't know if the target is in sync so we must skip it set is_skip 1 - puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" + puts stderr "Skipping file copy $m target $current_target_dir/$m - require synced_target to overwrite - current target cksum compared to previous install: $target_cksum_compare" lappend files_skipped $current_source_dir/$m } } else { @@ -1728,7 +1728,7 @@ namespace eval punkcheck { #if {$store_source_cksums} { #} - set install_records [dict get $filerec body] + set install_records [dict get $filerec body] set current_install_record [lindex $install_records end] #change the tag from *-INPROGRESS to INSTALL-RECORD/SKIPPED if {$is_skip} { @@ -1790,7 +1790,7 @@ namespace eval punkcheck { set relative_source_path [file join $relative_source_dir $d] set is_antipath 0 foreach antipath $opt_antiglob_paths { - #puts "testing folder - globmatchpath $antipath vs $relative_source_path" + #puts "testing folder - globmatchpath $antipath vs $relative_source_path" if {[punk::path::globmatchpath $antipath $relative_source_path]} { lappend antiglob_paths_matched [file join $current_source_dir $d] #puts stdout "SKIPPING FOLDER $relative_source_path due to antiglob_path-match: $antipath " @@ -1801,11 +1801,11 @@ namespace eval punkcheck { if {$is_antipath} { continue } - + #if {![file exists $current_target_dir/$d]} { # file mkdir $current_target_dir/$d #} - + set sub_opts_1 [list\ -call-depth-internal [expr {$CALLDEPTH + 1}]\ @@ -1828,7 +1828,7 @@ namespace eval punkcheck { -punkcheck_folder $punkcheck_folder\ -punkcheck_eventid $punkcheck_eventid\ -punkcheck_records $punkcheck_records\ - ] + ] set sub_opts [dict merge $opts $sub_opts] set sub_result [punkcheck::install $srcdir $tgtdir {*}$sub_opts] @@ -1838,7 +1838,7 @@ namespace eval punkcheck { lappend antiglob_paths_matched {*}[dict get $sub_result antiglob_paths_matched] set punkcheck_records [dict get $sub_result punkcheck_records] } - + if {[string match *store* $opt_source_checksum]} { #puts "subdirlist: $subdirlist" if {$CALLDEPTH == 0} { @@ -1849,7 +1849,7 @@ namespace eval punkcheck { #puts stdout ">>>>>>>>>>>>>>>>>>>" } else { #todo - write db INSTALLER record if -debug true - + } #puts stdout "sources_unchanged" #puts stdout "$sources_unchanged" @@ -2108,7 +2108,7 @@ namespace eval punkcheck { if {[dict get $file_record tag] ne "FILEINFO"} { error "file_record_set_defaults bad file_record: tag not FILEINFO" } - set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] + set defaults [list -keep_installrecords 3 -keep_skipped 1 -keep_inprogress 2] foreach {k v} $defaults { if {![dict exists $file_record $k]} { dict set file_record $k $v @@ -2186,10 +2186,10 @@ namespace eval ::punk::args::register { # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide punkcheck [namespace eval punkcheck { set pkg punkcheck variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm b/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm index ace56e9c..bb820f68 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellrun-0.1.1.tm @@ -23,7 +23,7 @@ namespace eval shellrun { #todo - something better if {[info exists ::punk::config::running]} { upvar ::punk::config::running conf - set syslog_stdout [dict get $conf syslog_stdout] + set syslog_stdout [dict get $conf syslog_stdout] set syslog_stderr [dict get $conf syslog_stderr] set logfile_stdout [dict get $conf logfile_stdout] set logfile_stderr [dict get $conf logfile_stderr] @@ -43,18 +43,18 @@ namespace eval shellrun { set err [dict get [shellfilter::stack::item punksherr] device localchan] } - namespace import ::punk::ansi::a+ + namespace import ::punk::ansi::a+ namespace import ::punk::ansi::a - + #repltelemetry - additional/alternative display info used in a repl context i.e info directed towards the screen #todo - package up in repltelemetry module and rewrite proc based on whether the module was found/loaded. #somewhat strong coupling to punk - but let's try to behave decently if it's not loaded #The last_run_display is actually intended for the repl - but is resident in the punk namespace with a view to the possibility of a different repl being in use. proc set_last_run_display {chunklist} { - #chunklist as understood by the + #chunklist as understood by the if {![info exists ::punk::repltelemetry_emmitters]} { namespace eval ::punk { variable repltelemetry_emmitters @@ -62,7 +62,7 @@ namespace eval shellrun { } } else { if {"shellrun" ni $::punk::repltelemetry_emmitters} { - lappend punk::repltelemetry_emmitters "shellrun" + lappend punk::repltelemetry_emmitters "shellrun" } } @@ -70,7 +70,7 @@ namespace eval shellrun { if {[catch {llength $chunklist} errMsg]} { error "set_last_run_display expects a list. Value supplied doesn't appear to be a well formed tcl list. '$errMsg'" } - #todo - + #todo - tsv::lappend repl runchunks-[tsv::get repl runid] {*}$chunklist } @@ -140,13 +140,13 @@ namespace eval shellrun { } else { set nonewline 0 } - set idlist_stderr [list] + set idlist_stderr [list] #we leave stdout without imposed ansi colouring - because the source may be colourised and because ansi-wrapping a stream at whatever boundaries it comes in at isn't a really nice thing to do. #stderr might have source colouring - but it usually doesn't seem to, and the visual distiction of red stderr can be very handy for the run command. #A further enhancement could be to detect well-known options such as --color and/or use a configuration for specific commands that have useful colourised stderr, #but having an option to configure stderr to red is a compromise. #Note that the other run commands, runout,runerr, runx don't emit in real-time - so for those commands there may be options to detect and/or post-process stdout and stderr. - #TODO - fix. This has no effect if/when the repl adds an ansiwrap transform + #TODO - fix. This has no effect if/when the repl adds an ansiwrap transform # what we probably want to do is 'aside' that transform for runxxx commands only. #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] @@ -158,7 +158,7 @@ namespace eval shellrun { dict set callopts -debug 1 } if {[dict exists $runoptslong --timeout]} { - dict set callopts -timeout [dict get $runoptslong --timeout] ;#convert to single dash + dict set callopts -timeout [dict get $runoptslong --timeout] ;#convert to single dash } #--------------------------------------------------------------------------------------------- set exitinfo [shellfilter::run $cmdargs {*}$callopts -teehandle punksh -inbuffering none -outbuffering none ] @@ -166,7 +166,7 @@ namespace eval shellrun { foreach id $idlist_stderr { shellfilter::stack::remove stderr $id - } + } flush stderr flush stdout @@ -191,10 +191,10 @@ namespace eval shellrun { 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 + #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 + #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} { @@ -230,9 +230,9 @@ namespace eval shellrun { } else { set nonewline 0 } - + #puts stdout "RUNOUT cmdargs: $cmdargs" - + #todo add -data boolean and -data lastwrite to -settings with default being -data all # because sometimes we're only interested in last char (e.g to detect something was output) @@ -268,7 +268,7 @@ namespace eval shellrun { if {"-tcl" in $runopts} { } else { - #we must raise an error. + #we must raise an error. #todo - check errorInfo makes sense.. return -code? tailcall? # set msg "" @@ -281,9 +281,10 @@ namespace eval shellrun { set chunklist [list] #exitcode not part of return value for runout - colourcode appropriately - set n $RST + set n $RST set c "" - if [dict exists $exitinfo exitcode] { + + if {[dict exists $exitinfo exitcode]} { set code [dict get $exitinfo exitcode] if {$code == 0} { set c [a+ green] @@ -291,7 +292,7 @@ namespace eval shellrun { set c [a+ white bold] } lappend chunklist [list "info" "$c$exitinfo$n"] - } elseif [dict exists $exitinfo error] { + } elseif {[dict exists $exitinfo error]} { set c [a+ yellow bold] lappend chunklist [list "info" "${c}error [dict get $exitinfo error]$n"] lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] @@ -330,7 +331,7 @@ namespace eval shellrun { } else { set o $::shellrun::runout } - append chunk "$o" + append chunk "$o" } lappend chunklist [list result $chunk] @@ -347,7 +348,7 @@ namespace eval shellrun { proc runerr {args} { #set_last_run_display [list] - variable runout + variable runout variable runerr set runout "" set runerr "" @@ -398,17 +399,15 @@ namespace eval shellrun { set n [a] set c "" - if [dict exists $exitinfo exitcode] { + if {[dict exists $exitinfo exitcode]} { set code [dict get $exitinfo exitcode] if {$code == 0} { set c [a+ green] } else { set c [a+ white bold] } - lappend chunklist [list "info" "$c$exitinfo$n"] - - } elseif [dict exists $exitinfo error] { + } elseif {[dict exists $exitinfo error]} { set c [a+ yellow bold] lappend chunklist [list "info" "error [dict get $exitinfo error]"] lappend chunklist [list "info" "errorCode [dict get $exitinfo errorCode]"] @@ -459,8 +458,8 @@ namespace eval shellrun { proc runx {args} { - #set_last_run_display [list] - variable runout + #set_last_run_display [list] + variable runout variable runerr set runout "" set runerr "" @@ -491,7 +490,7 @@ namespace eval shellrun { set stderr_stackid [shellfilter::stack::add stderr var -action float-locked -junction 1 -settings {-varname ::shellrun::runerr}] set stdout_stackid [shellfilter::stack::add stdout var -action float-locked -junction 1 -settings {-varname ::shellrun::runout}] } - + set callopts "" if {"-tcl" in $runopts} { append callopts " -tclscript 1" @@ -505,7 +504,7 @@ namespace eval shellrun { flush stderr flush stdout - + if {[dict exists $exitinfo error]} { if {"-tcl" in $runopts} { @@ -514,7 +513,7 @@ namespace eval shellrun { error [dict get $exitinfo error] } } - + #set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}] set chunk "" @@ -568,7 +567,7 @@ namespace eval shellrun { set exitdict [list exitcode $code] } elseif {[dict exists $exitinfo result]} { # presumably from a -tcl call - set val [dict get $exitinfo result] + set val [dict get $exitinfo result] lappend chunklist [list "info" " "] lappend chunklist [list "result" result] lappend chunklist [list "info" result] @@ -626,15 +625,15 @@ namespace eval shellrun { #we can only call runraw with a single (presumably braced) string if we want to use it from both repl and tcl scripts (why? todo with unbalanced quotes/braces?) proc runraw {commandline} { #runraw fails as intended - because we can't bypass exec/open interference quoting :/ - #set_last_run_display [list] - variable runout + #set_last_run_display [list] + variable runout variable runerr set runout "" set runerr "" #return [shellfilter::run [lrange $args 1 end] -teehandle punksh -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler] puts stdout ">>runraw got: $commandline" - + #run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing #for consistency with other runxxx commands - we'll just consume it. (review) @@ -666,14 +665,14 @@ namespace eval shellrun { } } } - + puts stdout ">>runraw runwords: $runwords" set runwords [lrange $runwords 1 end] - + puts stdout ">>runraw runwords: $runwords" #set args [lrange $args 1 end] #set runwords [lrange $wordparts 1 end] - + set known_runopts [list "-echo" "-e" "-terminal" "-t"] set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self set runopts [list] @@ -681,17 +680,17 @@ namespace eval shellrun { set idx_first_cmdarg [lsearch -not $runwords "-*"] set runopts [lrange $runwords 0 $idx_first_cmdarg-1] set cmdwords [lrange $runwords $idx_first_cmdarg end] - + foreach o $runopts { if {$o ni $known_runopts} { error "runraw: Unknown runoption $o" } } set runopts [lmap o $runopts {dict get $aliases $o}] - + set cmd_as_string [join $cmdwords " "] puts stdout ">>cmd_as_string: $cmd_as_string" - + if {"-terminal" in $runopts} { #fake terminal using 'script' command. #not ideal: smushes stdout & stderr together amongst other problems @@ -702,7 +701,7 @@ namespace eval shellrun { } else { set exitinfo [shellfilter::run $cmdwords -teehandle punksh -inbuffering line -outbuffering none ] } - + if {[dict exists $exitinfo error]} { #todo - check errorInfo makes sense.. return -code? tailcall? error [dict get $exitinfo error] @@ -764,7 +763,7 @@ namespace eval shellrun { interp alias {} ro {} shellrun::runout interp alias {} re {} shellrun::runerr interp alias {} rx {} shellrun::runx - + } @@ -772,7 +771,7 @@ namespace eval shellrun { proc test_cffi {} { package require test_cffi cffi::Wrapper create ::shellrun::kernel32 [file join $env(windir) system32 Kernel32.dll] - ::shellrun::kernel32 stdcall CreateProcessA + ::shellrun::kernel32 stdcall CreateProcessA #todo - stuff. return ::shellrun::kernel32 } diff --git a/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.1.tm b/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.1.tm index c529f234..2fd4d4f1 100644 --- a/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/shellthread-1.6.1.tm @@ -49,7 +49,7 @@ namespace eval shellthread::worker { variable logfile variable settings interp bgerror {} shellthread::worker::bgerror - #package require overtype ;#overtype uses tcllib textutil, punk::char etc - currently too heavyweight in terms of loading time for use in threads. + #package require overtype ;#overtype uses tcllib textutil, punk::char etc - currently too heavyweight in terms of loading time for use in threads. variable client_ids variable ts_start_micros lappend client_ids $tidclient @@ -108,7 +108,7 @@ namespace eval shellthread::worker { chan configure $readchan -translation lf if {$readchan ni [chan names]} { - error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" + error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" } set inpipe $readchan chan configure $readchan -blocking 0 @@ -123,15 +123,15 @@ namespace eval shellthread::worker { set chunksize [chan gets $chan chunk] if {$chunksize >= 0} { if {![chan eof $chan]} { - ::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering + ::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering } else { - ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering + ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering } } } else { set chunk [chan read $chan] - ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering - } + ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering + } if {[chan eof $chan]} { chan event $chan readable {} set $waitfor "pipe" @@ -143,10 +143,10 @@ namespace eval shellthread::worker { variable outpipe set defaults [dict create -buffering \uFFFF ] set opts [dict merge $defaults $args] - + #todo! set readchan stdin - + if {[dict exists $opts -readbuffering]} { set readbuffering [dict get $opts -readbuffering] } else { @@ -168,15 +168,15 @@ namespace eval shellthread::worker { can configure $writechan -buffering $writebuffering } } - + if {$writechan ni [chan names]} { - error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" + error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" } set outpipe $writechan chan configure $readchan -blocking 0 chan configure $writechan -blocking 0 set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) - + chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { if {$readbuffering eq "line"} { set chunksize [chan gets $chan chunk] @@ -194,7 +194,7 @@ namespace eval shellthread::worker { if {[chan eof $chan]} { chan event $chan readable {} set $waitfor "pipe" - chan close $writechan + chan close $writechan if {$chan ne "stdin"} { chan close $chan } @@ -209,18 +209,18 @@ namespace eval shellthread::worker { variable sysloghost_port variable sock if {[string length $sysloghost_port]} { - if {[catch {fconfigure $sock} state]} { + if {[catch {chan configure $sock} state]} { set sock [udp_open] - fconfigure $sock -buffering none -translation binary - fconfigure $sock -remote $sysloghost_port + chan configure $sock -buffering none -translation binary + chan configure $sock -remote $sysloghost_port } } - } + } proc _reconnect {} { variable sock catch {close $sock} _initsock - return [fconfigure $sock] + return [chan configure $sock] } proc send_info {client_tid ts_sent source msg} { @@ -242,12 +242,12 @@ namespace eval shellthread::worker { set tail_crlf 0 set tail_lf 0 set tail_cr 0 - #for cooked - always remove the trailing newline before splitting.. + #for cooked - always remove the trailing newline before splitting.. # #note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. # #Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split - #but add it back exactly as it was afterwards + #but add it back exactly as it was afterwards #we can always split on \n - and any adjacent \r will be preserved in the rejoin set lastchar [string range $logchunk end end] if {[string range $logchunk end-1 end] eq "\r\n"} { @@ -283,9 +283,9 @@ namespace eval shellthread::worker { #set col0 [string repeat " " 9] #set col1 [string repeat " " 27] #set col2 [string repeat " " 11] - #set col3 [string repeat " " 22] + #set col3 [string repeat " " 22] ##do not columnize the final data column or append to tail - or we could muck up the crlf integrity - #lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 + #lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 set w0 9 set w1 27 @@ -297,15 +297,15 @@ namespace eval shellthread::worker { [format %-${w1}s $time_info]\ [format %-${w2}s $lagfp]\ [format %-${w3}s $source]\ - ] c0 c1 c2 c3 + ] c0 c1 c2 c3 set c2_blank [string repeat " " $w2] #split on \n no matter the actual line-ending in use #shouldn't matter as long as we don't add anything at the end of the line other than the raw data #ie - don't quote or add spaces - set lines [split $logchunk \n] - + set lines [split $logchunk \n] + set i 1 set outlines [list] foreach ln $lines { @@ -324,13 +324,13 @@ namespace eval shellthread::worker { set logchunk "[join $outlines \r]\r" } else { #no trailing linefeed - set logchunk [join $outlines \n] + set logchunk [join $outlines \n] } #set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" } - + if {[string length $sysloghost_port]} { _initsock catch {puts -nonewline $sock $logchunk} @@ -348,7 +348,7 @@ namespace eval shellthread::worker { } } - # - withdraw just this client + # - withdraw just this client proc finish {tidclient} { variable client_ids if {($tidclient in $clientids) && ([llength $clientids] == 1)} { @@ -373,11 +373,11 @@ namespace eval shellthread::worker { #however.. how can we set a timeout on a thread::join ? #by telling the thread to release itself - we can wait on the thread::send variable # This needs review - because it's unclear that -wait even works on self - # (what does it mean to wait for the target thread to exit if the target is self??) + # (what does it mean to wait for the target thread to exit if the target is self??) thread::release -wait - return [thread::id] + return [thread::id] } else { - return "" + return "" } } @@ -388,7 +388,7 @@ namespace eval shellthread::worker { namespace eval shellthread::manager { variable workers [dict create] variable worker_errors [list] - variable timeouts + variable timeouts variable free_threads [list] #variable log_threads @@ -401,7 +401,7 @@ namespace eval shellthread::manager { if {[tcl::dict::exists $dictValue {*}$keys]} { return [tcl::dict::get $dictValue {*}$keys] } else { - return [lindex $args end] + return [lindex $args end] } } #new datastructure regarding workers and sourcetags required. @@ -412,7 +412,7 @@ namespace eval shellthread::manager { #If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. #If another thread want's to maintain joinability beyond the span provided by the starting client, #it can join with both the primary tag and a tag it will actually use for logging. - #A thread can join the logger with any existingtag - not just the 'primary' + #A thread can join the logger with any existingtag - not just the 'primary' #(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) proc join_worker {existingtag sourcetaglist} { set client_tid [thread::id] @@ -431,15 +431,15 @@ namespace eval shellthread::manager { #it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) # This allows multiple threads to more easily write to the same named sourcetag if necessary - # todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file + # todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file # # todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. - # Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target + # Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target # On the other hand socket targets such as UDP can happily be written to by multiple threads. - # For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches.. + # For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches. # but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. # Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker - # todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' + # todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' # probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. proc new_worker {sourcetaglist {settingsdict {}}} { variable workers @@ -455,7 +455,7 @@ namespace eval shellthread::manager { set workertype [string tolower [dict get $settingsdict -workertype]] set known_workertypes [list pipe message] if {$workertype ni $known_workertypes} { - error "new_worker - unknown -workertype $workertype. Expected one of '$known_workertypes'" + error "new_worker - unknown -workertype $workertype. Expected one of '$known_workertypes'" } if {[dict exists $workers $sourcetag]} { @@ -502,8 +502,8 @@ namespace eval shellthread::manager { #if {$tcllib ni $::auto_path} { # lappend ::auto_path $tcllib #} - - set ::settingsinfo [dict create %sd%] + + set ::settingsinfo [dict create %sd%] #if the executable running things is something like a tclkit, # then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things #The caller can tune the thread's package search by providing a settingsdict @@ -573,7 +573,7 @@ namespace eval shellthread::manager { } proc write_log {source msg args} { - variable workers + variable workers set ts_micros_sent [clock micros] set defaults [list -async 1 -level info] set opts [dict merge $defaults $args] @@ -584,12 +584,12 @@ namespace eval shellthread::manager { return } if {![thread::exists $tidworker]} { - # -syslog -file ? + # -syslog -file ? set tidworker [new_worker $source] } } else { #auto create with no requirement to call new_worker.. warn? - # -syslog -file ? + # -syslog -file ? error "write_log no log opened for source: $source" set tidworker [new_worker $source] } @@ -599,7 +599,7 @@ namespace eval shellthread::manager { } else { thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] } - } + } proc report_worker_errors {errdict} { variable workers set reporting_tid [dict get $errdict worker_tid] @@ -641,7 +641,7 @@ namespace eval shellthread::manager { set shuttingdown_workers [list] foreach deadtag $subscriberless_tags { set workertid [dict get $workers $deadtag tid] - set worker_tags [get_worker_tagstate $workertid] + set worker_tags [get_worker_tagstate $workertid] set subscriber_count 0 set kill_count 0 ;#number of ts_end_list entries - even one indicates thread is doomed foreach taginfo $worker_tags { @@ -690,8 +690,8 @@ namespace eval shellthread::manager { if {[info exists timeoutarr(shutdown_free_threads)]} { #already called return false - } - #set timeoutarr(shutdown_free_threads) waiting + } + #set timeoutarr(shutdown_free_threads) waiting #after $timeout [list set timeoutarr(shutdown_free_threads) timed-out] set ::shellthread::waitfor waiting after $timeout [list set ::shellthread::waitfor] @@ -708,7 +708,7 @@ namespace eval shellthread::manager { } if {[llength $waiting_for]} { for {set i 0} {$i < [llength $waiting_for]} {incr i} { - vwait ::shellthread::waitfor + vwait ::shellthread::waitfor if {$::shellthread::waitfor eq "timed-out"} { set timedout 1 break @@ -724,9 +724,9 @@ namespace eval shellthread::manager { #TODO - important. #REVIEW! #since moving to the unsubscribe mechansm - close_worker $source isn't being called - # - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription - #instruction to shut-down the thread that has this source. - #instruction to shut-down the thread that has this source. + # - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription + #instruction to shut-down the thread that has this source. + #instruction to shut-down the thread that has this source. proc close_worker {source {timeout 2500}} { variable workers variable worker_errors @@ -751,7 +751,7 @@ namespace eval shellthread::manager { set ts_end_list [dict get $workers $source ts_end_list] ;#ts_end_list is just a list of timestamps of closing calls for this source - only one is needed to close, but they may all come in a flurry. if {[llength $ts_end_list]} { set last_end_ts [lindex $ts_end_list end] - if {[expr {(($tsnow - $last_end_ts) / 1000) >= $timeout}]} { + if {(($tsnow - $last_end_ts) / 1000) >= $timeout} { lappend ts_end_list $ts_now dict set workers $source ts_end_list $ts_end_list } else { @@ -773,7 +773,7 @@ namespace eval shellthread::manager { #thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { # shellthread::worker::terminate %tidclient% #}] timeoutarr($source) - + vwait timeoutarr($source) #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" diff --git a/src/vfs/_vfscommon.vfs/modules/tcl9test-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/tcl9test-0.1.0.tm index 07e022b2..ee90595f 100644 --- a/src/vfs/_vfscommon.vfs/modules/tcl9test-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/tcl9test-0.1.0.tm @@ -53,7 +53,7 @@ namespace eval [lassign [split [file rootname [file tail [info script] ]] -] pkg - uplevel #0 [list package provide $pkgtail $version] + uplevel #0 [list package provide $pkgtail $version] #package provide [lassign {tcl9test 0.1.0} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] } @@ -64,9 +64,9 @@ namespace eval [lassign [split [file rootname [file tail [info script] ]] -] pkg #package provide [lassign {tcl9test 0.1.0} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $::ver[set ::ver {}]]$version}] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready #package provide tcl9test [namespace eval tcl9test { # variable version -# set version 0.1.0 +# set version 0.1.0 #}] #return 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 8d66978f..2d185f01 100644 --- a/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm +++ b/src/vfs/_vfscommon.vfs/modules/textblock-0.1.3.tm @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_textblock 0 0.1.3] #[copyright "2024"] #[titledesc {punk textblock functions}] [comment {-- Name section and table of contents description --}] -#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] +#[moddesc {punk textblock}] [comment {-- Description at end of page heading --}] #[require textblock] #[keywords module ansi text layout colour table frame console terminal] #[description] @@ -29,7 +29,7 @@ #*** !doctools #[section Overview] -#[para] overview of textblock +#[para] overview of textblock #[subsection Concepts] #[para] @@ -39,7 +39,7 @@ #*** !doctools #[subsection dependencies] -#[para] packages used by textblock +#[para] packages used by textblock #[list_begin itemized] #*** !doctools @@ -90,7 +90,7 @@ package require textutil tcl::namespace::eval textblock { #review - what about ansi off in punk::console? tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ - tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock #NOTE sha1, although computationally more intensive, tends to be faster than md5 on modern cpus #(more likely to be optimised for modern cpu features?) @@ -102,7 +102,7 @@ tcl::namespace::eval textblock { namespace eval argdoc { proc hash_algorithm_choices_and_help {} { set choices [list none] - set unavailable [list] + set unavailable [list] set unloaded [dict create] set algorithm_packages {md5 sha1 sha256} foreach p $algorithm_packages { @@ -219,7 +219,7 @@ tcl::namespace::eval textblock { #ie only vll,blc,hlb used for cells except top row and right column #top right cell uses all 'O' shape, other top cells use 'C' shape (hlt,tlc,vll,blc,hlb) #right cells use 'U' shape (vll,blc,hlb,brc,vlr) - #e.g for 4x4 + #e.g for 4x4 # C C C O # L L L U # L L L U @@ -229,7 +229,7 @@ tcl::namespace::eval textblock { set L [list vll blc hlb] set U [list vll blc hlb brc vlr] set tops [list trc hlt tlc] - set lefts [list tlc vll blc] + set lefts [list tlc vll blc] set bottoms [list blc hlb brc] set rights [list trc brc vlr] @@ -491,8 +491,8 @@ tcl::namespace::eval textblock { set requested_seps_h [tcl::dict::get $o_opts_table -show_hseps] set requested_seps_v [tcl::dict::get $o_opts_table -show_vseps] set seps $requested_seps - set seps_h $requested_seps_h - set seps_v $requested_seps_v + set seps_h $requested_seps_h + set seps_v $requested_seps_v if {$requested_seps eq ""} { if {$requested_seps_h eq ""} { set seps_h 1 @@ -502,10 +502,10 @@ tcl::namespace::eval textblock { } } else { if {$requested_seps_h eq ""} { - set seps_h $seps + set seps_h $seps } if {$requested_seps_v eq ""} { - set seps_v $seps + set seps_v $seps } } return [tcl::dict::create horizontal $seps_h vertical $seps_v] @@ -515,8 +515,8 @@ tcl::namespace::eval textblock { set requested_ft_header [tcl::dict::get $o_opts_table -frametype_header] set requested_ft_body [tcl::dict::get $o_opts_table -frametype_body] set ft $requested_ft - set ft_header $requested_ft_header - set ft_body $requested_ft_body + set ft_header $requested_ft_header + set ft_body $requested_ft_body switch -- $requested_ft { light { if {$requested_ft_header eq ""} { @@ -544,10 +544,10 @@ tcl::namespace::eval textblock { } default { if {$requested_ft_header eq ""} { - set ft_header $requested_ft + set ft_header $requested_ft } if {$requested_ft_body eq ""} { - set ft_body $requested_ft + set ft_body $requested_ft } } } @@ -621,7 +621,7 @@ tcl::namespace::eval textblock { if {![llength $args]} { return $o_opts_table - } + } if {[llength $args] == 1} { if {[lindex $args 0] in [list %topt_keys%]} { #query single option @@ -634,7 +634,7 @@ tcl::namespace::eval textblock { tcl::dict::set infodict debug [ansistring VIEW $val] } -framemap_body - -framemap_header - -framelimits_body - -framelimits_header { - tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] + tcl::dict::set returndict effective [tcl::dict::get $o_opts_table_effective $k] } } tcl::dict::set returndict info $infodict @@ -663,11 +663,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase_header - -ansibase_body - -ansiborder_header - -ansiborder-body - -ansiborder_footer { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set ansi_codes [list] ; + set ansi_codes [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret $k value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend ansi_codes $code @@ -684,7 +684,7 @@ tcl::namespace::eval textblock { -framemap_body - -framemap_header { #upvar ::textblock::class::opts_table_defaults tdefaults #set default_bmap [tcl::dict::get $tdefaults -framemap_body] - #todo - check keys and map + #todo - check keys and map if {[llength $v] == 1} { if {$v eq "default"} { upvar ::textblock::class::opts_table_defaults tdefaults @@ -700,7 +700,7 @@ tcl::namespace::eval textblock { switch -- $subk { topleft - topinner - topright - topsolo - middleleft - middleinner - middleright - middlesolo - bottomleft - bottominner - bottomright - bottomsolo - onlyleft - onlyinner - onlyright - onlysolo {} default { - error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" + error "textblock::table::configure invalid $subk. Known values {topleft topinner topright topsolo middleleft middleinner middleright middlesolo bottomleft bottominner bottomright bottomsolo onlyleft onlyinner onlyright onlysolo}" } } #safe jumptable test @@ -752,14 +752,14 @@ tcl::namespace::eval textblock { } -show_hseps { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations } -show_edge { if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } lappend checked_opts $k $v #these don't affect column width calculations - except if table -minwidth/-maxwidth come into play @@ -768,7 +768,7 @@ tcl::namespace::eval textblock { -show_vseps { #we allow empty string - so don't use -strict boolean check if {![tcl::string::is boolean $v]} { - error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" + error "textblock::table::configure invalid $k '$v'. Must be a boolean or empty string" } #affects width calculations set o_calculated_column_widths [list] @@ -807,7 +807,7 @@ tcl::namespace::eval textblock { if {[my width] < [expr {$twidth+2}]} { set o_calculated_column_widths [list] tcl::dict::set o_opts_table -minwidth [expr {$twidth+2}] - } + } tcl::dict::set o_opts_table -title $v } default { @@ -840,7 +840,7 @@ tcl::namespace::eval textblock { } } #ansireset exception - tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] + tcl::dict::set o_opts_table -ansireset [tcl::dict::get $o_opts_table_effective -ansireset] return $o_opts_table } @@ -858,7 +858,7 @@ tcl::namespace::eval textblock { for {set c 0} {$c < $matrix_colcount} {incr c} { my add_column -headers "" } - } + } set table_colcount [my column_count] if {$table_colcount != $matrix_colcount} { error "textblock::table::printmatrix column count of table doesn't match column count of matrix" @@ -874,7 +874,7 @@ tcl::namespace::eval textblock { method as_matrix {{cmd ""}} { #*** !doctools #[call class::table [method as_matrix] [arg ?cmd?]] - #[para] return a struct::matrix command representing the data portion of the table. + #[para] return a struct::matrix command representing the data portion of the table. if {$cmd eq ""} { set m [struct::matrix] @@ -883,8 +883,8 @@ tcl::namespace::eval textblock { } $m add columns [tcl::dict::size $o_columndata] $m add rows [tcl::dict::size $o_rowdefs] - tcl::dict::for {k v} $o_columndata { - $m set column $k $v + tcl::dict::for {k v} $o_columndata { + $m set column $k $v } return $m } @@ -907,17 +907,17 @@ tcl::namespace::eval textblock { } } } - set colcount [tcl::dict::size $o_columndefs] + set colcount [tcl::dict::size $o_columndefs] tcl::dict::set o_columndata $colcount [list] - #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists - tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists + #tcl::dict::set o_columndefs $colcount $defaults ;#ensure record exists + tcl::dict::set o_columndefs $colcount $o_opts_column_defaults ;#ensure record exists tcl::dict::set o_columnstates $colcount [tcl::dict::create minwidthbodyseen 0 maxwidthbodyseen 0 maxwidthheaderseen 0] set prev_calculated_column_widths $o_calculated_column_widths - if {[catch { + if {[catch { my configure_column $colcount {*}$opts } errMsg]} { #configure failed - ensure o_columndata and o_columndefs entries are removed @@ -926,7 +926,7 @@ tcl::namespace::eval textblock { tcl::dict::unset o_columnstates $colcount #undo cache invalidation set o_calculated_column_widths $prev_calculated_column_widths - error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_column failed to configure with supplied options $opts. Err:\n$errMsg" } #any add_column that succeeds should invalidate the calculated column widths set o_calculated_column_widths [list] @@ -945,7 +945,7 @@ tcl::namespace::eval textblock { method column_count {} { #*** !doctools #[call class::table [method column_count]] - #[para] return the number of columns + #[para] return the number of columns return [tcl::dict::size $o_columndefs] } method configure_column {index_expression args} { @@ -956,7 +956,7 @@ tcl::namespace::eval textblock { set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] if {$cidx eq ""} { error "textblock::table::configure_column - no column defined at index '$cidx'.Use add_column to define columns" - } + } if {![llength $args]} { return [tcl::dict::get $o_columndefs $cidx] } else { @@ -991,7 +991,7 @@ tcl::namespace::eval textblock { } set checked_opts [tcl::dict::get $o_columndefs $cidx] ;#copy of current state - set hstates $o_headerstates ;#operate on a copy + set hstates $o_headerstates ;#operate on a copy set colstate [tcl::dict::get $o_columnstates $cidx] set args_got_headers 0 set args_got_header_colspans 0 @@ -1000,7 +1000,7 @@ tcl::namespace::eval textblock { -headers { set args_got_headers 1 set i 0 - set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. + set maxseen 0 ;#don't compare with cached colstate maxwidthheaderseen - we have all the headers for the column right here and need to refresh the colstate maxwidthheaderseen values completely. foreach hdr $v { set currentmax [my header_height_calc $i $cidx] ;#exclude current column - ie look at heights for this header in all other columns #set this_header_height [textblock::height $hdr] @@ -1052,7 +1052,7 @@ tcl::namespace::eval textblock { # } #} else { set header_spans [tcl::dict::get $cspans $h] - set remaining [lindex $header_spans 0] + set remaining [lindex $header_spans 0] if {$remaining ne "any"} { incr remaining -1 } @@ -1109,11 +1109,11 @@ tcl::namespace::eval textblock { } -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set col_ansibase_items [list] ; + set col_ansibase_items [list] foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend col_ansibase_items $code @@ -1146,13 +1146,13 @@ tcl::namespace::eval textblock { } #args checked - ok to update headerstates, headerdefs and columndefs and columnstates tcl::dict::set o_columndefs $cidx $checked_opts - set o_headerstates $hstates + set o_headerstates $hstates dict for {hidx hstate} $hstates { #configure_header if {![dict exists $o_headerdefs $hidx]} { #remove calculated members -values -colspans set hdefaults [dict remove $o_opts_header_defaults -values -colspans] - dict set o_headerdefs $hidx $hdefaults + dict set o_headerdefs $hidx $hdefaults } } @@ -1183,7 +1183,7 @@ tcl::namespace::eval textblock { method header_count {} { #*** !doctools #[call class::table [method header_count]] - #[para] return the number of header rows + #[para] return the number of header rows return [tcl::dict::size $o_headerstates] } method header_count_calc {} { @@ -1232,7 +1232,7 @@ tcl::namespace::eval textblock { method header_colspans {} { #*** !doctools #[call class::table [method header_colspans]] - #[para] Show the colspans configured for all headers + #[para] Show the colspans configured for all headers #set num_headers [my header_count_calc] set num_headers [my header_count] @@ -1242,9 +1242,9 @@ tcl::namespace::eval textblock { set colspans_for_column [tcl::dict::get $cdef -header_colspans] for {set h 0} {$h < $num_headers} {incr h} { set headerspans [punk::lib::dict_getdef $colspans_by_header $h [list]] - set defined_span [lindex $colspans_for_column $h] + set defined_span [lindex $colspans_for_column $h] set i 0 - set spanremaining [lindex $headerspans 0] + set spanremaining [lindex $headerspans 0] if {$spanremaining ne "any"} { if {$spanremaining eq ""} { set spanremaining 1 @@ -1256,7 +1256,7 @@ tcl::namespace::eval textblock { set spanremaining "any" } elseif {$s == 0} { if {$spanremaining ne "any"} { - incr spanremaining -1 + incr spanremaining -1 } } else { set spanremaining [expr {$s - 1}] @@ -1273,7 +1273,7 @@ tcl::namespace::eval textblock { } else { lappend headerspans $defined_span } - tcl::dict::set colspans_by_header $h $headerspans + tcl::dict::set colspans_by_header $h $headerspans } } return $colspans_by_header @@ -1301,10 +1301,10 @@ tcl::namespace::eval textblock { } incr spanlen } - #overwrite the 'any' with it's actual span + #overwrite the 'any' with it's actual span set modified_spans [dict get $hcolspans $h] lset modified_spans $c $spanlen - dict set hcolspans $h $modified_spans + dict set hcolspans $h $modified_spans } incr c } @@ -1315,7 +1315,7 @@ tcl::namespace::eval textblock { method configure_header {index_expression args} { #*** !doctools #[call class::table [method configure_header]] - #[para] - configure header row-wise + #[para] - configure header row-wise #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. #It can also be set column by column - but it is much easier (especially for colspans) to configure them on a header-row basis @@ -1331,7 +1331,7 @@ tcl::namespace::eval textblock { } if {![llength $args]} { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] tcl::dict::set result -colspans [tcl::dict::get $colspans_by_header $hidx] set header_row_items [list] @@ -1339,9 +1339,9 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - tcl::dict::set result -values $header_row_items + tcl::dict::set result -values $header_row_items #review - ensure always a headerdef record for each header? if {[tcl::dict::exists $o_headerdefs $hidx]} { @@ -1359,7 +1359,7 @@ tcl::namespace::eval textblock { #set val [tcl::dict::get $o_rowdefs $ridx $k] set infodict [tcl::dict::create] - #todo + #todo # -blockalignments and -textalignments lists # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} #if there is a value it overrides alignments specified on the column @@ -1370,14 +1370,14 @@ tcl::namespace::eval textblock { set colheaders [tcl::dict::get $cdef -headers] set relevant_header [lindex $colheaders $hidx] #The -headers element of the column def is allowed to have less elements than the total, even be empty. Number of headers is defined by the longest -header list in the set of columns - lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. + lappend header_row_items $relevant_header ;#may be empty string because column had nothing at that index, or may be empty string stored in that column. We don't differentiate. } - set val $header_row_items + set val $header_row_items set returndict [tcl::dict::create option $k value $val ansireset "\x1b\[m"] } -colspans { - set colspans_by_header [my header_colspans] + set colspans_by_header [my header_colspans] set result [tcl::dict::create] set val [tcl::dict::get $colspans_by_header $hidx] #ansireset not required @@ -1412,11 +1412,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set header_ansibase_items [list] ; + set header_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend header_ansibase_items $code @@ -1443,7 +1443,7 @@ tcl::namespace::eval textblock { if {[llength $v] > $numcols} { error "textblock::table::configure_header -colspans length ([llength $v]) is longer than number of columns ([tcl::dict::size $o_columndefs])" } - if {[llength $v] < $numcols} { + if {[llength $v] < $numcols} { puts stderr "textblock::table::configure_header warning - only [llength $v] spans specified for [tcl::dict::size $o_columndefs] columns." puts stderr "It is recommended to set all spans explicitly. (auto-calc not implemented)" } @@ -1457,7 +1457,7 @@ tcl::namespace::eval textblock { } if {!$first_is_ok} { error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" - } + } #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) set remaining $firstspan if {$remaining ne "any"} { @@ -1469,7 +1469,7 @@ tcl::namespace::eval textblock { foreach span [lrange $v 1 end] { if {$remaining eq "any"} { if {$span eq "any"} { - set remaining "any" + set remaining "any" } elseif {$span > 0} { #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { @@ -1479,7 +1479,7 @@ tcl::namespace::eval textblock { set remaining $span incr remaining -1 } else { - #zero following an any - leave remaining as any + #zero following an any - leave remaining as any } } else { if {$span eq "0"} { @@ -1546,7 +1546,7 @@ tcl::namespace::eval textblock { # -- -- -- -- -- -- #also update maxwidthseen & maxheightseen set i 0 - set maxwidthseen 0 + set maxwidthseen 0 #set maxheightseen 0 foreach hdr $thiscol_headers_vertical { lassign [textblock::size $hdr] _w this_header_width _h this_header_height @@ -1567,7 +1567,7 @@ tcl::namespace::eval textblock { } } -colspans { - #sequence has been verified above - we need to split it and store across columns + #sequence has been verified above - we need to split it and store across columns set c 0 ;#column index foreach span $v { set colspans [tcl::dict::get $o_columndefs $c -header_colspans] @@ -1615,7 +1615,7 @@ tcl::namespace::eval textblock { } #set o_headerstate $hidx -minheight? -maxheight? ??? - tcl::dict::set o_headerdefs $hidx $update_hdefs + tcl::dict::set o_headerdefs $hidx $update_hdefs } method add_row {valuelist args} { @@ -1635,14 +1635,14 @@ tcl::namespace::eval textblock { if {[tcl::dict::size $o_columndefs] == 0 && ![llength $valuelist]} { error "add_row - no values supplied, and no columns defined, so cannot use default column values" } - + set defaults [tcl::dict::create\ -minheight 1\ -maxheight ""\ -ansibase ""\ -ansireset "\uFFEF"\ ] - set o_opts_row_defaults $defaults + set o_opts_row_defaults $defaults if {[llength $args] %2 !=0} { error "[tcl::namespace::current]::table::add_row unexpected argument count. Require name value pairs. Known options: [tcl::dict::keys $defaults]" @@ -1676,23 +1676,23 @@ tcl::namespace::eval textblock { } } set rowcount [tcl::dict::size $o_rowdefs] - tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure + tcl::dict::set o_rowdefs $rowcount $defaults ;# ensure record exists before configure if {[catch { my configure_row $rowcount {*}$opts } errMsg]} { #undo anything we saved before configure_row tcl::dict::unset o_rowdefs $rowcount - #remove auto_columns + #remove auto_columns if {$auto_columns} { set o_columndata [tcl::dict::create] set o_columndefs [tcl::dict::create] set o_columnstate [tcl::dict::create] } - error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" + error "add_row failed to configure with supplied options $opts. Err:\n$errMsg" } - + set c 0 set max_height_seen 1 foreach v $valuelist { @@ -1774,11 +1774,11 @@ tcl::namespace::eval textblock { switch -- $k { -ansibase { set parts [punk::ansi::ta::split_codes_single $v] ;#caller may have supplied separated codes eg "[a+ Yellow][a+ red]" - set row_ansibase_items [list] ; + set row_ansibase_items [list] ; foreach {pt code} $parts { if {$pt ne ""} { #we don't expect plaintext in an ansibase - error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" + error "Unable to interpret -ansibase value as ansi SGR codes. Plaintext detected. Consider using for example: '\[punk::ansi::a+ green]' (or alias '\[a+ green]') to build ansi. debug view: [punk::ansi::ansistring VIEW $v]" } if {$code ne ""} { lappend row_ansibase_items $code @@ -1954,7 +1954,7 @@ tcl::namespace::eval textblock { } method get_column_by_index {index_expression args} { #puts "+++> get_column_by_index $index_expression $args [tcl::namespace::current]" - #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. + #index_expression may be something like end-1 or 2+2 - we can't directly use it as a lookup for dicts. set opts [tcl::dict::create\ -position "inner"\ -return "string"\ @@ -1992,7 +1992,7 @@ tcl::namespace::eval textblock { set topt_show_header [tcl::dict::get $o_opts_table -show_header] if {$topt_show_header eq ""} { - set allheaders 0 + set allheaders 0 set all_cols [tcl::dict::keys $o_columndefs] foreach c $all_cols { incr allheaders [llength [tcl::dict::get $o_columndefs $c -headers]] @@ -2015,8 +2015,8 @@ tcl::namespace::eval textblock { set boxlimits "" set joins "" - set header_boxlimits [list] - set header_body_joins [list] + set header_boxlimits [list] + set header_body_joins [list] set ftypes [my Get_frametypes] @@ -2035,9 +2035,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $opt_posn $fname_body] set header_body_joins [tcl::dict::get $limj bodyjoins] - set joins [tcl::dict::get $limj joins] - set boxlimits_position [tcl::dict::get $limj boxlimits] - set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] + set joins [tcl::dict::get $limj joins] + set boxlimits_position [tcl::dict::get $limj boxlimits] + set boxlimits_toprow [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available set boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_position] set boxlimits_headerless [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $boxlimits_toprow] @@ -2060,9 +2060,9 @@ tcl::namespace::eval textblock { set sep_elements_horizontal $::textblock::class::table_hseps set sep_elements_vertical $::textblock::class::table_vseps - set topmap [tcl::dict::get $fmap top$opt_posn] - set botmap [tcl::dict::get $fmap bottom$opt_posn] - set midmap [tcl::dict::get $fmap middle$opt_posn] + set topmap [tcl::dict::get $fmap top$opt_posn] + set botmap [tcl::dict::get $fmap bottom$opt_posn] + set midmap [tcl::dict::get $fmap middle$opt_posn] set onlymap [tcl::dict::get $fmap only$opt_posn] set hdrmap [tcl::dict::get $hmap only${opt_posn}] @@ -2074,7 +2074,7 @@ tcl::namespace::eval textblock { set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] - #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway + #top should work for all header rows regarding vseps - as we only use it to reduce the box elements, and lower headers have same except for tlc which isn't present anyway set headerseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] lassign [my Get_seps] _h show_seps_h _v show_seps_v @@ -2091,7 +2091,7 @@ tcl::namespace::eval textblock { set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] ;#merged to single during configure set ansiborder_header [tcl::dict::get $o_opts_table -ansiborder_header] if {[tcl::dict::get $o_opts_table -frametype_header] eq "block"} { - set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] + set extrabg [punk::ansi::codetype::sgr_merge_singles [list $ansibase_header] -filter_fg 1] set ansiborder_final $ansibase_header$ansiborder_header$extrabg } else { set ansiborder_final $ansibase_header$ansiborder_header @@ -2099,7 +2099,7 @@ tcl::namespace::eval textblock { set RST [punk::ansi::a] - set hcolwidth $colwidth + set hcolwidth $colwidth #set hcolwidth [my column_width_configured $cidx] set hcell_line_blank [tcl::string::repeat " " $hcolwidth] @@ -2149,7 +2149,7 @@ tcl::namespace::eval textblock { if {$hrow == $hmax} { set header_joins $header_body_joins } else { - set header_joins $joins + set header_joins $joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] @@ -2167,7 +2167,7 @@ tcl::namespace::eval textblock { set next_spanlist [tcl::dict::get $all_colspans [expr {$hrow+1}]] set spanbelow [lindex $next_spanlist $cidx] if {$spanbelow == 0} { - #we don't want a down-join for blc - use a framedef with only left joins + #we don't want a down-join for blc - use a framedef with only left joins tcl::dict::set startmap blc [tcl::dict::get $framedef_leftbox blc] } } else { @@ -2181,7 +2181,7 @@ tcl::namespace::eval textblock { #May be better to require user to pre-wrap as needed ##set hval [textblock::renderspace -width $colwidth -wrap 1 "" $hval] - #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used + #review - contentwidth of hval can be greater than $colwidth+2 - if so frame function will detect and frame_cache will not be used #This ellipsis 0 makes a difference (unwanted ellipsis at rhs of header column that starts span) # -width is always +2 - as the boxlimits take into account show_vseps and show_edge @@ -2219,10 +2219,10 @@ tcl::namespace::eval textblock { #puts ">> remaining_spans: $remaining_spans" set spancol [expr {$cidx + 1}] set h_lines [lrepeat $rowh ""] - set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + set hcell_blank [::join $h_lines \n] ;#todo - just use -height option of frame? review - currently doesn't cache with -height and no contents - slow + - set last [expr {[llength $remaining_spans] -1}] set i 0 foreach s $remaining_spans { @@ -2238,9 +2238,9 @@ tcl::namespace::eval textblock { set limj [my Get_boxlimits_and_joins $next_posn $fname_body] set span_joins_body [tcl::dict::get $limj bodyjoins] - set span_joins [tcl::dict::get $limj joins] - set span_boxlimits [tcl::dict::get $limj boxlimits] - set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] + set span_joins [tcl::dict::get $limj joins] + set span_boxlimits [tcl::dict::get $limj boxlimits] + set span_boxlimits_top [tcl::dict::get $limj boxlimits_top] #use struct::set instead of simple for loop - will be faster at least when critcl available #set span_boxlimits [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits] #set span_boxlimits_top [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_body] $span_boxlimits_top] @@ -2263,14 +2263,14 @@ tcl::namespace::eval textblock { } } else { #join to body - tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype } } if {$hrow == $hmax} { set header_joins $span_joins_body } else { - set header_joins $span_joins + set header_joins $span_joins } if {![tcl::dict::get $o_opts_table -show_edge]} { set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$next_posn] ] @@ -2285,7 +2285,7 @@ tcl::namespace::eval textblock { } else { break } - incr spancol + incr spancol incr i } @@ -2304,7 +2304,7 @@ tcl::namespace::eval textblock { set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] } else { - set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] } } else { @@ -2349,10 +2349,10 @@ tcl::namespace::eval textblock { set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] #POTENTIAL BUG (fixed with spans_to_rhs above) #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) - #we need to shift 1 to the left when doing our overtype with blockalign right + #we need to shift 1 to the left when doing our overtype with blockalign right #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge #(even though the column position may be left or inner) - + } else { @@ -2389,12 +2389,12 @@ tcl::namespace::eval textblock { set h_lines [lrepeat $padheight $bline] set hcell_blank [::join $h_lines \n] set header_frame $hcell_blank - } else { + } else { set bline [tcl::string::repeat $TSUB $padwidth] set h_lines [lrepeat $rowh $bline] set hcell_blank [::join $h_lines \n] # -usecache 1 ok - #frame borders will never display - so use the simplest frametype and don't apply any ansi + #frame borders will never display - so use the simplest frametype and don't apply any ansi #puts "===>zerospan hlims: $hlims" set header_frame [textblock::frame -checkargs 0 -ellipsis 0 -width [expr {$padwidth+2}] -type ascii\ -boxlimits $hlims -boxmap $framesub_map $hcell_blank\ @@ -2424,13 +2424,13 @@ tcl::namespace::eval textblock { append part_header $header_frame\n } set part_header [tcl::string::trimright $part_header \n] - lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight + lassign [textblock::size $part_header] _w return_headerwidth _h return_headerheight set padline [tcl::string::repeat $TSUB $return_headerwidth] - set adjusted_lines [list] + set adjusted_lines [list] foreach ln [split $part_header \n] { if {[tcl::string::first $TSUB $ln] >=0} { - lappend adjusted_lines $padline + lappend adjusted_lines $padline } else { lappend adjusted_lines $ln } @@ -2496,7 +2496,7 @@ tcl::namespace::eval textblock { set cell_ansibase "" set ansiborder_body_col_row $border_ansi$row_bg - set ansiborder_final $ansiborder_body_col_row + set ansiborder_final $ansiborder_body_col_row #$c will always have ansi resets due to overtype behaviour ? #todo - review overtype if {[punk::ansi::ta::detect $c]} { @@ -2514,7 +2514,7 @@ tcl::namespace::eval textblock { #set cell_bg [punk::ansi::codetype::sgr_merge_singles [list $takebg] -filter_fg 1] set cell_bg [punk::ansi::codetype::sgr_merge_singles $codes -filter_fg 1 -filter_reset 1] #puts --->[ansistring VIEW $codes] - + if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end]]} { if {[punk::ansi::codetype::is_sgr_reset [lindex $codes end-1]]} { #special case double reset at end of content @@ -2527,7 +2527,7 @@ tcl::namespace::eval textblock { set cell_ansibase $cell_ansi_tail } else { #single trailing reset in content - set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase + set cell_ansibase "" ;#cell doesn't contribute to frame's ansibase } } else { if {$ftblock} { @@ -2555,7 +2555,7 @@ tcl::namespace::eval textblock { } else { set bmap $topmap if {$do_show_header} { - set blims $blims_top + set blims $blims_top } else { set blims $blims_top_headerless } @@ -2631,7 +2631,7 @@ tcl::namespace::eval textblock { } else { set output $part_body } - return $output + return $output } else { return [tcl::dict::create header $part_header body $part_body headerwidth $return_headerwidth headerheight $return_headerheight bodywidth $return_bodywidth bodyheight $return_bodyheight] } @@ -2652,15 +2652,15 @@ tcl::namespace::eval textblock { } error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" } - #assert cidx is integer >=0 - set num_header_rows [my header_count] - set cdef [tcl::dict::get $o_columndefs $cidx] - set headerlist [tcl::dict::get $cdef -headers] + #assert cidx is integer >=0 + set num_header_rows [my header_count] + set cdef [tcl::dict::get $o_columndefs $cidx] + set headerlist [tcl::dict::get $cdef -headers] set ansibase_col [tcl::dict::get $cdef -ansibase] set textalign [tcl::dict::get $cdef -textalign] switch -- $textalign { left {set pad right} - right {set pad left} + right {set pad left} default { set pad "centre" ;#todo? } @@ -2684,7 +2684,7 @@ tcl::namespace::eval textblock { # lappend configured_widths [my column_width_configured $c] #} - set output [tcl::dict::create] + set output [tcl::dict::create] tcl::dict::set output headers [list] set showing_vseps [my Showing_vseps] @@ -2720,10 +2720,10 @@ tcl::namespace::eval textblock { set headerrow_colspans [tcl::dict::get $all_colspans $hrow] - set this_span [lindex $headerrow_colspans $cidx] + set this_span [lindex $headerrow_colspans $cidx] - #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign + #set this_hdrwidth [lindex $configured_widths $cidx] + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] @@ -2734,7 +2734,7 @@ tcl::namespace::eval textblock { set hval_lines [lrange $hval_lines 0 $header_maxdataheight-1] ;#vertical align top set hval_block [::join $hval_lines \n] set hcell [textblock::pad $hval_block -width $this_hdrwidth -padchar " " -within_ansi 1 -which $pad] - tcl::dict::lappend output headers $hcell + tcl::dict::lappend output headers $hcell } @@ -2758,7 +2758,7 @@ tcl::namespace::eval textblock { set maxdataheight [tcl::dict::get $o_rowstates $r -maxheight] set rowdefminh [tcl::dict::get $o_rowdefs $r -minheight] set rowdefmaxh [tcl::dict::get $o_rowdefs $r -maxheight] - if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { + if {"$rowdefminh$rowdefmaxh" ne "" && $rowdefminh eq $rowdefmaxh} { set rowh $rowdefminh ;#an exact height is defined for the row } else { if {$rowdefminh eq ""} { @@ -2780,7 +2780,7 @@ tcl::namespace::eval textblock { } } } - + set cell_lines [lrepeat $rowh $cell_line_blank] #set cell_blank [join $cell_lines \n] @@ -2792,7 +2792,7 @@ tcl::namespace::eval textblock { set cval_lines [lrange $cval_lines 0 $rowh-1] set cval_block [::join $cval_lines \n] - #//JMN assert widest cval_line = datawidth = known_blockwidth + #//JMN assert widest cval_line = datawidth = known_blockwidth set cell [textblock::pad $cval_block -known_blockwidth $datawidth -width $datawidth -padchar " " -within_ansi 1 -which $pad] #set cell [textblock::pad $cval_block -width $colwidth -padchar " " -within_ansi 0 -which left] tcl::dict::lappend output cells $cell @@ -2817,7 +2817,7 @@ tcl::namespace::eval textblock { #[call class::table [method debug]] #[para] display lots of debug information about how the table is constructed. - #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) + #nice to lay this out with tables - but this is the one function where we really should provide the ability to avoid tables in case things get really broken (e.g major refactor) set defaults [tcl::dict::create\ -usetables 1\ ] @@ -2836,7 +2836,7 @@ tcl::namespace::eval textblock { puts stdout "rowstates: $o_rowstates" #puts stdout "columndefs: $o_columndefs" puts stdout "columndefs:" - if {!$opt_usetables} { + if {!$opt_usetables} { tcl::dict::for {k v} $o_columndefs { puts " $k $v" } @@ -2849,7 +2849,7 @@ tcl::namespace::eval textblock { continue } $t add_column -headers $property - } + } break } @@ -2858,15 +2858,15 @@ tcl::namespace::eval textblock { set max_widths [tcl::dict::create 0 0 1 0 2 0 3 0] ;#max inner table column widths tcl::dict::for {col coldef} $o_columndefs { set row [list $col] - set colheaders [tcl::dict::get $coldef -headers] + set colheaders [tcl::dict::get $coldef -headers] #inner table probably overkill here ..but just as easy set htable [textblock::class::table new] $htable configure -show_header 1 -show_edge 0 -show_hseps 0 $htable add_column -headers row $htable add_column -headers text $htable add_column -headers WxH - $htable add_column -headers span - set hnum 0 + $htable add_column -headers span + set hnum 0 set spans [tcl::dict::get $o_columndefs $col -header_colspans] foreach h $colheaders s $spans { lassign [textblock::size $h] _w width _h height @@ -2881,7 +2881,7 @@ tcl::namespace::eval textblock { if {$w > [tcl::dict::get $max_widths $icol]} { tcl::dict::set max_widths $icol $w } - incr icol + incr icol } } @@ -2899,7 +2899,7 @@ tcl::namespace::eval textblock { tcl::dict::for {innercol maxw} $max_widths { $htable configure_column $innercol -minwidth $maxw -blockalign left } - lappend row [$htable print] + lappend row [$htable print] $htable destroy } default { @@ -2923,7 +2923,7 @@ tcl::namespace::eval textblock { tcl::dict::for {k coldef} $o_columndefs { if {[tcl::dict::exists $o_columndata $k]} { set headerlist [tcl::dict::get $coldef -headers] - set coldata [tcl::dict::get $o_columndata $k] + set coldata [tcl::dict::get $o_columndata $k] set colinfo "rowcount: [llength $coldata]" set allfields [concat $headerlist $coldata] if {[llength $allfields]} { @@ -2944,7 +2944,7 @@ tcl::namespace::eval textblock { if {$c == 0} { lappend cols [my get_column_by_index $c -position left] " " } elseif {$c == $max} { - lappend cols [my get_column_by_index $c -position right] + lappend cols [my get_column_by_index $c -position right] } else { lappend cols [my get_column_by_index $c -position inner] " " } @@ -3089,7 +3089,7 @@ tcl::namespace::eval textblock { lappend configured_widths [my column_width_configured $c] } set header_colspans [my header_colspans] - set width_max $colwidth + set width_max $colwidth set test_width $colwidth set showing_vseps [my Showing_vseps] set thiscol_widest_header [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] @@ -3125,7 +3125,7 @@ tcl::namespace::eval textblock { if {$showing_vseps} { incr others_width 1 } - } + } set total_spanned_width [expr {$width_max + $others_width}] if {$thiscol_widest_header > $total_spanned_width} { #this just allocates the extra space in the current column - which is not great. @@ -3172,9 +3172,9 @@ tcl::namespace::eval textblock { return true } } - return false + return false } - + method column_datawidth {index_expression args} { set opts [tcl::dict::create\ -headers 0\ @@ -3289,11 +3289,11 @@ tcl::namespace::eval textblock { set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] set widest [expr {max($valwidest,$hwidest)}] } else { - set widest $hwidest + set widest $hwidest } return $widest } - #print1 uses basic column joining - useful for testing/debug especially with colspans + #print1 uses basic column joining - useful for testing/debug especially with colspans method print1 {args} { if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3338,15 +3338,15 @@ tcl::namespace::eval textblock { incr colposn } if {[llength $blocks]} { - return [textblock::join -- {*}$blocks] + return [textblock::join -- {*}$blocks] } else { return "No columns matched" } } method columncalc_spans {allocmethod} { - set colwidths [tcl::dict::create] ;# to use tcl::dict::incr + set colwidths [tcl::dict::create] ;# to use tcl::dict::incr set colspace_added [tcl::dict::create] - + set ordered_spans [tcl::dict::create] tcl::dict::for {col spandata} [my spangroups] { set dwidth [my column_datawidth $col -data 1 -headers 0 -footers 0 -cached 1] @@ -3363,7 +3363,7 @@ tcl::namespace::eval textblock { } } tcl::dict::set colwidths $col $dwidth ;#spangroups is ordered by column - so colwidths dict will be correctly ordered - tcl::dict::set colspace_added $col 0 + tcl::dict::set colspace_added $col 0 set spanlengths [tcl::dict::get $spandata spanlengths] foreach slen $spanlengths { @@ -3373,13 +3373,13 @@ tcl::namespace::eval textblock { set hwidth [tcl::dict::get $s headerwidth] set hrow [tcl::dict::get $s hrow] set scol [tcl::dict::get $s startcol] - tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth + tcl::dict::set ordered_spans $scol,$hrow membercols $col $dwidth tcl::dict::set ordered_spans $scol,$hrow headerwidth $hwidth } } } - #safe jumptable test + #safe jumptable test #dict for {spanid spandata} $ordered_spans {} tcl::dict::for {spanid spandata} $ordered_spans { lassign [split $spanid ,] startcol hrow @@ -3390,7 +3390,7 @@ tcl::namespace::eval textblock { if {$num_cols_spanned == 1} { set col [lindex $memcols 0] set space_to_alloc [expr {$hwidth - [tcl::dict::get $colwidths $col]}] - if {$space_to_alloc > 0} { + if {$space_to_alloc > 0} { set maxwidth [tcl::dict::get $o_columndefs $col -maxwidth] if {$maxwidth ne ""} { if {$maxwidth > [tcl::dict::get $colwidths $col]} { @@ -3400,7 +3400,7 @@ tcl::namespace::eval textblock { } set will_alloc [expr {min($space_to_alloc,$can_alloc)}] } else { - set will_alloc $space_to_alloc + set will_alloc $space_to_alloc } if {$will_alloc} { #tcl::dict::set colwidths $col $hwidth @@ -3422,12 +3422,12 @@ tcl::namespace::eval textblock { if {[my Showing_vseps]} { set sepcount [expr {$num_cols_spanned -1}] incr space_to_alloc -$sepcount - } + } #review - we want to reduce overallocation to earlier or later columns - hence the use of colspace_added switch -- $allocmethod { least { #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3445,10 +3445,10 @@ tcl::namespace::eval textblock { } } least_unmaxed { - #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth + #TODO - fix header truncation/overflow issues when they are restricted by column maxwidth #(we should be able to collapse column width to zero and have header colspans gracefully respond) #add to least-expanded each time - #safer than method 1 - pretty balanced + #safer than method 1 - pretty balanced if {$space_to_alloc > 0} { for {set i 0} {$i < $space_to_alloc} {incr i} { set ordered_colspace_added [lsort -stride 2 -index 1 -integer $colspace_added] @@ -3485,7 +3485,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3521,7 +3521,7 @@ tcl::namespace::eval textblock { foreach col $ordered_colids { tcl::dict::incr colwidths $col - tcl::dict::incr colspace_added $col + tcl::dict::incr colspace_added $col incr space_to_alloc -1 if {$space_to_alloc == 0} { break @@ -3533,10 +3533,10 @@ tcl::namespace::eval textblock { } - return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] + return [list ordered_spans $ordered_spans colwidths $column_widths adjustments $colspace_added] } - #spangroups keyed by column + #spangroups keyed by column method spangroups {} { #*** !doctools #[call class::table [method spangroups]] @@ -3550,8 +3550,8 @@ tcl::namespace::eval textblock { tcl::dict::set spangroups $c [list spanlengths {}] set spanlist [my column_get_spaninfo $c] set index_spanlen_val 5 - set spanlist [lsort -index $index_spanlen_val -integer $spanlist] - set ungrouped $spanlist + set spanlist [lsort -index $index_spanlen_val -integer $spanlist] + set ungrouped $spanlist while {[llength $ungrouped]} { set spanlen [lindex $ungrouped 0 $index_spanlen_val] @@ -3569,14 +3569,14 @@ tcl::namespace::eval textblock { tcl::dict::set headerwidths $hcol,$hrow $hwidth } lappend spaninfo headerwidth $hwidth - lappend sgroup $spaninfo + lappend sgroup $spaninfo } set spanlengths [tcl::dict::get $spangroups $c spanlengths] lappend spanlengths $spanlen tcl::dict::set spangroups $c spanlengths $spanlengths tcl::dict::set spangroups $c spangroups $spanlen $sgroup set ungrouped [lremove $ungrouped {*}$spangroup_posns] - } + } } return $spangroups } @@ -3660,14 +3660,14 @@ tcl::namespace::eval textblock { basic { #basic column by column - This allocates extra space to first span/column as they're encountered. #This can leave the table quite unbalanced with regards to whitespace and the table is also not as compact as it could be especially with regards to header colspans - #The header values can extend over some of the spanned columns - but not optimally so. + #The header values can extend over some of the spanned columns - but not optimally so. set o_calculated_column_widths [list] for {set c 0} {$c < $column_count} {incr c} { lappend o_calculated_column_widths [my basic_column_width $c] } } simplistic { - #just uses the widest column data or header element. + #just uses the widest column data or header element. #this is even less compact than basic and doesn't allow header colspan values to extend beyond their first spanned column #This is a conservative option potentially useful in testing/debugging. set o_calculated_column_widths [list] @@ -3676,7 +3676,7 @@ tcl::namespace::eval textblock { } } span { - #widest of smallest spans first method + #widest of smallest spans first method #set calcresult [my columncalc_spans least] set calcresult [my columncalc_spans least_unmaxed] set o_calculated_column_widths [tcl::dict::get $calcresult colwidths] @@ -3695,7 +3695,7 @@ tcl::namespace::eval textblock { return $o_calculated_column_widths } method print2 {args} { - variable full_column_cache + variable full_column_cache set full_column_cache [tcl::dict::create] if {![llength $args]} { @@ -3749,10 +3749,10 @@ tcl::namespace::eval textblock { tcl::dict::set full_column_cache $c $columninfo } set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] @@ -3762,12 +3762,12 @@ tcl::namespace::eval textblock { #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] #set table [overtype::renderspace -expand_right 1 -transparent \uFFFF $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3787,7 +3787,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3839,7 +3839,7 @@ tcl::namespace::eval textblock { } set blocks [list] set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set table "" foreach c $cols { @@ -3855,20 +3855,20 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] set nextcol [tcl::string::cat [tcl::dict::get $columninfo header] \n [tcl::dict::get $columninfo body]] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] if {$table eq ""} { - set table $nextcol + set table $nextcol set height [textblock::height $table] ;#only need to get height once at start } else { set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $table $nextcol] } - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {[llength $cols]} { - #return [textblock::join -- {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3888,7 +3888,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -3916,7 +3916,7 @@ tcl::namespace::eval textblock { method print {args} { #*** !doctools #[call class::table [method print]] - #[para] Return the table as text suitable for console display + #[para] Return the table as text suitable for console display if {![llength $args]} { set cols [tcl::dict::keys $o_columndata] @@ -3944,7 +3944,7 @@ tcl::namespace::eval textblock { } } set numposns [llength $cols] - set colposn 0 + set colposn 0 set padwidth 0 set header_build "" set body_blocks [list] @@ -3962,7 +3962,7 @@ tcl::namespace::eval textblock { } set columninfo [my get_column_by_index $c -return dict {*}$flags] #set nextcol [tcl::dict::get $columninfo column] - set bodywidth [tcl::dict::get $columninfo bodywidth] + set bodywidth [tcl::dict::get $columninfo bodywidth] set headerheight [tcl::dict::get $columninfo headerheight] #set nextcol_lines [split $nextcol \n] #set nextcol_header [join [lrange $nextcol_lines 0 $headerheight-1] \n] @@ -3971,7 +3971,7 @@ tcl::namespace::eval textblock { set nextcol_body [tcl::dict::get $columninfo body] if {$header_build eq "" && ![llength $body_blocks]} { - set header_build $nextcol_header + set header_build $nextcol_header } else { if {$headerheight > 0} { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -expand_right 1 -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] @@ -3979,7 +3979,7 @@ tcl::namespace::eval textblock { #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } lappend body_blocks $nextcol_body - incr padwidth $bodywidth + incr padwidth $bodywidth incr colposn } if {![llength $body_blocks]} { @@ -4014,7 +4014,7 @@ tcl::namespace::eval textblock { } set opt_titletransparent [tcl::dict::get $o_opts_table -titletransparent] switch -- $opt_titletransparent { - 0 { + 0 { set mapchar "" } 1 { @@ -4039,11 +4039,11 @@ tcl::namespace::eval textblock { method print_bodymatrix {} { #*** !doctools #[call class::table [method print_bodymatrix]] - #[para] output the matrix string corresponding to the body data using the matrix 2string format + #[para] output the matrix string corresponding to the body data using the matrix 2string format #[para] this will be a table without borders,headers,title etc and will exclude additional ANSI applied due to table, row or column settings. #[para] If the original cell data itself contains ANSI - the output will still contain those ansi codes. # - + set m [my as_matrix] $m format 2string @@ -4098,7 +4098,7 @@ tcl::namespace::eval textblock { return $t } - #more complex colspans + #more complex colspans proc spantest2 {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} @@ -4137,7 +4137,7 @@ tcl::namespace::eval textblock { -show_header -default "" -type boolean -show_edge -default "" -type boolean -forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured" - @values -min 0 -max 0 + @values -min 0 -max 0 } proc periodic {args} { @@ -4163,7 +4163,7 @@ tcl::namespace::eval textblock { " " " " " " " " " " " " " " " " " " " " " " " " "" "" "" "" "" "" ""\ "" "" "" 6 La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu\ "" "" "" 7 Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr\ - ] + ] set type_colours [list] @@ -4173,71 +4173,71 @@ tcl::namespace::eval textblock { set ansi [a+ {*}$fc web-black Web-gold] set val [list ansi $ansi cat alkaline_earth] foreach e $cat_alkaline_earth { - tcl::dict::set ecat $e $val + tcl::dict::set ecat $e $val } set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - #set ansi [a+ {*}$fc web-black Web-lightgreen] - set ansi [a+ {*}$fc black Term-113] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val } set cat [list Li Na K Rb Cs Fr] - #set ansi [a+ {*}$fc web-black Web-Khaki] - set ansi [a+ {*}$fc black Term-lightgoldenrod2] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val } - set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - #set ansi [a+ {*}$fc web-black Web-lightsalmon] - set ansi [a+ {*}$fc black Term-orange1] + set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Al Ga In Sn Tl Pb Bi Po] - set ansi [a+ {*}$fc web-black Web-lightskyblue] + set ansi [a+ {*}$fc web-black Web-lightskyblue] set val [list ansi $ansi cat post_transition_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list B Si Ge As Sb Te At] - #set ansi [a+ {*}$fc web-black Web-turquoise] - set ansi [a+ {*}$fc black Brightcyan] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list He Ne Ar Kr Xe Rn] - set ansi [a+ {*}$fc web-black Web-orchid] + set ansi [a+ {*}$fc web-black Web-orchid] set val [list ansi $ansi cat noble_gases] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr] - set ansi [a+ {*}$fc web-black Web-plum] + set ansi [a+ {*}$fc web-black Web-plum] set val [list ansi $ansi cat actinoids] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - #set ansi [a+ {*}$fc web-black Web-tan] - set ansi [a+ {*}$fc black Term-tan] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] set val [list ansi $ansi cat lanthanoids] foreach e $cat { tcl::dict::set ecat $e $val } - set ansi [a+ {*}$fc web-black Web-whitesmoke] + set ansi [a+ {*}$fc web-black Web-whitesmoke] set val [list ansi $ansi cat other] foreach e [list Mt Ds Rg Cn Nh Fl Mc Lv Ts Og] { tcl::dict::set ecat $e $val @@ -4264,7 +4264,7 @@ tcl::namespace::eval textblock { set header_0 [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18] set c 0 foreach h $header_0 { - $t configure_column $c -headers [list $h] -minwidth 2 + $t configure_column $c -headers [list $h] -minwidth 2 incr c } set ccount [$t column_count] @@ -4279,7 +4279,7 @@ tcl::namespace::eval textblock { } dict for {k v} $conf { if {[dict get $opts $k] ne ""} { - dict set conf $k [dict get $opts $k] + dict set conf $k [dict get $opts $k] } } @@ -4310,14 +4310,14 @@ tcl::namespace::eval textblock { } proc bookend_lines {block start {end "\x1b\[m"}} { - set out "" + set out "" foreach ln [split $block \n] { append out $start $ln $end \n } return [string range $out 0 end-1] } proc ansibase_lines {block {newprefix ""}} { - set base "" + set base "" set out "" if {$newprefix eq ""} { if {![punk::ansi::ta::detect $block]} { @@ -4340,7 +4340,7 @@ tcl::namespace::eval textblock { set code_idx 3 foreach {pt code} [lrange $parts 2 end] { if {[punk::ansi::codetype::is_sgr_reset $code]} { - set parts [linsert $parts $code_idx+1 $base] + set parts [linsert $parts $code_idx+1 $base] } incr code_idx 2 } @@ -4373,7 +4373,7 @@ tcl::namespace::eval textblock { incr offset } incr code_idx 2 - } + } append out {*}$parts \n } return [string range $out 0 end-1] @@ -4398,29 +4398,29 @@ tcl::namespace::eval textblock { Will not be visible if -show_edge is false" -titlealign -type string -choices {left centre right} -frametype -default "light" -type dict -choices {${$FRAMETYPES}} -choicerestricted 0\ - -help "frame type or dict for custom frame" + -help "frame type or dict for custom frame" -show_edge -default "" -type boolean\ -help "show outer border of table" - -show_seps -default "" -type boolean + -show_seps -default "" -type boolean -show_vseps -default "" -type boolean\ - -help "Show vertical table separators" + -help "Show vertical table separators" -show_hseps -default "" -type boolean\ -help "Show horizontal table separators (default 0 if no existing -table supplied)" -colheaders -default "" -type list\ -help {list of lists. list of column header values. Outer list must match number of columns. - A table + A table e.g single header row: -colheaders {{column_a} {column_b} {column_c}} e.g 2 header rows: -colheaders {{column_a "nextrow test"} {column_b} {column_c}} Note that each element of the outer list is itself a list so: - -colheaders {"column a" "column b" "column c"} + -colheaders {"column a" "column b" "column c"} Is likely not the right format if it was intended to have a single header row where the column titles contain spaces. The correct syntax for that would be: - -colheaders {{"column a"} {"column b"} {"column c"}} + -colheaders {{"column a"} {"column b"} {"column c"}} For spanning header cells - use 'set t [list_as_table -return tableobject ...]' and then something like: - $t configure_header 1 -colspans {3 0 0}; $t print + $t configure_header 1 -colspans {3 0 0}; $t print } -header -default "" -type list -multiple 1\ -help "Each supplied -header argument is a header row. @@ -4498,14 +4498,14 @@ tcl::namespace::eval textblock { if {[llength $colheaders] < $c+1} { lappend colheaders [lrepeat $r {}] } - set colinfo [lindex $colheaders $c] + set colinfo [lindex $colheaders $c] if {$r > [llength $colinfo]} { set diff [expr {$r - [llength $colinfo]}] lappend colinfo {*}[lrepeat $diff {}] } lappend colinfo $cell lset colheaders $c $colinfo - incr c + incr c } incr r } @@ -4516,15 +4516,15 @@ tcl::namespace::eval textblock { if {![tcl::dict::exists $opts received -show_header]} { set show_header 1 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } } else { if {![tcl::dict::exists $opts received -show_header]} { set show_header 0 } else { - set show_header [tcl::dict::get $opts -show_header] + set show_header [tcl::dict::get $opts -show_header] } - } + } if {[tcl::string::is integer -strict $opt_columns]} { set cols $opt_columns @@ -4536,7 +4536,7 @@ tcl::namespace::eval textblock { if {[llength $colheaders]} { set cols [llength $colheaders] } else { - set cols 2 ;#seems a reasonable default + set cols 2 ;#seems a reasonable default } } #defaults for new table only @@ -4605,13 +4605,13 @@ tcl::namespace::eval textblock { if {"-titlealign" in $received} { $t configure -titlealign [dict get $opts -titlealign] } - #puts stdout $rowdata + #puts stdout $rowdata if {[tcl::dict::get $opts -return] eq "table"} { set result [$t print] if {$is_new_table} { $t destroy } - return $result + return $result } else { return $t } @@ -4627,13 +4627,13 @@ tcl::namespace::eval textblock { error "textblock::block blockheight must be a positive integer" } if {$char eq ""} {return ""} - #using tcl::string::length is ok + #using tcl::string::length is ok if {[tcl::string::length $char] == 1} { set row [tcl::string::repeat $char $blockwidth] set mtrx [lrepeat $blockheight $row] return [::join $mtrx \n] } else { - set charblock [tcl::string::map [list \r\n \n] $char] + set charblock [tcl::string::map [list \r\n \n] $char] if {[tcl::string::last \n $charblock] >= 0} { if {$blockwidth > 1} { #set row [.= val $charblock {*}[lrepeat [expr {$blockwidth -1}] |> piper_blockjoin $charblock]] ;#building a repeated "|> command arg" list to evaluate as a pipeline. (from before textblock::join could take arbitrary num of blocks ) @@ -4657,7 +4657,7 @@ tcl::namespace::eval textblock { columns wide and size rows tall. (which on a terminal will show as a vertically oriented rectangle due to - cells being taller than their width) + cells being taller than their width) The characters used are 123456789ABCDEF @@ -4681,7 +4681,7 @@ tcl::namespace::eval textblock { The additional pseudo-color 'rainbow' is available. - " + " } proc testblock {args} { @@ -4700,14 +4700,14 @@ tcl::namespace::eval textblock { lappend rainbow_list {37 40} ;#white Black lappend rainbow_list {black Yellow} lappend rainbow_list red - lappend rainbow_list green + lappend rainbow_list green lappend rainbow_list yellow lappend rainbow_list blue lappend rainbow_list purple - lappend rainbow_list cyan + lappend rainbow_list cyan lappend rainbow_list {white Red} - #set rainbow_direction "horizontal" + #set rainbow_direction "horizontal" #set vpos [lsearch $colour vertical] #if {$vpos >= 0} { # set rainbow_direction vertical @@ -4719,11 +4719,11 @@ tcl::namespace::eval textblock { # set colour [lremove $colour $hpos] #} set direction [dict get $argd opts -direction] - + set chars [list {*}[punk::lib::range 1 9] A B C D E F] - set charsubset [lrange $chars 0 $size-1] + set charsubset [lrange $chars 0 $size-1] if {"noreset" in $colour} { set RST "" } else { @@ -4737,7 +4737,7 @@ tcl::namespace::eval textblock { for {set i 0} {$i <$size} {incr i} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $i]] $colour] set ansi [a+ {*}$colour2] - + set ansicode [punk::ansi::codetype::sgr_merge_list "" $ansi] lappend clist ${ansicode}$c$RST } @@ -4748,7 +4748,7 @@ tcl::namespace::eval textblock { } } elseif {"rainbow" in $colour} { #direction must be horizontal - set block "" + set block "" for {set r 0} {$r < $size} {incr r} { set colour2 [tcl::string::map [list rainbow [lindex $rainbow_list $r]] $colour] set ansi [a+ {*}$colour2] @@ -4763,7 +4763,7 @@ tcl::namespace::eval textblock { set block [tcl::string::trimright $block \n] return $block } else { - #row first - + #row first - set rows [list] foreach ch $charsubset { lappend rows [tcl::string::repeat $ch $size] @@ -4790,7 +4790,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4799,8 +4799,8 @@ tcl::namespace::eval textblock { if {[tcl::string::last \n $textblock] >= 0} { return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } - return [punk::char::ansifreestring_width $textblock] - } + return [punk::char::ansifreestring_width $textblock] + } #gather info about whether ragged (samewidth each line = false) and min width proc widthinfo {textblock} { #backspaces, vertical tabs ? @@ -4814,7 +4814,7 @@ tcl::namespace::eval textblock { } else { set tw 8 } - set textblock [textutil::tabify::untabify2 $textblock $tw] + set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[string length $textblock] > 1 && [punk::ansi::ta::detect $textblock]} { #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) @@ -4843,7 +4843,7 @@ tcl::namespace::eval textblock { if {[punk::ansi::ta::detect $tl]} { set tl [punk::ansi::ansistripraw $tl] } - return [punk::char::ansifreestring_width $tl] + return [punk::char::ansifreestring_width $tl] } #uses tcl's tcl::string::length on each line. Length will include chars in ansi codes etc - this is not a 'width' determining function. proc string_length_line_max {textblock} { @@ -4864,7 +4864,7 @@ tcl::namespace::eval textblock { proc height {textblock} { #This is the height as it will/would-be rendered - not the number of input lines purely in terms of le - #empty string still has height 1 (at least for left-right/right-left languages) + #empty string still has height 1 (at least for left-right/right-left languages) #vertical tab on a proper terminal should move directly down. #Whether or not the terminal in use actually does this - we need to calculate as if it does. (there might not even be a terminal) @@ -4894,7 +4894,7 @@ tcl::namespace::eval textblock { #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } else { - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -4933,7 +4933,7 @@ tcl::namespace::eval textblock { } } else { set num_le 0 - set width [punk::char::ansifreestring_width $textblock] + set width [punk::char::ansifreestring_width $textblock] } #set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map [list \n {} \v {}] $textblock]]}] ;#faster than splitting into single-char list #our concept of block-height is likely to be different to other line-counting mechanisms @@ -5010,14 +5010,14 @@ tcl::namespace::eval textblock { # -- --- --- --- --- --- --- --- --- --- set padchar [tcl::dict::get $opts -padchar] #if padchar width (screen width) > 1 - length calculations will not be correct - #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map + #we will allow tokens longer than 1 - as the caller may want to post-process on the token whilst preserving previous leading/trailing spaces, e.g with a tcl::string::map #The caller may also use ansi within the padchar - although it's unlikely to be efficient. # -- --- --- --- --- --- --- --- --- --- set known_whiches [list l left r right c center centre] set opt_which [tcl::string::tolower [tcl::dict::get $opts -which]] switch -- $opt_which { center - centre - c { - set which c + set which c } left - l { set which l @@ -5055,7 +5055,7 @@ tcl::namespace::eval textblock { set known_samewidth [tcl::dict::get $opts -known_samewidth] ;# if true - we have a known non-ragged block, if false - could be either. set datawidth "" if {$width eq "auto"} { - #for auto - we + #for auto - we if {$known_blockwidth eq ""} { if {$known_samewidth ne "" && $known_samewidth} { set datawidth [textblock::widthtopline $block] @@ -5077,7 +5077,7 @@ tcl::namespace::eval textblock { set datawidth [textblock::widthtopline $block] } else { set datawidth $known_blockwidth - } + } } #assert datawidth may still be empty string } @@ -5096,7 +5096,7 @@ tcl::namespace::eval textblock { #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) #we should use overtype with suitable replacement char (space?) for chopped double-wides if {!$pad_has_ansi} { - return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] } else { set base [tcl::string::repeat " " $width] return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] @@ -5105,7 +5105,7 @@ tcl::namespace::eval textblock { #review - tcl format can only pad with zeros or spaces? #experimental fallback to supposedly faster simpler 'format' but we still need to compensate for double-width or non-printing chars - and it won't work on strings with ansi SGR codes - #review - surprisingly, this doesn't seem to be a performance win + #review - surprisingly, this doesn't seem to be a performance win #No detectable diff on small blocks - slightly worse on large blocks # if {($padchar eq " " || $padchar eq "0") && ![punk::ansi::ta::detect $block]} { # #This will still be wrong for example with diacritics on terminals that don't collapse the space following a diacritic, and don't correctly report cursor position @@ -5144,7 +5144,7 @@ tcl::namespace::eval textblock { set parts [list $block] } - set line_chunks [list] + set line_chunks [list] set line_len 0 set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad foreach {pt ansi} $parts { @@ -5179,7 +5179,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5237,7 +5237,7 @@ tcl::namespace::eval textblock { } #don't let trailing empty ansi affect the line_chunks length if {$ansi ne ""} { - lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? + lappend line_chunks $ansi ;#don't update line_len - review - ansi codes with visible content? } } #pad last line @@ -5251,7 +5251,7 @@ tcl::namespace::eval textblock { set pad [tcl::dict::get $pad_cache $missing] } else { set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width - if {!$pad_has_ansi} { + if {!$pad_has_ansi} { set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] } else { set base [tcl::string::repeat " " $missing] @@ -5321,7 +5321,7 @@ tcl::namespace::eval textblock { if {$i == $i_last_code} { return [lappend out $str {*}[lrange $ansisplits $i end]] } - #code being empty can only occur when we have reached last pt + #code being empty can only occur when we have reached last pt #we have returned by then. lappend out $code incr i 2 @@ -5338,7 +5338,7 @@ tcl::namespace::eval textblock { set right1 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 1] set right2 [textblock::pad $block -known_blockwidth $width -width $padtowidth -padchar . -which right -within_ansi 2] - set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] + set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2] set t [textblock::list_as_table -columns 3 -return tableobject $testlist] $t configure_column 0 -headers [list "ansi"] @@ -5397,20 +5397,20 @@ tcl::namespace::eval textblock { set r3 [list "column\ncolours"] #1 - #test without table padding + #test without table padding #we need to textblock::join each item to ensure we don't get the table's own textblock::pad interfering #(basically a mechanism to add extra resets at start and end of each line) #dict for {b bdict} $blockinfo { # lappend r0 [textblock::join [tcl::dict::get $blockinfo $b left0]] [textblock::join [tcl::dict::get $blockinfo $b right0]] # lappend r1 [textblock::join [tcl::dict::get $blockinfo $b left1]] [textblock::join [tcl::dict::get $blockinfo $b right1]] - # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] + # lappend r2 [textblock::join [tcl::dict::get $blockinfo $b left2]] [textblock::join [tcl::dict::get $blockinfo $b right2]] #} #2 - the more useful one? tcl::dict::for {b bdict} $blockinfo { lappend r0 [tcl::dict::get $blockinfo $b left0] [tcl::dict::get $blockinfo $b right0] lappend r1 [tcl::dict::get $blockinfo $b left1] [tcl::dict::get $blockinfo $b right1] - lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] + lappend r2 [tcl::dict::get $blockinfo $b left2] [tcl::dict::get $blockinfo $b right2] lappend r3 "" "" } @@ -5486,7 +5486,7 @@ tcl::namespace::eval textblock { # >} .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| # >} punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::left $col1 $v][overtype::left $col2 $w]"}} {| - # >} punk::lib::list_as_lines -- } punk::lib::list_as_lines -- } .=lhs> punk::lib::lines_as_list -- {| # >} .= {lmap v $data w $data2 {val "[overtype::right $col1 $v][overtype::right $col2 $w]"}} {| - # >} punk::lib::list_as_lines } punk::lib::list_as_lines punk . lhs][a]\n\n[a+ rgb#FFFF00][>punk . rhs][a] set ipunks [overtype::renderspace -width [textblock::width $punks] [punk::ansi::enable_inverse]$punks] set testblock [textblock::testblock 15 rainbow] - set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] + set contents $ansi\n[textblock::join -- " " $table " " $punks " " $testblock " " $ipunks " " $punks] set framed [textblock::frame -checkargs 0 -type arc -title [a+ cyan]Compositing[a] -subtitle [a+ red]ANSI[a] -ansiborder [a+ web-orange] $contents] - } + } proc example {args} { @@ -5930,7 +5930,7 @@ tcl::namespace::eval textblock { set RST [a] set gr0 [punk::ansi::g0 abcdefghijklm\nnopqrstuvwxyz] set punks [textblock::join -- $pleft $pright] - set pleft_greenb $greenb$pleft$RST + set pleft_greenb $greenb$pleft$RST set pright_redb $redb$pright$RST set prightair_cyanb $cyanb$prightair$RST set cpunks [textblock::join -- $pleft_greenb $pright_redb] @@ -6064,7 +6064,7 @@ tcl::namespace::eval textblock { } } } - } + } variable framedef_cache [tcl::dict::create] proc framedef {args} { #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. @@ -6072,7 +6072,7 @@ tcl::namespace::eval textblock { #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. #the arc set can't even join to itself e.g with curved equivalents of T-like shapes - #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. variable framedef_cache set cache_key $args if {[tcl::dict::exists $framedef_cache $cache_key]} { @@ -6115,10 +6115,10 @@ tcl::namespace::eval textblock { if {![llength $rawglobs] || "all" in $rawglobs || "*" in $rawglobs} { set globs * } else { - set globs [list] + set globs [list] foreach g $rawglobs { switch -- $g { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc - hltj - hlbj - vllj - vlrj { lappend globs $g } @@ -6150,7 +6150,7 @@ tcl::namespace::eval textblock { } default { #must look like a glob search if not one of the above - if {[regexp {[*?\[\]]} $g]} { + if {[regexp {[*?\[\]]} $g]} { lappend globs $g } else { set bad_option 1 @@ -6174,7 +6174,7 @@ tcl::namespace::eval textblock { -help "-boxonly true restricts results to the corner,vertical and horizontal box elements It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj." - @values -min 1 + @values -min 1 frametype -choices "" -choiceprefix 0 -choicerestricted 0 -type dict\ -help "name from the predefined frametypes or an adhoc dictionary." memberglob -type globstring -optional 1 -multiple 1 -choiceprefix 0 -choicerestricted 0 -choices { @@ -6191,7 +6191,7 @@ tcl::namespace::eval textblock { set joins [tcl::dict::get $opts -joins] set boxonly [tcl::dict::get $opts -boxonly] - + #sorted order down left right up #1 x choose 4 #4 x choose 3 @@ -6204,7 +6204,7 @@ tcl::namespace::eval textblock { #e.g down-light, up-heavy set join_targets [tcl::dict::create left "" down "" right "" up ""] foreach jt $joins { - lassign [split $jt -] direction target + lassign [split $jt -] direction target if {$target ne ""} { tcl::dict::set join_targets $direction $target } @@ -6234,7 +6234,7 @@ tcl::namespace::eval textblock { #set brc [cd::brc] set brc [punk::ansi::g0 j] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6382,7 +6382,7 @@ tcl::namespace::eval textblock { set trc + set blc + set brc + - #horizontal and vertical bar joins + #horizontal and vertical bar joins #set hltj $hlt #set hlbj $hlb #set vllj $vll @@ -6392,7 +6392,7 @@ tcl::namespace::eval textblock { set hlbj + set vllj + set vlrj + - #our corners are all + already - so we won't do anything for directions or targets + #our corners are all + already - so we won't do anything for directions or targets } "light" { @@ -6408,7 +6408,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_lur] set brc [punk::char::charshort boxd_lul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6423,16 +6423,16 @@ tcl::namespace::eval textblock { #default empty targets to current box type 'light' foreach dir {down left right up} { set rawtarget [tcl::dict::get $join_targets $dir] - lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same + lassign [split $rawtarget _] target ;# treat variants light light_b lightc the same switch -- $target { "" - light { - set target$dir light + set target$dir light } ascii - altg - arc { - set target$dir light + set target$dir light } heavy { - set target$dir $target + set target$dir $target } default { set target$dir other @@ -6504,7 +6504,7 @@ tcl::namespace::eval textblock { other-light { set blc \u2534 ;#(btj) set tlc \u252c ;#(ttj) - #brc - default corner + #brc - default corner set vllj \u2524 ;# (rtj) } other-other { @@ -6546,7 +6546,7 @@ tcl::namespace::eval textblock { light-other { set blc \u251c ;# (ltj) #tlc - default corner - set brc \u2524 ;# boxd_lvl (rtj) + set brc \u2524 ;# boxd_lvl (rtj) set hlbj \u252c ;# (ttj) } light-heavy { @@ -6682,41 +6682,41 @@ tcl::namespace::eval textblock { light_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } light_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins light corner] tcl::dict::with arcframe {} ;#extract keys as vars } "heavy" { @@ -6731,7 +6731,7 @@ tcl::namespace::eval textblock { set trc [punk::char::charshort boxd_hdl] set blc [punk::char::charshort boxd_hur] set brc [punk::char::charshort boxd_hul] - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -6743,10 +6743,10 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - heavy { - set target$dir heavy + set target$dir heavy } light - ascii - altg - arc { - set target$dir light + set target$dir light } default { set target$dir other @@ -6773,12 +6773,12 @@ tcl::namespace::eval textblock { #2 switch -- $targetleft { light { - set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) + set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) set blc [punk::char::charshort boxd_llruh] ;#\u253a Left Light and Right Up Heavy (btj) set vllj \u2528 ;# left light (rtj) } heavy { - set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) + set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set blc [punk::char::charshort boxd_huhz] ;# (btj) set vllj \u252b ;#(rtj) } @@ -6833,7 +6833,7 @@ tcl::namespace::eval textblock { set vllj \u2528 ;# left light (rtj) } down-light-left-light { - set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) + set blc [punk::char::charshort boxd_ruhldl] ;#\u2544 right up heavy and left down light (fwj) set brc [punk::char::charshort boxd_dlluh] ;#\u2529 Down Light and left Up Heavy (rtj) (left must stay heavy) set tlc [punk::char::charshort boxd_llrdh] ;#\u2532 Left Light and Right Down Heavy (ttj) (we are in heavy - so down must stay heavy at tlc) set hlbj \u252F ;# down light (ttj) @@ -6954,41 +6954,41 @@ tcl::namespace::eval textblock { heavy_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } heavy_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins heavy corner] tcl::dict::with arcframe {} ;#extract keys as vars } "double" { @@ -7004,7 +7004,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_dur] ;#double up and right \U255A set brc [punk::char::charshort boxd_dul] ;#double up and left \U255D - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7163,7 +7163,7 @@ tcl::namespace::eval textblock { } left_right { #8 - + #from 2 #set tlc [punk::char::charshort boxd_hdhz] ;# (ttj) set tlc \U2566 ;# (ttj) @@ -7254,7 +7254,7 @@ tcl::namespace::eval textblock { set blc [punk::char::charshort boxd_laur] ;#light arc up and right \U2570 set brc [punk::char::charshort boxd_laul] ;#light arc up and left \U256F - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7266,7 +7266,7 @@ tcl::namespace::eval textblock { set target [tcl::dict::get $join_targets $dir] switch -- $target { "" - arc { - set target$dir self + set target$dir self } default { set target$dir other @@ -7282,7 +7282,7 @@ tcl::namespace::eval textblock { set blc \u251c ;# *light (ltj) #set blc \u29FD ;# misc math right-pointing curved angle bracket (ltj) - positioned too far left #set blc \u227b ;# math succeeds char. joins on right ok - gaps top and bottom - almost passable - #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal + #set blc \u22b1 ;#math succeeds under relation - looks 'ornate', sits too low to join horizontal #set brc \u2524 ;# *light(rtj) #set brc \u29FC ;# misc math left-pointing curved angle bracket (rtj) @@ -7354,41 +7354,41 @@ tcl::namespace::eval textblock { arc_b { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner vll vlr vllj vlrj] tcl::dict::with arcframe {} ;#extract keys as vars } arc_c { set hl " " set hlt " " - set hlb " " - set vl " " - set vll " " - set vlr " " - set tlc " " - set trc " " - set blc " " - set brc " " - #horizontal and vertical bar joins - set hltj " " - set hlbj " " - set vllj " " - set vlrj " " - - set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] + set hlb " " + set vl " " + set vll " " + set vlr " " + set tlc " " + set trc " " + set blc " " + set brc " " + #horizontal and vertical bar joins + set hltj " " + set hlbj " " + set vllj " " + set vlrj " " + + set arcframe [textblock::framedef -boxonly $boxonly -joins $joins arc corner] tcl::dict::with arcframe {} ;#extract keys as vars } block1 { @@ -7402,7 +7402,7 @@ tcl::namespace::eval textblock { set blc \u2594 ;# upper one eighth block set brc \u2594 ;# upper one eight block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7410,7 +7410,7 @@ tcl::namespace::eval textblock { } block2 { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7425,7 +7425,7 @@ tcl::namespace::eval textblock { set trc \U1fb7e ;#legacy block set blc \U1fb7c ;#legacy block set brc \U1fb7f ;#legacy block - + if {(![interp issafe])} { if {![catch {punk::console::check::has_bug_legacysymbolwidth} symbug] && $symbug} { #rather than totally fail on some mixed layout that happens to use block2 - just degrade it - but prevent alignment problems @@ -7437,7 +7437,7 @@ tcl::namespace::eval textblock { } } - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7445,7 +7445,7 @@ tcl::namespace::eval textblock { } block2hack { - #the resultant table will have text appear towards top of each box + #the resultant table will have text appear towards top of each box #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block @@ -7466,7 +7466,7 @@ tcl::namespace::eval textblock { # a 'privacy message' is 'probably' also not supported on the old terminal but is on newer ones #known exception - conemu on windows - displays junk for various ansi codes - (and slow terminal anyway) #this hack has a reasonable chance of working - #except that the punk overtype library does recognise PMs + #except that the punk overtype library does recognise PMs #A single backspace however is an unlikely and generally unuseful PM - so there is a corresponding hack in the renderline system to pass this PM through! #ugly - in that we don't know the application specifics of what the PM data contains and where it's going. set tlc \U1fb7d\x1b^\b\x1b\\ ;#legacy block @@ -7474,7 +7474,7 @@ tcl::namespace::eval textblock { set blc \U1fb7c\x1b^\b\x1b\\ ;#legacy block set brc \U1fb7f\x1b^\b\x1b\\ ;#legacy block - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7491,7 +7491,7 @@ tcl::namespace::eval textblock { set blc \u2599 set brc \u259f - #horizontal and vertical bar joins + #horizontal and vertical bar joins set hltj $hlt set hlbj $hlb set vllj $vll @@ -7526,9 +7526,9 @@ tcl::namespace::eval textblock { set $t [tcl::dict::get $custom_frame $t] } else { #set more explicit type to it's more general counterpart if it's missing - #e.g hlt -> hl - #e.g hltj -> hlt - set $t [set [string range $t 0 end-1]] + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] } } #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set @@ -7671,14 +7671,14 @@ tcl::namespace::eval textblock { tcl::dict::for {k v} $display_dict { lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? #set fwidth [textblock::width $frame] set frameinfo "$k used:$used " set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] if {$allinone_width >= $termwidth} { #split across 2 lines - append out "$frameinfo\n" + append out "$frameinfo\n" append out $frame \n } else { append out [textblock::join -- $frameinfo $frame]\n @@ -7707,7 +7707,7 @@ tcl::namespace::eval textblock { set FRAMETYPELABELS [dict remove $FRAMETYPELABELS block2hack] return $FRAMETYPELABELS } - #proc EG {} "return {[a+ brightblack]}" + #proc EG {} "return {[a+ brightblack]}" #make EG fetch from SGR cache so as to abide by colour off/on proc EG {} { a+ brightblack @@ -7729,7 +7729,7 @@ tcl::namespace::eval textblock { -checkargs -default 1 -type boolean\ -help "If true do extra argument checks and provide more comprehensive error info. - Set false for slight performance improvement." + Set false for slight performance improvement." -etabs -default 0\ -help "expanding tabs - experimental/unimplemented." -type -default light -choices {${[textblock::frametypes]}} -choicerestricted 0 -choicecolumns 8 -type dict\ @@ -7741,10 +7741,10 @@ tcl::namespace::eval textblock { passing an empty string will result in no box, but title/subtitle will still appear if supplied. ${[textblock::EG]}e.g: -frame -boxlimits {} -title things [a+ red White]my\\ncontent${[textblock::RST]}" -boxmap -default {} -type dict - -joins -default {} -type list + -joins -default {} -type list -title -default "" -type string -regexprefail {\n}\ -help "Frame title placed on topbar - no newlines. - May contain ANSI - no trailing reset required. + May contain ANSI - no trailing reset required. ${[textblock::EG]}e.g 1: frame -title My[a+ green]Green[a]Thing e.g 2: frame -title [a+ red underline]MyThing${[textblock::RST]}" -titlealign -default "centre" -choices {left centre right} @@ -7778,7 +7778,7 @@ tcl::namespace::eval textblock { -help "Show ANSI control characters within frame contents. (Control Representation Mode) Frame width doesn't adapt and content may be truncated - so -width may need to be manually set to display more." + so -width may need to be manually set to display more." @values -min 0 -max 1 contents -default "" -type string\ @@ -7793,7 +7793,7 @@ tcl::namespace::eval textblock { # #consider if we can use -sticky nsew instead of -blockalign (as per Tk grid -sticky option) # This would require some sort of expand equivalent e.g for -sticky ew or -sticky ns - for which we have to decide a meaning for text.. e.g ansi padding? - #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand + #We are framing 'rendered' text - so we don't have access to for example an inner frame or table to tell it to expand #we could refactor as an object and provide a -return object option, then use stored -sticky data to influence how another object renders into it # - but we would need to maintain support for the rendered-string based operations too. proc frame {args} { @@ -7828,8 +7828,8 @@ tcl::namespace::eval textblock { # for ansi art - -pad 0 is likely to be preferable set has_contents 0 - set optlist $args ;#initial only - content will be removed - #no solo opts for frame + set optlist $args ;#initial only - content will be removed + #no solo opts for frame if {[llength $args] %2 == 0} { if {[lindex $args end-1] eq "--"} { set contents [lpop optlist end] @@ -7843,7 +7843,7 @@ tcl::namespace::eval textblock { set contents [lpop optlist end] set has_contents 1 } - + #todo args -justify left|centre|right (center) #todo -blockalignbias -textalignbias? #use -buildcache 1 with -usecache 0 for debugging cache issues so we can inspect using textblock::frame_cache @@ -7852,12 +7852,12 @@ tcl::namespace::eval textblock { foreach {k v} $optlist { set k2 [tcl::prefix::match -error "" $optnames $k] switch -- $k2 { - -etabs - -type - -boxlimits - -boxmap - -joins + -etabs - -type - -boxlimits - -boxmap - -join - -title - -titlealign - -subtitle - -subtitlealign - -width - -height - -ansiborder - -ansibase - -blockalign - -textalign - -ellipsis - -crm_mode - - -usecache - -buildcache - -pad + - -usecache - -buildcache - -pad - -checkargs { tcl::dict::set opts $k2 $v } @@ -7878,21 +7878,21 @@ tcl::namespace::eval textblock { set contents [dict get $argd values contents] } - # -- --- --- --- --- --- + # -- --- --- --- --- --- # cache relevant set opt_usecache [tcl::dict::get $opts -usecache] set opt_buildcache [tcl::dict::get $opts -buildcache] set usecache $opt_usecache ;#may need to override set opt_etabs [tcl::dict::get $opts -etabs] ;#affects contentwidth - needed before cache determination set opt_crm_mode [tcl::dict::get $opts -crm_mode] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_type [tcl::dict::get $opts -type] set opt_boxlimits [tcl::dict::get $opts -boxlimits] set opt_joins [tcl::dict::get $opts -joins] set opt_boxmap [tcl::dict::get $opts -boxmap] set buildcache $opt_buildcache set opt_pad [tcl::dict::get $opts -pad] - # -- --- --- --- --- --- + # -- --- --- --- --- --- set opt_title [tcl::dict::get $opts -title] set opt_subtitle [tcl::dict::get $opts -subtitle] set opt_width [tcl::dict::get $opts -width] @@ -7930,7 +7930,7 @@ tcl::namespace::eval textblock { ##e.g down-light, up-heavy #set join_targets [tcl::dict::create left "" down "" right "" up ""] #foreach jt $opt_joins { - # lassign [split $jt -] direction target + # lassign [split $jt -] direction target # if {$target ne ""} { # tcl::dict::set join_targets $direction $target # } @@ -8056,10 +8056,10 @@ tcl::namespace::eval textblock { set FSUB \uF2DD - #this occurs commonly in table building with colspans - review - if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { + #this occurs commonly in table building with colspans - review + if {($actual_contentwidth > $frame_inner_width) || ($actual_contentheight != $frame_inner_height)} { set usecache 0 - #set buildcache 0 ;#comment out for debug/analysis so we can see + #set buildcache 0 ;#comment out for debug/analysis so we can see #puts "--->> frame_inner_width:$frame_inner_width actual_contentwidth:$actual_contentwidth contents: '$contents'" set cache_key [a+ Web-red web-white]$cache_key[a] } @@ -8069,7 +8069,7 @@ tcl::namespace::eval textblock { #we can still substitute with right length set cache_key [a+ Web-steelblue web-black]$cache_key[a] } else { - #actual_contentwidth is narrower than frame - check template's patternwidth + #actual_contentwidth is narrower than frame - check template's patternwidth if {[tcl::dict::exists $frame_cache $cache_key]} { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] } else { @@ -8096,7 +8096,7 @@ tcl::namespace::eval textblock { set cache_patternwidth [tcl::dict::get $frame_cache $cache_key patternwidth] set template [tcl::dict::get $frame_cache $cache_key frame] set used [tcl::dict::get $frame_cache $cache_key used] - tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record + tcl::dict::set frame_cache $cache_key used [expr {$used+1}] ;#update existing record set is_cached 1 } @@ -8107,7 +8107,7 @@ tcl::namespace::eval textblock { # -- --- --- --- --- set is_joins_ok 1 foreach v $opt_joins { - lassign [split $v -] direction target + lassign [split $v -] direction target switch -- $direction { left - right - up - down {} default { @@ -8126,7 +8126,7 @@ tcl::namespace::eval textblock { if {!$is_joins_ok} { error "frame option -joins '$opt_joins' must contain only values from the set: left,right,up,down with targets heavy,light,ascii,altg,arc,double,block,block1,custom e.g down-light" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- set is_boxmap_ok 1 tcl::dict::for {boxelement subst} $opt_boxmap { switch -- $boxelement { @@ -8139,9 +8139,9 @@ tcl::namespace::eval textblock { } } if {!$is_boxmap_ok} { - error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" + error "frame option -boxmap '$opt_boxmap' must contain only keys from the set: hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc,hltj,hlbj,vllj,vlrj" } - # -- --- --- --- --- --- + # -- --- --- --- --- --- #these are all valid commands for overtype:: switch -- $opt_textalign { left - right - centre - center {} @@ -8149,7 +8149,7 @@ tcl::namespace::eval textblock { error "frame option -textalign must be left|right|centre|center - received: $opt_textalign" } } - # -- --- --- --- --- --- + # -- --- --- --- --- --- switch -- $opt_blockalign { left - right - centre - center {} default { @@ -8217,7 +8217,7 @@ tcl::namespace::eval textblock { switch -- $frameset { custom { #REVIEW - textblock::table assumes that at least the vl elements are 1-wide - #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though + #generally supporting wider or taller custom frame elements would make for some interesting graphical possibilities though #if no ansi, these widths are reasonable to maintain in grapheme_width_cached indefinitely set vll_width [punk::ansi::printing_length $vll] set hlb_width [punk::ansi::printing_length $hlb] @@ -8235,8 +8235,8 @@ tcl::namespace::eval textblock { if {$opt_width eq ""} { #width wasn't specified - so user is expecting frame to adapt to title/contents #content shouldn't truncate because of extra wide frame - #review - punk::console::get_size ? wrapping? quite hard to support with colspans - set frame_inner_width $content_or_title_width + #review - punk::console::get_size ? wrapping? quite hard to support with colspans + set frame_inner_width $content_or_title_width set tbarwidth [expr {$content_or_title_width + 2 - $tlc_width - $trc_width - 2 + $vll_width + $vlr_width}] ;#+/2's for difference between border element widths and standard element single-width set bbarwidth [expr {$content_or_title_width + 2 - $blc_width - $brc_width - 2 + $vll_width + $vlr_width}] } else { @@ -8281,14 +8281,14 @@ tcl::namespace::eval textblock { set tbar [tcl::string::repeat $hlt $frame_inner_width] #set tbar [cd::groptim $tbar] set tbar [punk::ansi::groptim $tbar] - set bbar [tcl::string::repeat $hlb $frame_inner_width] + set bbar [tcl::string::repeat $hlb $frame_inner_width] #set bbar [cd::groptim $bbar] set bbar [punk::ansi::groptim $bbar] } default { set tbar [tcl::string::repeat $hlt $frame_inner_width] set bbar [tcl::string::repeat $hlb $frame_inner_width] - + } } @@ -8467,7 +8467,7 @@ tcl::namespace::eval textblock { #after overtype::block - our actual patternwidth may be less set cache_patternwidth [tcl::string::length [lindex [regexp -inline "\[^$FSUB]*(\[$FSUB]*).*" $cache_inner] 1]] - if {$leftborder && $rightborder} { + if {$leftborder && $rightborder} { #set bodyparts [list $lhs $inner $rhs] set cache_bodyparts [list $lhs $cache_inner $rhs] } else { @@ -8522,12 +8522,12 @@ tcl::namespace::eval textblock { } set template $fscached ;#end !$is_cached - } + } - #use the same mechanism to build the final frame - whether from cache or template + #use the same mechanism to build the final frame - whether from cache or template if {$actual_contentwidth == 0} { set fs [tcl::string::map [list $FSUB " "] $template] } else { @@ -8549,7 +8549,7 @@ tcl::namespace::eval textblock { #set cwidth [textblock::width $contents] set cwidth $actual_contentwidth if {$opt_pad} { - set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) + set paddedcontents [textblock::pad $contents -known_blockwidth $cwidth -which $pad -within_ansi 1] ;#autowidth to width of content (should match cache_patternwidth) set paddedwidth [textblock::widthtopline $paddedcontents] #review - horizontal truncation if {$paddedwidth > $cache_patternwidth} { @@ -8590,7 +8590,7 @@ tcl::namespace::eval textblock { if {$is_cached} { - return $fs + return $fs } else { if {$buildcache} { tcl::dict::set frame_cache $cache_key [list frame $template used 0 patternwidth $cache_patternwidth] @@ -8621,9 +8621,9 @@ tcl::namespace::eval textblock { set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] #set fit_size [punk::lib::greatestOddFactor $size] - set fit_size $size + set fit_size $size if {$opt_max_cross_size == 0} { - set max_cross_size $fit_size + set max_cross_size $fit_size } else { #todo - only allow divisors #set testsize [expr {min($fit_size,$opt_max_cross_size)}] @@ -8651,7 +8651,7 @@ tcl::namespace::eval textblock { set onecross "" set crossrows [list] set armsize [expr {int(floor($max_cross_size /2))}] - set row [lrepeat $max_cross_size " "] + set row [lrepeat $max_cross_size " "] #toparm for {set i 0} {$i < $armsize} {incr i} { set r $row @@ -8692,7 +8692,7 @@ tcl::namespace::eval textblock { return $out } - #Test we can join two coloured blocks + #Test we can join two coloured blocks proc test_colour {} { set b1 [a red]1\n2\n3[a] set b2 [a green]a\nb\nc[a] @@ -8716,10 +8716,10 @@ interp alias {} piper_blockjoin {} ::textblock::piper::join # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide textblock [tcl::namespace::eval textblock { variable version - set version 0.1.3 + set version 0.1.3 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/winlibreoffice-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/winlibreoffice-0.1.0.tm index 44e9151f..3e36f26a 100644 --- a/src/vfs/_vfscommon.vfs/modules/winlibreoffice-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/winlibreoffice-0.1.0.tm @@ -28,15 +28,16 @@ if {"windows" eq $::tcl_platform(platform)} { puts stderr "Minimal functionality - only some utils may work" } } else { - puts stderr "Package requires twapi. No current equivalent on non-windows platform. Try tcluno http://sf.net/projets/tcluno " + puts stderr "Package requires twapi. No current equivalent on non-windows platform. Try tcluno http://sf.net/projets/tcluno" puts stderr "Minimal functionality - only some utils may work" } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval winlibreoffice { + namespace export from_libre_date to_libre_date #--- - #todo: investigate tcluno package http://sf.net/projects/tcluno + #todo: investigate tcluno package http://sf.net/projects/tcluno #CPlusPlus - platforms? #--- # @@ -48,10 +49,10 @@ namespace eval winlibreoffice { #sometimes a com object may support $obj -print #see also - # $obj -destroy + # $obj -destroy # $obj Quit # $collection -iterate ?options? varname script - + variable uno "" ;# service manager object variable psm "" ;# process service manager @@ -91,7 +92,7 @@ namespace eval winlibreoffice { return $fpath } - # + # proc convertFromUrl {fileuri} { if {[string match "file:/*" $fileuri]} { set finfo [uri::split $fileuri] @@ -100,7 +101,7 @@ namespace eval winlibreoffice { return "//${host}${path}" } else { #the leading slash in path indicates a local path and we strip on windows - set p [dict get $finfo path] + set p [dict get $finfo path] if {[string index $p 0] eq "/"} { set p [string range $p 1 end] } @@ -111,12 +112,12 @@ namespace eval winlibreoffice { #?? review - how are file uris to other hosts handled? error "convertFromUrl doesn't handle non-local file uris on this platform" } else { - return [dict get $finfo path] + return [dict get $finfo path] } } } - } + } # -- --- --- --- # custom functions @@ -127,7 +128,7 @@ namespace eval winlibreoffice { #$dt setName odk_officedev_desk #$dt getName return $dt - } + } proc blankdoc {{type scalc}} { set known_types [list scalc swriter simpress sdraw smath] @@ -139,7 +140,7 @@ namespace eval winlibreoffice { puts "doc title: [$doc Title]" #title can be set with [$doc settitle "titletext"] return $doc - } + } proc file_open_dialog {{title "pick a libreoffice file"}} { set filepicker [createUnoService "com.sun.star.ui.dialogs.FilePicker"] @@ -175,7 +176,7 @@ namespace eval winlibreoffice { $cell setValue $value } proc calccell_setPropertyValue {cell propset} { - $cell setPropertyValue {*}$propset + $cell setPropertyValue {*}$propset #e.g "NumberFormat" 49 # YYYY-MM-DD @@ -192,7 +193,7 @@ namespace eval winlibreoffice { set dec [punk::lib::hex2dec $rgb] $cell setPropertyValue "CharColor" [expr {$dec}] } - + #cell charFontName @@ -201,7 +202,7 @@ namespace eval winlibreoffice { #https://api.libreoffice.org/docs/idl/ref/FontWeight_8idl.html # values are listed with 6 DPs - but one seems to work # only setting to normal and bold seem to result in a value (regular & bold) in the format->font style dialog for the cell. - #DONTKNOW 0.0 + #DONTKNOW 0.0 #THIN 50.0 #ULTRALIGHT 60.0 #LIGHT 75.0 @@ -212,31 +213,133 @@ namespace eval winlibreoffice { #ULTRABOLD 175.0 #BLACK 200.0 + lappend PUNKARGS [list { + @id -id ::winlibreoffice::to_libre_date + @cmd -name winlibreoffice::to_libre_date -help\ + "Return an internal Libre Office date/time floating point + number representing the number of days between 1899-12-30 + and the supplied time. + + e.g + % to_libre_date 2025-02-28T060000 + 45716.25 + % to_libre_date 2025-01-01T060101 + 45658.250706018516 + " + @opts + -timezone -default "" -help\ + "If unspecified, the timezone will be the + current time zone on the system" + @values -min 1 -max 1 + time -type string -help\ + "A unix timestamp as output by 'clock seconds' + or a text timestamp such as 2025-01-03T000000 + parseable by 'clock scan'" + }] + + proc to_libre_date {args} { + package require punk::args + set argd [punk::args::parse $args withid ::winlibreoffice::to_libre_date] + lassign [dict values $argd] leaders opts values received + + set tz [dict get $opts -timezone] + set time [dict get $values time] + if {![string is integer -strict $time]} { + set ts [clock scan $time -timezone $tz] + } else { + set ts $time + } - - #a hack - #return libreoffice date in days since 1899.. - proc date_from_clockseconds_approx {cs} { variable datebase - set tbase [clock scan $datebase] + set tbase [clock scan $datebase -timezone $tz] package require punk::timeinterval - set diff [punk::timeinterval::difference $tbase $cs] + set info [punk::timeinterval::difference -maxunit days -timezone $tz $tbase $ts] + lassign [dict values $info] _Y _m days h m s - set Y [dict get $diff years] - set M [dict get $diff months] - set D [dict get $diff days] - set yeardays [expr 365.25 * $Y] - set monthdays [expr 30.437 * $M] + return [expr {$days + ((($h *3600) + ($m * 60) + $s)/86400.0)}] + } + + lappend PUNKARGS [list { + @id -id ::winlibreoffice::from_libre_date + @cmd -name winlibreoffice::from_libre_date -help\ + "Convert an internal Libre Office date floating point value + representing the number of days since 1899-12-30 to a format + understood by Tcl such as 'clock seconds', 'clock milliseconds' + as specified in the -format option. + " + @opts + -format -default "clockseconds" -choices {clockseconds clockmillis ISO8601} -choicerestricted 0 -help\ + "Aside from the special values listed -format accepts a format string + as accepted by the Tcl 'clock format' command's -format option." + -timezone -default "" -help\ + "If unspecified, the timezone will be the + current time zone on the system" + @values -min 1 -max 1 + libredatetime -type float -help\ + "Floating point number representing the number of + days since 1899-12-30." + }] + #review - we don't expect sci notation for any float values here + #but we could easily get them.. e.g 0.000000001 * 86400.0 => 8.64e-5 + #todo - clockmicros ? + proc from_libre_date {args} { + package require punk::args + set argd [punk::args::parse $args withid ::winlibreoffice::from_libre_date] + lassign [dict values $argd] leaders opts values received + set format [dict get $opts -format] + set tz [dict get $opts -timezone] + set libredatetime [dict get $values libredatetime] - #yes.. this is horrible.. just a test really - but gets in the ballpark. - return [expr int($yeardays + $monthdays + $D)] + variable datebase + set tbase [clock scan $datebase -timezone $tz] + set intdays [expr {int($libredatetime)}] + set fracdays [lindex [split $libredatetime .] 1] + if {$fracdays ne ""} { + set fracdays "0.$fracdays" + set floatsecs [expr {$fracdays * 86400.0}] ;#assuming not a leap-second day + if {$format eq "clockmillis"} { + set wholesecs [expr {int($floatsecs)}] + set msfrac [lindex [split $floatsecs .] 1] + if {$msfrac ne ""} { + set msfrac "0.$msfrac" ;#could also be something like 0.64e-5 which should still work + set ms [expr {round(1000 * $msfrac)}] + if {$ms == 1000} { + set ms 0 + incr wholesecs + } + } else { + set ms 0 + } + } else { + set wholesecs [expr {round($floatsecs)}] + set ms 0 + } + } else { + set wholesecs 0 + set ms 0 + } + + set cs [clock add $tbase +$intdays days +$wholesecs seconds -timezone $tz] + switch -- $format { + clockseconds { + return $cs + } + clockmillis { + return [expr {($cs * 1000) + $ms}] + } + ISO8601 { + set format "%Y%m%dT%H%M%S" + } + } + return [clock format $cs -format $format] } + #time is represented on a scale of 0 to 1 6:00am = 0.25 (24/4) - - proc date_from_clockseconds {cs} { - puts stderr "unimplemented" + #return libreoffice date as a floating point number of days since 1899.. (1899-12-30) + proc to_libre_date_from_clockseconds_gmt {cs} { + return [expr {($cs/86400.0) + 25569}] } #see also: https://wiki.tcl-lang.org/page/Tcom+examples+for+Microsoft+Outlook @@ -265,19 +368,21 @@ namespace eval winlibreoffice { - - - - - - - +# ----------------------------------------------------------------------------- +# 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 ::winlibreoffice +} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready +## Ready package provide winlibreoffice [namespace eval winlibreoffice { variable version - set version 0.1.0 + set version 0.1.0 }] return diff --git a/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm b/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm index 080e7da9..1983211c 100644 Binary files a/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm and b/src/vfs/_vfscommon.vfs/modules/zipper-0.12.tm differ