diff --git a/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm b/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm index 5d5dbe3d..d3138501 100644 --- a/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm +++ b/src/modules/#modpod-zipper-999999.0a1.0/zipper-999999.0a1.0.tm @@ -10,7 +10,7 @@ namespace eval zipper { variable base variable toc } - + #if we initialize before writing anything to fd - our base is the file base # - ie we get an 'internal preamble' #if instead, we write data to fd before initialize, our base is the start of the archive-data. @@ -22,7 +22,7 @@ namespace eval zipper { # #It seems to be ok either way for reading - but some tools cannot write to file based offset if there is prefix data #(e.g file.kit with offset adjusted with something like zip -A which makes the preamble internal to the zip) - # and some cannot write to archive-based offset if there is prefix data ! + # and some cannot write to archive-based offset if there is prefix data ! #(e.g file.kit with preamble prepended and offsets not adjusted = external preamble) # #Some tools may auto-adjust to file-based offset when adding entries (e.g pkzip if extension is .zip) @@ -31,8 +31,8 @@ namespace eval zipper { set v::fd $fd set v::base [tell $fd] set v::toc {} - #fconfigure $fd -translation binary -encoding binary - fconfigure $fd -translation binary -encoding iso8859-1 + #chan configure $fd -translation binary -encoding binary + chan configure $fd -translation binary -encoding iso8859-1 } proc emit {s} { @@ -83,7 +83,7 @@ namespace eval zipper { #lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ # $flag $type $time $date $crc $csize $fsize $fnlen \ # {0 0 0 0} 128 [tell $v::fd]]$name" - #build the CDR file header - but we don't add it here + #build the CDR file header - but we don't add it here set do_extended_timestamp 1 if {!$do_extended_timestamp} { lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ @@ -100,7 +100,7 @@ namespace eval zipper { # (ModTime) Long time of last modification (UTC/GMT) # --- # - Tsize = 9 - 4 = 5 - set extended_timestamp [binary format a2sci UT 5 0 $unixmtime] + set extended_timestamp [binary format a2sci UT 5 0 $unixmtime] append extra $extended_timestamp # --- @@ -127,13 +127,13 @@ namespace eval zipper { set fsize 0 set csize 0 set fnlen [string length $name] - + set crc 0 - + lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ $flag $type $time $date $crc $csize $fsize $fnlen \ {0 0 0 0} 128 [tell $v::fd]]$name" - + emit [binary format a2c4ssssiiiss PK {3 4 20 0} \ $flag $type $time $date $crc $csize $fsize $fnlen 0] emit $name @@ -150,7 +150,7 @@ namespace eval zipper { set len [expr {$cd_end_pos - $cd_start_pos}] #incr pos -$v::base - set cdr_offset_pos [expr $cd_start_pos -$v::base] ;#review + set cdr_offset_pos [expr {$cd_start_pos -$v::base}] ;#review #EOCD signature PK\5\6 = 0x06054b50 emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $cdr_offset_pos 0] @@ -178,7 +178,7 @@ if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} { if {[file isfile $f]} { regsub {^\./} $f {} f set fd [open $f] - fconfigure $fd -translation binary -encoding binary + chan configure $fd -translation binary -encoding binary zipper::addentry $f [read $fd] [file mtime $f] close $fd } elseif {[file isdir $f]} { diff --git a/src/modules/patternpunk-1.1.tm b/src/modules/patternpunk-1.1.tm index 42bd91e6..cf73c712 100644 --- a/src/modules/patternpunk-1.1.tm +++ b/src/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/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index d43529f1..11d247a7 100644 --- a/src/modules/punk-0.1.tm +++ b/src/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}]} { @@ -1586,7 +1586,7 @@ namespace eval punk { 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]} @@ -1598,7 +1598,7 @@ namespace eval punk { 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]} @@ -1641,7 +1641,7 @@ namespace eval punk { 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 @@ -1653,7 +1653,7 @@ namespace eval punk { 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 @@ -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,27 +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 - #tclint-disable-next-line + 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]] } @@ -5396,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} @@ -5421,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]} { @@ -5453,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 @@ -5534,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 @@ -5560,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: @@ -5575,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]} { @@ -5590,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 @@ -5615,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] @@ -5634,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] @@ -5673,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] @@ -5685,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 @@ -5778,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] @@ -5790,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]} { @@ -5799,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] @@ -5850,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]] } } @@ -5871,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] } @@ -5881,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] @@ -5919,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] @@ -5935,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. @@ -5994,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]}}] @@ -6007,7 +6012,7 @@ namespace eval punk { } proc path {{glob *}} { set pipe [punk::path_list_pipe $glob] - {*}$pipe |> list_as_lines + {*}$pipe |> list_as_lines } #------------------------------------------------------------------- @@ -6050,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} { @@ -6068,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] @@ -6078,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"}] @@ -6087,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 { @@ -6101,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 } @@ -6163,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 @@ -6267,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 @@ -6303,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 { @@ -6343,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. @@ -6399,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" @@ -6499,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. # @@ -6588,7 +6593,7 @@ namespace eval punk { } #group_numlist ? preserve representation of numbers rather than use string comparison? - + # - group_string #.= punk::group_string "aabcccdefff" @@ -6673,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] @@ -6689,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] @@ -6793,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] @@ -6844,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 {} { @@ -6857,7 +6862,7 @@ namespace eval punk { lappend comparedlines $ln } else { incr fpurepunctlines - } + } } } if {$opt_largest > 0} { @@ -6930,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 @@ -6941,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 @@ -6970,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" @@ -6984,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" @@ -7009,7 +7014,7 @@ namespace eval punk { proc dictline {d} { puts stderr "unimplemented" set lines [list] - + return $lines } @@ -7057,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 @@ -7073,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 @@ -7091,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)" @@ -7108,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\ @@ -7138,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 @@ -7189,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] } @@ -7235,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 @@ -7247,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] } @@ -7330,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 @@ -7381,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. @@ -7397,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)" } @@ -7416,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)" } @@ -7433,7 +7438,7 @@ 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] @@ -7561,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] } @@ -7571,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 } } @@ -7616,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 @@ -7653,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 @@ -7703,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 @@ -7730,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 @@ -7738,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} { @@ -7779,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]} { @@ -7804,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/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index 6f30d962..1f335109 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::aliascore 0 999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 0a2b0457..af1c6e09 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -19,21 +19,21 @@ #[manpage_begin punkshell_module_punk::ansi 0 999999.0a1.0] #[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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 81ff5dec..25524b2b 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::args 0 999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/args/tclcore-999999.0a1.0.tm b/src/modules/punk/args/tclcore-999999.0a1.0.tm index 64a86473..6141d7e7 100644 --- a/src/modules/punk/args/tclcore-999999.0a1.0.tm +++ b/src/modules/punk/args/tclcore-999999.0a1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::args::tclcore 0 999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/assertion-999999.0a1.0.tm b/src/modules/punk/assertion-999999.0a1.0.tm index bdaabf88..627546a9 100644 --- a/src/modules/punk/assertion-999999.0a1.0.tm +++ b/src/modules/punk/assertion-999999.0a1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::assertion 0 999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/basictelnet-999999.0a1.0.tm b/src/modules/punk/basictelnet-999999.0a1.0.tm index ee2b834e..6af02972 100644 --- a/src/modules/punk/basictelnet-999999.0a1.0.tm +++ b/src/modules/punk/basictelnet-999999.0a1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell::basictelnet 0 999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/cap-999999.0a1.0.tm b/src/modules/punk/cap-999999.0a1.0.tm index c6c7a3b7..92aab976 100644 --- a/src/modules/punk/cap-999999.0a1.0.tm +++ b/src/modules/punk/cap-999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 variable README.md [string map [list %pkg% $pkg %ver% $version] { # punk capabilities system ## pkg: %pkg% version: %ver% diff --git a/src/modules/punk/cap/handlers/caphandler-999999.0a1.0.tm b/src/modules/punk/cap/handlers/caphandler-999999.0a1.0.tm index 8fa45211..c3a6ecb8 100644 --- a/src/modules/punk/cap/handlers/caphandler-999999.0a1.0.tm +++ b/src/modules/punk/cap/handlers/caphandler-999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return \ No newline at end of file diff --git a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm b/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm index 45e16713..9707d631 100644 --- a/src/modules/punk/cap/handlers/templates-999999.0a1.0.tm +++ b/src/modules/punk/cap/handlers/templates-999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return \ No newline at end of file diff --git a/src/modules/punk/char-999999.0a1.0.tm b/src/modules/punk/char-999999.0a1.0.tm index 05e7875a..197a30a9 100644 --- a/src/modules/punk/char-999999.0a1.0.tm +++ b/src/modules/punk/char-999999.0a1.0.tm @@ -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 diff --git a/src/modules/punk/config-0.1.tm b/src/modules/punk/config-0.1.tm index fbce0905..ac70e97b 100644 --- a/src/modules/punk/config-0.1.tm +++ b/src/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/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index e0b822e8..63bd422e 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -783,7 +783,7 @@ namespace eval punk::console { 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/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index cc58ab3e..8dc990f6 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -9,7 +9,7 @@ # @@ Meta Begin # Application punk::fileline 999999.0a1.0 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -20,7 +20,7 @@ #[manpage_begin punkshell_module_punk::fileline 0 999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/icomm-999999.0a1.0.tm b/src/modules/punk/icomm-999999.0a1.0.tm index 7c5560d4..4cc10b9b 100644 --- a/src/modules/punk/icomm-999999.0a1.0.tm +++ b/src/modules/punk/icomm-999999.0a1.0.tm @@ -875,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 } } @@ -935,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 "" } @@ -1089,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 } @@ -1111,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 @@ -1143,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] @@ -1215,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 -- @@ -1324,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. # @@ -1343,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 } @@ -1995,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 diff --git a/src/modules/punk/imap4-999999.0a1.0.tm b/src/modules/punk/imap4-999999.0a1.0.tm index 5952717a..cbcfe26f 100644 --- a/src/modules/punk/imap4-999999.0a1.0.tm +++ b/src/modules/punk/imap4-999999.0a1.0.tm @@ -234,7 +234,7 @@ tcl::namespace::eval punk::imap4::system { 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] @@ -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 @@ -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'" } @@ -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 { @@ -3260,7 +3260,7 @@ tcl::namespace::eval punk::imap4 { lappend PUNKARGS [list { @id -id "(package)punk::imap4" @package -name "punk::imap4" -help\ - "Package + "Package Description" }] diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index a22fc051..aaeddcce 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -10,7 +10,7 @@ # @@ Meta Begin # Application punk::lib 999999.0a1.0 # Meta platform tcl -# Meta license BSD +# Meta license BSD # @@ Meta End @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::lib 0 999999.0a1.0] #[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 @@ -3969,9 +3969,9 @@ tcl::namespace::eval punk::lib::test { #*** !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] @@ -3979,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} { @@ -3992,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! @@ -4005,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) @@ -4074,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 { @@ -4082,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 } } @@ -4093,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 } } @@ -4102,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 } } @@ -4113,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 @@ -4196,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 @@ -4225,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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/mix/base-0.1.tm b/src/modules/punk/mix/base-0.1.tm index c5ec5551..69f2f5cb 100644 --- a/src/modules/punk/mix/base-0.1.tm +++ b/src/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/modules/punk/mix/cli-999999.0a1.0.tm b/src/modules/punk/mix/cli-999999.0a1.0.tm index 197821a9..137f509a 100644 --- a/src/modules/punk/mix/cli-999999.0a1.0.tm +++ b/src/modules/punk/mix/cli-999999.0a1.0.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::mix::cli 999999.0a1.0 +# Application punk::mix::cli 999999.0a1.0 # 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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/mix/templates-999999.0a1.0.tm b/src/modules/punk/mix/templates-999999.0a1.0.tm index 0f730818..a1d36631 100644 --- a/src/modules/punk/mix/templates-999999.0a1.0.tm +++ b/src/modules/punk/mix/templates-999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return \ No newline at end of file diff --git a/src/modules/punk/mix/util-999999.0a1.0.tm b/src/modules/punk/mix/util-999999.0a1.0.tm index b5f13c60..1eeb66f3 100644 --- a/src/modules/punk/mix/util-999999.0a1.0.tm +++ b/src/modules/punk/mix/util-999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/nav/fs-999999.0a1.0.tm b/src/modules/punk/nav/fs-999999.0a1.0.tm index 091c0347..ac63e613 100644 --- a/src/modules/punk/nav/fs-999999.0a1.0.tm +++ b/src/modules/punk/nav/fs-999999.0a1.0.tm @@ -21,7 +21,7 @@ #[manpage_begin punkshell_module_punk::nav::fs 0 999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/repl-999999.0a1.0.tm b/src/modules/punk/repl-999999.0a1.0.tm index baaac1ef..3da2b3c0 100644 --- a/src/modules/punk/repl-999999.0a1.0.tm +++ b/src/modules/punk/repl-999999.0a1.0.tm @@ -127,7 +127,7 @@ namespace eval punk::repl { 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 { @@ -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" @@ -1327,7 +1327,7 @@ 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 @@ -1542,14 +1542,14 @@ 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 {} + chan event $inputchan readable {} set reading 0 thread::send -async $::repl::codethread {set ::punk::repl::codethread::running 0} if {$::tcl_interactive} { @@ -1757,7 +1757,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config # #review # rputs stderr "->0byte read stdin" # if {[chan eof $inputchan]} { - # fileevent $inputchan readable {} + # chan event $inputchan readable {} # set reading 0 # #set running 0 # if {$::tcl_interactive} { @@ -1973,7 +1973,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config 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 { @@ -2185,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 #=============================================================================== @@ -2529,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] @@ -2578,7 +2578,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config } - #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]"} @@ -2590,7 +2590,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config 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 { diff --git a/src/modules/punk/repl/codethread-999999.0a1.0.tm b/src/modules/punk/repl/codethread-999999.0a1.0.tm index a85674f9..23f94eb5 100644 --- a/src/modules/punk/repl/codethread-999999.0a1.0.tm +++ b/src/modules/punk/repl/codethread-999999.0a1.0.tm @@ -21,11 +21,11 @@ #[manpage_begin punkshell_module_punk::repl::codethread 0 999999.0a1.0] #[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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/sshrun-999999.0a1.0.tm b/src/modules/punk/sshrun-999999.0a1.0.tm index ef3a700f..00d00923 100644 --- a/src/modules/punk/sshrun-999999.0a1.0.tm +++ b/src/modules/punk/sshrun-999999.0a1.0.tm @@ -8,7 +8,7 @@ # @@ Meta Begin # Application punk::sshrun 999999.0a1.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 999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return diff --git a/src/modules/punk/winrun-999999.0a1.0.tm b/src/modules/punk/winrun-999999.0a1.0.tm index 5d2ce870..40a8f27e 100644 --- a/src/modules/punk/winrun-999999.0a1.0.tm +++ b/src/modules/punk/winrun-999999.0a1.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 999999.0a1.0 + set version 999999.0a1.0 }] return \ No newline at end of file diff --git a/src/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-0.1.0.tm index db8a3db5..fbf9a4e4 100644 --- a/src/modules/punkcheck-0.1.0.tm +++ b/src/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/modules/shellrun-0.1.1.tm b/src/modules/shellrun-0.1.1.tm index ace56e9c..bb820f68 100644 --- a/src/modules/shellrun-0.1.1.tm +++ b/src/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/modules/shellthread-1.6.1.tm b/src/modules/shellthread-1.6.1.tm index c529f234..2fd4d4f1 100644 --- a/src/modules/shellthread-1.6.1.tm +++ b/src/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/modules/tcl9test-999999.0a1.0.tm b/src/modules/tcl9test-999999.0a1.0.tm index 92c32ca9..448beb02 100644 --- a/src/modules/tcl9test-999999.0a1.0.tm +++ b/src/modules/tcl9test-999999.0a1.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 999999.0a1.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 999999.0a1.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 999999.0a1.0 +# set version 999999.0a1.0 #}] #return diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 9c198427..4f29176e 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -19,7 +19,7 @@ #[manpage_begin punkshell_module_textblock 0 999999.0a1.0] #[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 999999.0a1.0 + set version 999999.0a1.0 }] return