# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt # module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # (C) 2024 # # @@ Meta Begin # Application punk::lib 0.1.1 # Meta platform tcl # Meta license BSD # @@ Meta End # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[manpage_begin punkshell_module_punk::lib 0 0.1.1] #[copyright "2024"] #[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] #[moddesc {punk library}] [comment {-- Description at end of page heading --}] #[require punk::lib] #[keywords module utility lib] #[description] #[para]This is a set of utility functions that are commonly used across punk modules or are just considered to be general-purpose functions. #[para]The base set includes string and math functions but has no specific theme # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Overview] #[para] overview of punk::lib #[subsection Concepts] #[para]The punk::lib modules should have no strong dependencies other than Tcl #[para]Dependendencies that only affect display or additional functionality may be included - but should fail gracefully if not present, and only when a function is called that uses one of these soft dependencies. #[para]This requirement for no strong dependencies, means that many utility functions that might otherwise seem worthy of inclusion here are not present. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[subsection dependencies] #[para] packages used by punk::lib #[list_begin itemized] package require Tcl 8.6- #*** !doctools #[item] [package {Tcl 8.6-}] # #package require frobz # #*** !doctools # #[item] [package {frobz}] #*** !doctools #[list_end] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section API] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::lib::class { #*** !doctools #[subsection {Namespace punk::lib::class}] #[para] class definitions if {[info commands [namespace current]::interface_sample1] eq ""} { #*** !doctools #[list_begin enumerated] # oo::class create interface_sample1 { # #*** !doctools # #[enum] CLASS [class interface_sample1] # #[list_begin definitions] # method test {arg1} { # #*** !doctools # #[call class::interface_sample1 [method test] [arg arg1]] # #[para] test method # puts "test: $arg1" # } # #*** !doctools # #[list_end] [comment {-- end definitions interface_sample1}] # } #*** !doctools #[list_end] [comment {--- end class enumeration ---}] } } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::lib { namespace export * #variable xyz #*** !doctools #[subsection {Namespace punk::lib}] #[para] Core API functions for punk::lib #[list_begin definitions] #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] # #[para]Description of sample1 # #[para] Arguments: # # [list_begin arguments] # # [arg_def tring p1] A description of string argument p1. # # [arg_def integer n] A description of integer argument n. # # [list_end] # return "ok" #} proc K {x y} {return $x} #*** !doctools #[call [fun K] [arg x] [arg y]] #[para]The K-combinator function - returns the first argument, x and discards y #[para]see [uri https://wiki.tcl-lang.org/page/K] #[para]It is used in cases where command-substitution at the calling-point performs some desired effect. proc hex2dec {args} { #*** !doctools #[call [fun hex2dec] [opt {option value...}] [arg list_largeHex]] #[para]Convert a list of (possibly large) unprefixed hex strings to their decimal values #[para]hex2dec accepts and ignores internal underscores in the same manner as Tcl 8.7+ numbers e.g hex2dec FF_FF returns 65535 #[para]Leading and trailing underscores are ignored as a matter of implementation convenience - but this shouldn't be relied upon. #[para]Leading or trailing whitespace in each list member is allowed e.g hex2dec " F" returns 15 #[para]Internal whitespace e.g "F F" is not permitted - but a completely empty element "" is allowed and will return 0 set list_largeHex [lindex $args end] set argopts [lrange $args 0 end-1] if {[llength $argopts]%2 !=0} { error "[namespace current]::hex2dec arguments prior to list_largeHex must be option/value pairs - received '$argopts'" } set defaults [dict create\ -validate 1\ -empty_as_hex "INVALID set -empty_as_hex to a hex string e.g FF if empty values should be replaced"\ ] set known_opts [dict keys $defaults] set fullopts [dict create] dict for {k v} $argopts { dict set fullopts [tcl::prefix match -message "options for hex2dec. Unexpected option" $known_opts $k] $v } set opts [dict merge $defaults $fullopts] # -- --- --- --- set opt_validate [dict get $opts -validate] set opt_empty [dict get $opts -empty_as_hex] # -- --- --- --- set list_largeHex [lmap h $list_largeHex[unset list_largeHex] {string map [list _ ""] [string trim $h]}] if {$opt_validate} { #Note appended F so that we accept list of empty strings as per the documentation if {![string is xdigit -strict [join $list_largeHex ""]F ]} { error "[namespace current]::hex2dec error: non-hex digits encountered after stripping underscores and leading/trailing whitespace for each element\n $list_largeHex" } } if {![string is xdigit -strict [string map [list _ ""] $opt_empty]]} { #mapping empty string to a value destroys any advantage of -scanonly #todo - document that -scanonly has 2 restrictions - each element must be valid hex and less than 7 chars long #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {0} : {[set v]}}] if {[lsearch $list_largeHex ""] >=0} { error "[namespace current]::hex2dec error: empty values in list cannot be mapped to non-hex $opt_empty" } } else { set opt_empty [string trim [string map [list _ ""] $opt_empty]] if {[set first_empty [lsearch $list_largeHex ""]] >= 0} { #set list_largeHex [lmap v $list_largeHex[set list_largeHex {}] {expr {$v eq ""} ? {$opt_empty} : {$v}}] set nonempty_head [lrange $list_largeHex 0 $first_empty-1] set list_largeHex [concat $nonempty_head [lmap v [lrange $list_largeHex $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] } } return [scan $list_largeHex [string repeat %llx [llength $list_largeHex]]] } proc dec2hex {args} { #*** !doctools #[call [fun dex2hex] [opt {option value...}] [arg list_decimals]] #[para]Convert a list of decimal integers to a list of hex values #[para] -width can be used to make each hex value at least int characters wide, with leading zeroes. #[para] -case upper|lower determines the case of the hex letters in the output set list_decimals [lindex $args end] set argopts [lrange $args 0 end-1] if {[llength $argopts]%2 !=0} { error "[namespace current]::dec2hex arguments prior to list_decimals must be option/value pairs - received '$argopts'" } set defaults [dict create\ -width 1\ -case upper\ -empty_as_decimal "INVALID set -empty_as_decimal to a number if empty values should be replaced"\ ] set known_opts [dict keys $defaults] set fullopts [dict create] dict for {k v} $argopts { dict set fullopts [tcl::prefix match -message "options for [namespace current]::dec2hex. Unexpected option" $known_opts $k] $v } set opts [dict merge $defaults $fullopts] # -- --- --- --- set opt_width [dict get $opts -width] set opt_case [dict get $opts -case] set opt_empty [dict get $opts -empty_as_decimal] # -- --- --- --- set resultlist [list] switch -- [string tolower $opt_case] { upper { set spec X } lower { set spec x } default { error "[namespace current]::dec2hex unknown value '$opt_case' for -case expected upper|lower" } } set fmt "%${opt_width}.${opt_width}ll${spec}" set list_decimals [lmap d $list_decimals[unset list_decimals] {string map [list _ ""] [string trim $d]}] if {![string is digit -strict [string map [list _ ""] $opt_empty]]} { if {[lsearch $list_decimals ""] >=0} { error "[namespace current]::dec2hex error: empty values in list cannot be mapped to non-decimal $opt_empty" } } else { set opt_empty [string map [list _ ""] $opt_empty] if {[set first_empty [lsearch $list_decimals ""]] >= 0} { set nonempty_head [lrange $list_decimals 0 $first_empty-1] set list_decimals [concat $nonempty_head [lmap v [lrange $list_decimals $first_empty end] {expr {$v eq ""} ? {$opt_empty} : {$v}}]] } } return [format [lrepeat [llength $list_decimals] $fmt] {*}$list_decimals] } proc log2 x "expr {log(\$x)/[expr log(2)]}" #*** !doctools #[call [fun log2] [arg x]] #[para]log base2 of x #[para]This uses a 'live' proc body - the divisor for the change of base is computed once at definition time #[para](courtesy of RS [uri https://wiki.tcl-lang.org/page/Additional+math+functions]) proc logbase {b x} { #*** !doctools #[call [fun logbase] [arg b] [arg x]] #[para]log base b of x #[para]This function uses expr's natural log and the change of base division. #[para]This means for example that we can get results like: logbase 10 1000 = 2.9999999999999996 #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 expr {log($x)/log($b)} } proc factors {x} { #*** !doctools #[call [fun factors] [arg x]] #[para]Return a sorted list of the positive factors of x where x > 0 #[para]For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. (including zero itself in this context)* #[para]This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors #[para]Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions #[para]See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers #[para]Comparisons were done with some numbers below 17 digits long #[para]For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. #[para]The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers #but has the disadvantage of being slower for 'small' numbers and using more memory. #[para]If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get there than computing the whole list, even for small values of x #[para]* Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py #[para] In other mathematical contexts zero may be considered not to divide anything. set factors [list 1] set j 2 set max [expr {sqrt($x)}] while {$j <= $max} { if {($x % $j) == 0} { lappend factors $j [expr {$x / $j}] } incr j } lappend factors $x return [lsort -unique -integer $factors] } proc oddFactors {x} { #*** !doctools #[call [fun oddFactors] [arg x]] #[para]Return a list of odd integer factors of x, sorted in ascending order set j 2 set max [expr {sqrt($x)}] set factors [list 1] while {$j <= $max} { if {$x % $j == 0} { set other [expr {$x / $j}] if {$other % 2 != 0} { if {$other ni $factors} { lappend factors $other } } if {$j % 2 != 0} { if {$j ni $factors} { lappend factors $j } } } incr j } return [lsort -integer -increasing $factors] } proc greatestFactorBelow {x} { #*** !doctools #[call [fun greatestFactorBelow] [arg x]] #[para]Return the largest factor of x excluding itself #[para]factor functions can be useful for console layout calculations #[para]See Tcllib math::numtheory for more extensive implementations if {$x % 2 == 0 || $x == 0} { return [expr {$x / 2}] } set j 3 set max [expr {sqrt($x)}] while {$j <= $max} { if {$x % $j == 0} { return [expr {$x / $j}] } incr j 2 } return 1 } proc greatestOddFactorBelow {x} { #*** !doctools #[call [fun greatestOddFactorBelow] [arg x]] #[para]Return the largest odd integer factor of x excluding x itself if {$x %2 == 0} { return [greatestOddFactor $x] } set j 3 #dumb brute force - time taken to compute is wildly variable on big numbers #todo - use a (memoized?) generator of primes to reduce the search space #tcllib math::numtheory has suitable functions - but do we want that dependency here? Testing shows brute-force often faster for small numbers. set god 1 set max [expr {sqrt($x)}] while { $j <= $max} { if {$x % $j == 0} { set other [expr {$x / $j}] if {$other % 2 == 0} { set god $j } else { set god [expr {$x / $j}] #lowest j - so other side must be highest break } } incr j 2 } return $god } proc greatestOddFactor {x} { #*** !doctools #[call [fun greatestOddFactor] [arg x]] #[para]Return the largest odd integer factor of x #[para]For an odd value of x - this will always return x if {$x % 2 != 0 || $x == 0} { return $x } set r [expr {$x / 2}] while {$r % 2 == 0} { set r [expr {$r / 2}] } return $r } proc gcd {n m} { #*** !doctools #[call [fun gcd] [arg n] [arg m]] #[para]Return the greatest common divisor of m and n #[para]Straight from Lars Hellström's math::numtheory library in Tcllib #[para]Graphical use: #[para]An a by b rectangle can be covered with square tiles of side-length c, #[para]only if c is a common divisor of a and b # # Apply Euclid's good old algorithm # if { $n > $m } { set t $n set n $m set m $t } while { $n > 0 } { set r [expr {$m % $n}] set m $n set n $r } return $m } proc lcm {n m} { #*** !doctools #[call [fun gcd] [arg n] [arg m]] #[para]Return the lowest common multiple of m and n #[para]Straight from Lars Hellström's math::numtheory library in Tcllib #[para] set gcd [gcd $n $m] return [expr {$n*$m/$gcd}] } proc commonDivisors {x y} { #*** !doctools #[call [fun commonDivisors] [arg x] [arg y]] #[para]Return a list of all the common factors of x and y #[para](equivalent to factors of their gcd) return [factors [gcd $x $y]] } #experimental only - there are better/faster ways proc sieve n { set primes [list] if {$n < 2} {return $primes} set nums [dict create] for {set i 2} {$i <= $n} {incr i} { dict set nums $i "" } set next 2 set limit [expr {sqrt($n)}] while {$next <= $limit} { for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i} lappend primes $next dict for {next -} $nums break } return [concat $primes [dict keys $nums]] } proc sieve2 n { set primes [list] if {$n < 2} {return $primes} set nums [dict create] for {set i 2} {$i <= $n} {incr i} { dict set nums $i "" } set next 2 set limit [expr {sqrt($n)}] while {$next <= $limit} { for {set i $next} {$i <= $n} {incr i $next} {dict unset nums $i} lappend primes $next #dict for {next -} $nums break set next [lindex $nums 0] } return [concat $primes [dict keys $nums]] } proc hasglobs {str} { #*** !doctools #[call [fun hasglobs] [arg str]] #[para]Return a boolean indicating whether str contains any of the glob characters: * ? [lb] [rb] #[para]hasglobs uses append to preserve Tcls internal representation for str - so it should help avoid shimmering in the few cases where this may matter. regexp {[*?\[\]]} [append obj2 $str {}] ;# int-rep preserving } proc trimzero {number} { #*** !doctools #[call [fun trimzero] [arg number]] #[para]Return number with left-hand-side zeros trimmed off - unless all zero #[para]If number is all zero - a single 0 is returned set trimmed [string trimleft $number 0] if {[string length $trimmed] == 0} { set trimmed 0 } return $trimmed } proc substring_count {str substring} { #*** !doctools #[call [fun substring_count] [arg str] [arg substring]] #[para]Search str and return number of occurrences of substring #faster than lsearch on split for str of a few K if {$substring eq ""} {return 0} set occurrences [expr {[string length $str]-[string length [string map [list $substring {}] $str]]}] return [expr {$occurrences / [string length $substring]}] } proc dict_merge_ordered {defaults main} { #*** !doctools #[call [fun dict_merge_ordered] [arg defaults] [arg main]] #[para]The standard dict merge accepts multiple dicts with values from dicts to the right (2nd argument) taking precedence. #[para]When merging with a dict of default values - this means that any default key/vals that weren't in the main dict appear in the output before the main data. #[para]This function merges the two dicts whilst maintaining the key order of main followed by defaults. #1st merge (inner merge) with wrong values taking precedence - but right key-order - then (outer merge) restore values return [dict merge [dict merge $main $defaults] $main] } proc askuser {question} { #*** !doctools #[call [fun askuser] [arg question]] #[para]A basic utility to read an answer from stdin #[para]The prompt is written to the terminal and then it waits for a user to type something #[para]stdin is temporarily configured to blocking and then put back in its original state in case it wasn't already so. #[para]If the terminal is using punk::console and is in raw mode - the terminal will temporarily be put in line mode. #[para](Generic terminal raw vs linemode detection not yet present) #[para]The user must hit enter to submit the response #[para]The return value is the string if any that was typed prior to hitting enter. #[para]The question argument can be manually colourised using the various punk::ansi funcitons #[example_begin] # set answer [lb]punk::lib::askuser "[lb]a+ green bold[rb]Do you want to proceed? (Y|N)[lb]a[rb]"[rb] # if {[lb]string match y* [lb]string tolower $answer[rb][rb]} { # puts "Proceeding" # } else { # puts "Cancelled by user" # } #[example_end] puts stdout $question flush stdout set stdin_state [fconfigure stdin] if {[catch { package require punk::console set console_raw [set ::punk::console::is_raw] } err_console]} { #assume normal line mode set console_raw 0 } try { fconfigure stdin -blocking 1 if {$console_raw} { punk::console::disableRaw set answer [gets stdin] punk::console::enableRaw } else { set answer [gets stdin] } } finally { fconfigure stdin -blocking [dict get $stdin_state -blocking] } return $answer } #like textutil::adjust::indent - but doesn't strip trailing lines, and doesn't implement skip parameter. proc indent {text {prefix " "}} { set result [list] foreach line [split $text \n] { if {[string trim $line] eq ""} { lappend result "" } else { lappend result $prefix[string trimright $line] } } return [join $result \n] } proc undent {text} { if {$text eq ""} { return "" } set lines [split $text \n] set nonblank [list] foreach ln $lines { if {[string trim $ln] eq ""} { continue } lappend nonblank $ln } set lcp [longestCommonPrefix $nonblank] if {$lcp eq ""} { return $text } regexp {^([\t ]*)} $lcp _m lcp if {$lcp eq ""} { return $text } set len [string length $lcp] set result [list] foreach ln $lines { if {[string trim $ln] eq ""} { lappend result "" } else { lappend result [string range $ln $len end] } } return [join $result \n] } #A version of textutil::string::longestCommonPrefixList proc longestCommonPrefix {items} { if {[llength $items] <= 1} { return [lindex $items 0] } set items [lsort $items[unset items]] set min [lindex $items 0] set max [lindex $items end] #if first and last of sorted list share a prefix - then all do (first and last of sorted list are the most different in the list) #(sort order nothing to do with length - e.g min may be longer than max) if {[string length $min] > [string length $max]} { set temp $min set min $max set max $temp } set n [string length $min] set prefix "" set i -1 while {[incr i] < $n && ([set c [string index $min $i]] eq [string index $max $i])} { append prefix $c } return $prefix } #test example of the technique - not necessarily particularly useful as a function, except maybe for brevity/clarity. todo - test if inlined version gives any perf advantage compared to a temp var proc swapnumvars {namea nameb} { upvar $namea a $nameb b set a [expr {$a ^ $b}] set b [expr {$a ^ $b}] set a [expr {$a ^ $b}] } #e.g linesort -decreasing $data proc linesort {args} { #*** !doctools #[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]] #[para]Sort lines in textblock #[para]Returns another textblock with lines sorted #[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique if {[llength $args] < 1} { error "linesort missing lines argument" } set lines [lindex $args end] set opts [lrange $args 0 end-1] #.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts list_as_lines [lsort {*}$opts [linelist $lines]] } proc list_as_lines {args} { #*** !doctools #[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]] #[para]This simply 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]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line. if {[set eop [lsearch $args --]] == [llength $args]-2} { #end-of-opts not really necessary - except for consistency with lines_as_list set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]] } if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} { set joinchar [lindex $args 1] set lines [lindex $args 2] } elseif {[llength $args] == 1} { set joinchar "\n" set lines [lindex $args 0] } else { error "list_as_lines usage: list_as_lines ?-joinchar ? " } return [join $lines $joinchar] } proc list_as_lines2 {args} { #eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible lassign [dict values [punk::lib::opts_values -minvalues 1 -maxvalues 1 { -joinchar -default \n } $args]] opts values return [join [dict get $values 0] [dict get $opts -joinchar]] } proc lines_as_list {args} { #*** !doctools #[call [fun lines_as_list] [opt {option value ...}] [arg text]] #[para]Returns a list of possibly trimmed lines depeding on options #[para]The concept of lines is raw lines from splitting on newline after crlf is mapped to lf #[para]- not console lines which may be entirely different due to control characters such as vertical tabs or ANSI movements #The underlying function linelist has the validation code which gives nicer usage errors. #we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error #..because we don't know what to say if there are odd numbers of args #we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work #e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway if {[lsearch $args "--"] == [llength $args]-2} { set opts [lrange $args 0 end-2] } else { set opts [lrange $args 0 end-1] } #set opts [dict merge {-block {}} $opts] set bposn [lsearch $opts -block] if {$bposn < 0} { lappend opts -block {} } set text [lindex $args end] tailcall linelist {*}$opts $text } #this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds proc lines_as_list2 {args} { #pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults #-anyopts 1 avoids having to know what to say if odd numbers of options passed etc #we don't have to decide what is an opt vs a value #even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block) lassign [dict values [punk::lib::opts_values -anyopts 1 { -block -default {} } $args]] opts valuedict tailcall linelist {*}$opts {*}[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 proc linelist {args} { set usage "linelist ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix text" if {[llength $args] == 0} { error "linelist missing textchunk argument usage:$usage" } set text [lindex $args end] set text [string map [list \r\n \n] $text] ;#review - option? set arglist [lrange $args 0 end-1] set defaults [dict create\ -block {trimhead1 trimtail1}\ -line {}\ -commandprefix ""\ -ansiresets 0\ ] dict for {o v} $arglist { switch -- $o { -block - -line - -commandprefix - -ansiresets {} default { error "linelist: Unrecognized option '$o' usage:$usage" } } } set opts [dict merge $defaults $arglist] # -- --- --- --- --- --- set opt_block [dict get $opts -block] if {[llength $opt_block]} { foreach bo $opt_block { switch -- $bo { trimhead - trimtail - triminner - trimall - trimhead1 - trimtail1 - collateempty {} default { set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty] error "linelist: unknown -block option value: $bo known values: $known_blockopts" } } } #normalize certain combos if {[set posn [lsearch $opt_block trimhead1]] >=0 && "trimhead" in $opt_block} { set opt_block [lreplace $opt_block $posn $posn] } if {[set posn [lsearch $opt_block trimtail1]] >=0 && "trimtail" in $opt_block} { set opt_block [lreplace $opt_block $posn $posn] } if {"trimall" in $opt_block} { #no other block options make sense in combination with this set opt_block [list "trimall"] } #TODO if {"triminner" in $opt_block } { error "linelist -block triminner not implemented - sorry" } } # -- --- --- --- --- --- set opt_line [dict get $opts -line] foreach lo $opt_line { switch -- $lo { trimline - trimleft - trimright {} default { set known_lineopts [list trimline trimleft trimright] error "linelist: unknown -line option value: $lo known values: $known_lineopts" } } } #normalize trimleft trimright combo if {"trimleft" in $opt_line && "trimright" in $opt_line} { set opt_line [list "trimline"] } # -- --- --- --- --- --- set opt_commandprefix [dict get $opts -commandprefix] # -- --- --- --- --- --- set opt_ansiresets [dict get $opts -ansiresets] # -- --- --- --- --- --- set linelist [list] set nlsplit [split $text \n] if {![llength $opt_line]} { set linelist $nlsplit #lappend linelist {*}$nlsplit } else { foreach ln $nlsplit { #already normalized trimleft+trimright to trimline if {"trimline" in $opt_line} { lappend linelist [string trim $ln] } elseif {"trimleft" in $opt_line} { lappend linelist [string trimleft $ln] } elseif {"trimright" in $opt_line} { lappend linelist [string trimright $ln] } } } if {"collateempty" in $opt_block} { set inputlist $linelist[set linelist [list]] set last "-" foreach input $inputlist { if {$input ne ""} { lappend linelist $input set last "-" } else { if {$last ne ""} { lappend linelist "" } set last "" } } } if {"trimall" in $opt_block} { set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""] } else { set start 0 if {"trimhead" in $opt_block} { set idx 0 set lastempty -1 foreach ln $linelist { if {[lindex $linelist $idx] ne ""} { break } else { set lastempty $idx } incr idx } if {$lastempty >=0} { set start [expr {$lastempty +1}] } } set linelist [lrange $linelist $start end] if {"trimtail" in $opt_block} { set revlinelist [lreverse $linelist][set linelist {}] set i 0 foreach ln $revlinelist { if {$ln ne ""} { set linelist [lreverse [lrange $revlinelist $i end]] break } incr i } } # --- --- set start 0 set end "end" if {"trimhead1" in $opt_block} { if {[lindex $linelist 0] eq ""} { set start 1 } } if {"trimtail1" in $opt_block} { if {[lindex $linelist end] eq ""} { set end "end-1" } } set linelist [lrange $linelist $start $end] } #review - we need to make sure ansiresets don't accumulate/grow on any line #Each resulting line should have a reset of some type at start and a pure-reset at end to stop #see if we can find an ST sequence that most terminals will not display for marking sections? if {$opt_ansiresets} { set RST [a] set replaycodes $RST ;#todo - default? set transformed [list] #shortcircuit common case of no ansi if {![punk::ansi::ta::detect $linelist]} { foreach ln $linelist { lappend transformed $RST$ln$RST } set linelist $transformed } else { #INLINE punk::ansi::codetype::is_sgr_reset #regexp {\x1b\[0*m$} $code set re_is_sgr_reset {\x1b\[0*m$} #INLINE punk::ansi::codetype::is_sgr #regexp {\033\[[0-9;:]*m$} $code set re_is_sgr {\x1b\[[0-9;:]*m$} foreach ln $linelist { #set is_replay_pure_reset [regexp {\x1b\[0*m$} $replaycodes] ;#only looks at tail code - but if tail is pure reset - any prefix is ignorable set ansisplits [punk::ansi::ta::split_codes_single $ln] if {[llength $ansisplits]<= 1} { #plaintext only - no ansi codes in line lappend transformed [string cat $replaycodes $ln $RST] #leave replaycodes as is for next line set nextreplay $replaycodes } else { set tail $RST set lastcode [lindex $ansisplits end-1] ;#may or may not be SGR if {[punk::ansi::codetype::is_sgr_reset $lastcode]} { if {[lindex $ansisplits end] eq ""} { #last plaintext is empty. So the line is already suffixed with a reset set tail "" set nextreplay $RST } else { #trailing text has been reset within line - but no tail reset present #we normalize by putting a tail reset on anyway set tail $RST set nextreplay $RST } } elseif {[lindex $ansisplits end] ne "" && [punk::ansi::codetype::has_sgr_leadingreset $lastcode]} { #No tail reset - and no need to examine whole line to determine stack that is in effect set tail $RST set nextreplay $lastcode } else { #last codeset doesn't reset from earlier codes or isn't SGR - so we have to look at whole line to determine codes in effect #last codeset doesn't end in a pure-reset #whether code was at very end or not - add a reset tail set tail $RST #determine effective replay for line set codestack [list start] foreach {pt code} $ansisplits { if {[punk::ansi::codetype::is_sgr_reset $code]} { set codestack [list] ;#different from 'start' marked - this means we've had a reset } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { set codestack [list $code] } else { if {[punk::ansi::codetype::is_sgr $code]} { #todo - proper test of each code - so we only take latest background/foreground etc. #requires handling codes with varying numbers of parameters. #basic simplification - remove straight dupes. set dup_posns [lsearch -all -exact $codestack $code] ;#!must use -exact as codes have square brackets which are interpreted as glob chars. set codestack [lremove $codestack {*}$dup_posns] lappend codestack $code } ;#else gx0 or other code - we don't want to stack it with SGR codes } } if {$codestack eq [list start]} { #No SGRs - may have been other codes set line_has_sgr 0 } else { #list is either empty or begins with start - empty means it had SGR reset - so it still invalidates current state of replaycodes set line_has_sgr 1 if {[lindex $codestack 0] eq "start"} { set codestack [lrange $codestack 1 end] } } #set newreplay [join $codestack ""] set newreplay [punk::ansi::codetype::sgr_merge_list {*}$codestack] if {$line_has_sgr && $newreplay ne $replaycodes} { #adjust if it doesn't already does a reset at start if {[punk::ansi::codetype::has_sgr_leadingreset $newreplay]} { set nextreplay $newreplay } else { set nextreplay $RST$newreplay } } else { set nextreplay $replaycodes } } if {[punk::ansi::codetype::has_sgr_leadingreset $ln]} { #no point attaching any replay lappend transformed [string cat $ln $tail] } else { lappend transformed [string cat $replaycodes $ln $tail] } } set replaycodes $nextreplay } set linelist $transformed } } if {[llength $opt_commandprefix]} { set transformed [list] foreach ln $linelist { lappend transformed [{*}$opt_commandprefix $ln] } set linelist $transformed } return $linelist } #maintenance - take over from punk::args - or put back in punk::args once fixed to support pipeline argument order #possible improvements - after the 1st call, replace the callsite in the calling proc with an inline script to process and validate the arguments as specified in optionspecs #This would require a tcl parser .. and probably lots of other work #It would also probably only be practical if there are no dynamic entries in the optionspecs. An option for opts_values to indicate the caller wants this optimisation would probably be best. #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. #only supports -flag val pairs, not solo options #If an option is supplied multiple times - only the last value is used. proc opts_values {args} { #*** !doctools #[call [fun opts_values] [opt {option value...}] [arg optionspecs] [arg rawargs] ] #[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values #[para]Returns a dict of the form: opts values #[para]ARGUMENTS: #[list_begin arguments] #[arg_def multiline-string optionspecs] #[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced #[para]'info complete' is used to determine if a record spans multiple lines due to multiline values #[para]Each optionspec line 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 #[arg_def list rawargs] #[para] This is a list of the arguments to parse. Usually it will be the \$args value from the containing proc #[list_end] #[para] #consider line-processing example below for we need info complete to determine record boundaries #punk::lib::opt_values { # -opt1 -default {} # -opt2 -default { # etc # } -multiple 1 #} $args #-- cannot be used to allow opts_values itself to accept rawargs as separate values - so it doesn't serve much purpose other than as an indicator of intention #For consistency we support it anyway. #we have to be careful with end-of-options flag -- #It may legitimately be the only value in the rawargs list (which is a bit odd - but possible) or it may occur immediately before optionspecs and rawargs #if there is more than one entry in rawargs - we won't find it anyway - so that's ok set eopts_posn [lsearch $args --] if {$eopts_posn == ([llength $args]-1)} { #sole argument in rawargs - not the one we're looking for set eopts_posn -1 } if {$eopts_posn >= 0} { set ov_opts [lrange $args 0 $eopts_posn-1] set ov_vals [lrange $args $eopts_posn+1 end] } else { set ov_opts [lrange $args 0 end-2] set ov_vals [lrange $args end-1 end] } if {[llength $ov_vals] < 2 || [llength $ov_opts] %2 != 0} { error "opts_args wrong # args: should be opts_values ?opt val?... optionspecs rawargs_as_list } set optionspecs [lindex $ov_vals 0] set optionspecs [string map [list \r\n \n] $optionspecs] set rawargs [lindex $ov_vals 1] set optspec_defaults [dict create\ -optional 1\ -allow_ansi 1\ -validate_without_ansi 0\ -strip_ansi 0\ -nocase 0\ ] set required_opts [list] set required_vals [list] set arg_info [dict create] set defaults_dict_opts [dict create] set defaults_dict_values [dict create] #first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end set value_names [list] set records [list] set linebuild "" foreach rawline [split $optionspecs \n] { set recordsofar [string cat $linebuild $rawline] if {![info complete $recordsofar]} { append linebuild [string trimleft $rawline] \n } else { lappend records [string cat $linebuild $rawline] set linebuild "" } } foreach ln $records { set trimln [string trim $ln] switch -- [string index $trimln 0] { "" - # {continue} } set argname [lindex $trimln 0] set argspecs [lrange $trimln 1 end] if {[llength $argspecs] %2 != 0} { error "punk::lib::opts_values - bad optionspecs line for argument '$argname' Remaining items on line must be in paired option-value format - received '$argspecs'" } if {[string match -* $argname]} { dict set argspecs -ARGTYPE option set is_opt 1 } else { dict set argspecs -ARGTYPE value lappend value_names $argname set is_opt 0 } dict for {spec specval} $argspecs { switch -- $spec { -default - -type - -range - -choices - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -ARGTYPE {} default { set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -ARGTYPE] error "punk::lib::opts_values - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" } } } set argspecs [dict merge $optspec_defaults $argspecs] dict set arg_info $argname $argspecs if {![dict get $argspecs -optional]} { if {$is_opt} { lappend required_opts $argname } else { lappend required_vals $argname } } if {[dict exists $arg_info $argname -default]} { if {$is_opt} { dict set defaults_dict_opts $argname [dict get $arg_info $argname -default] } else { dict set defaults_dict_values $argname [dict get $arg_info $argname -default] } } } #puts "--> [info frame -2] <--" set cmdinfo [dict get [info frame -2] cmd] #we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work #hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc #we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly) set caller [regexp -inline {\S+} $cmdinfo] #if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace" if {$caller eq "namespace"} { set caller "punk::lib::opts_values called from namespace" } # ------------------------------ if {$caller ne "punk::lib::opts_values"} { #1) check our caller's call to us - recursive version - perhaps more elegant to eat our own dogfood - but maybe too much overhead for a script-based args processor which is already quite heavy :/ #lassign [punk::lib::opts_values "-anyopts -default 0 -type integer\n -minvalues -default 0 -type integer\n -maxvalues -default -1 -type integer" $args] _o ownopts _v ownvalues #if {[dict size $ownvalues] != 2} { # error "punk::lib::opts_values expected: a multiline text block of option-specifications, a list of args and at most three option pairs -minvalues , -maxvalues , -anyopts true|false - got extra arguments: '$ownvalues'" #} #set opt_minvalues [dict get $ownopts -minvalues] #set opt_maxvalues [dict get $ownopts -maxvalues] #set opt_anyopts [dict get $ownopts -anyopts] #2) Quick and dirty - but we don't need much validation set defaults [dict create\ -minvalues 0\ -maxvalues -1\ -anyopts 0\ ] dict for {k v} $ov_opts { if {$k ni {-minvalues -maxvalues -anyopts}} { error "punk::lib::opts_values unrecognised option $k. Known values [dict keys $defaults]" } if {![string is integer -strict $v]} { error "punk::lib::opts_values argument $k must be of type integer" } } set ov_opts [dict merge $defaults $ov_opts] set opt_minvalues [dict get $ov_opts -minvalues] set opt_maxvalues [dict get $ov_opts -maxvalues] set opt_anyopts [dict get $ov_opts -anyopts] } else { #don't recurse ie don't check our own args if we called ourself set opt_minvalues 2 set opt_maxvalues 2 set opt_anyopts 0 } # ------------------------------ if {[set eopts [lsearch $rawargs "--"]] >= 0} { set values [lrange $rawargs $eopts+1 end] set arglist [lrange $rawargs 0 $eopts-1] } else { if {[lsearch $rawargs -*] >= 0} { #to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex set i 0 foreach {k v} $rawargs { if {![string match -* $k]} { break } if {$i+1 >= [llength $rawargs]} { #no value for last flag error "bad options for $caller. No value supplied for last option $k" } incr i 2 } set arglist [lrange $rawargs 0 $i-1] set values [lrange $rawargs $i end] } else { set arglist [list] set values $rawargs ;#no -flags detected } } #confirm any valnames before last don't have -multiple key foreach valname [lrange $value_names 0 end-1] { if {[dict exists $arg_info $valname -multiple ]} { error "bad key -multiple on argument spec for '$valname'. Only the last value argument specification can be marked -multiple" } } set values_dict [dict create] set validx 0 set in_multiple "" foreach valname $value_names val $values { if {$validx+1 > [llength $values]} { break } if {$valname ne ""} { if {[dict exists $arg_info $valname -multiple] && [dict get $arg_info $valname -multiple]} { dict lappend values_dict $valname $val set in_multiple $valname } else { dict set values_dict $valname $val } } else { if {$in_multiple ne ""} { dict lappend values_dict $in_multiple $val } else { dict set values_dict $validx $val } } incr validx } if {$opt_maxvalues == -1} { #only check min if {[llength $values] < $opt_minvalues} { error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues" } } else { if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} { if {$opt_minvalues == $opt_maxvalues} { error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues" } else { error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive" } } } #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 will 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 #For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true set argnamespresent [dict keys $arglist] foreach r $required_opts { if {$r ni $argspresent} { error "Required option missing for $caller. '$r' is marked with -optional false - so must be present in its full-length form" } } set valuenamespresent [dict keys $values_dict] foreach r $required_vals { if {$r ni $valuenamespresent} { error "Required value missing for $caller. '$r' is marked with -optional false - so must be present" } } if {!$opt_anyopts} { set checked_args [dict create] for {set i 0} {$i < [llength $arglist]} {incr i} { #allow this to error out with message indicating expected flags set val [lindex $arglist $i+1] set fullopt [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $arg_info] [lindex $arglist $i]] if {[dict exists $arg_info $fullopt -multiple] && [dict get $arg_info $fullopt -multiple]} { dict lappend checked_args $fullopt $val } else { dict set checked_args $fullopt $val } incr i ;#skip val } } else { #still need to use tcl::prefix match to normalize - but don't raise an error set checked_args [dict create] dict for {k v} $arglist { if {![catch {tcl::prefix::match [dict keys $arg_info] $k} fullopt]} { if {[dict exists $arg_info $fullopt -multiple] && [dict get $arg_info $fullopt -multiple]} { dict lappend checked_args $fullopt $v } else { dict set checked_args $fullopt $v } } else { #opt was unspecified dict set checked_args $k $v } } } set opts [dict merge $defaults_dict_opts $checked_args] #assertion - checked_args keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options set values [dict merge $defaults_dict_values $values_dict] #todo - allow defaults outside of choices/ranges #check types,ranges,choices set opts_and_values [concat $opts $values] set combined_defaults [concat $defaults_dict_values $defaults_dict_opts] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash dict for {o v} $opts_and_values { if {[dict exists $arg_info $o -multiple] && [dict get $arg_info $o -multiple]} { set vlist $v } else { set vlist [list $v] } if {[dict exists $arg_info $o -validate_without_ansi] && [dict get $arg_info $o -validate_without_ansi]} { set validate_without_ansi 1 package require punk::ansi } else { set validate_without_ansi 0 } if {[dict exists $arg_info $o -allow_ansi] && [dict get $arg_info $o -allow_ansi]} { set allow_ansi 1 } else { #ironically - we need punk::ansi to detect and disallow - but we don't need it if ansi is allowed package require punk::ansi set allow_ansi 0 } if {!$allow_ansi} { #detect should work fine directly on whole list if {[punk::ansi::ta::detect $vlist]} { error "Option $o for $caller contains ansi - but -allow_ansi is false. Received: [ansistring VIEW $vlist]" } #foreach e $vlist { # if {[punk::ansi::ta::detect $e]} { # error "Option $o for $caller contains ansi - but -allow_ansi is false. Received: '$e'" # } #} } set vlist_check [list] foreach e $vlist { #could probably stripansi entire list safely in one go? - review if {$validate_without_ansi} { lappend vlist_check [punk::ansi::stripansi $e] } else { lappend vlist_check $e } } set is_default 0 foreach e $vlist e_check $vlist_check { if {[dict exists $combined_defaults $o] && ($e_check eq [dict get $combined_defaults $o])} { incr is_default } } if {$is_default eq [llength $vlist]} { set is_default true } #we want defaults to pass through - even if they don't pass the checks that would be required for a specified value #If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review. if {!$is_default} { if {[dict exists $arg_info $o -type]} { set type [dict get $arg_info $o -type] set ltype [string tolower $type] switch -- $type { int - integer - double { switch -- $ltype { int - integer { foreach e $vlist e_check $vlist_check { if {![string is integer -strict $e_check]} { error "Option $o for $caller requires type 'integer'. Received: '$e'" } } } double { foreach e $vlist e_check $vlist_check { if {![string is double -strict $e_check]} { error "Option $o for $caller requires type 'double'. Received: '$e'" } } } } #todo - small-value double comparisons with error-margin? review if {[dict exists $arg_info $o -range]} { lassign [dict get $arg_info $o -range] low high foreach e $vlist e_check $vlist_check { if {$e_check < $low || $e_check > $high} { error "Option $o for $caller must be between $low and $high. Received: '$e'" } } } } bool - boolean { foreach e $vlist e_check $vlist_check { if {![string is boolean -strict $e_check]} { error "Option $o for $caller requires type 'boolean'. Received: '$e'" } } } alnum - alpha - ascii - control - digit - graph - lower - print - punct - space - upper - wordchar - xdigit { foreach e $vlist e_check $vlist_check { if {![string is [string tolower $type] $e_check]} { error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e'" } } } file - directory - existingfile - existingdirectory { foreach e $vlist e_check $vlist_check { if {!([string length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_check])} { error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which doesn't look like it could be a file or directory" } } if {[string tolower $type] in {existingfile}} { foreach e $vlist e_check $vlist_check { if {![file exists $e_check]} { error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not an existing file" } } } elseif {[string tolower $type] in {existingdirectory}} { foreach e $vlist e_check $vlist_check { if {![file isdirectory $e_check]} { error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not an existing directory" } } } } char - character { foreach e $vlist e_check $vlist_check { if {[string length != 1]} { error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not a single character" } } } } } if {[dict exists $arg_info $o -choices]} { set choices [dict get $arg_info $o -choices] set nocase [dict get $arg_info $o -nocase] foreach e $vlist e_check $vlist_check { if {$nocase} { set casemsg "(case insensitive)" set choices_test [string tolower $choices] set v_test [string tolower $e_check] } else { set casemsg "(case sensitive)" set v_test $e_check set choices_test $choices } if {$v_test ni $choices_test} { error "Option $o for $caller must be one of the listed values $choices $casemsg. Received: '$e'" } } } } if {[dict exists $arg_info $o -strip_ansi] && [dict get $arg_info $o -strip_ansi]} { set stripped_list [list] foreach e $vlist { lappend stripped_list [punk::ansi::stripansi $e] } if {[dict exists $arg_info $o -multiple] && [dict get $arg_info $o -multiple]} { if {[dict get $arg_info $o -ARGTYPE] eq "option"} { dict set opts $o $stripped_list } else { dict set values $o $stripped_list } } else { if {[dict get $arg_info $o -ARGTYPE] eq "option"} { dict set opts $o [lindex $stripped_list 0] } else { dict set values [lindex $stripped_list 0] } } } } #maintain order of opts $opts values $values as caller may use lassign. return [dict create opts $opts values $values] } #tcl8.7/9 compatibility for 8.6 if {[info commands ::tcl::string::insert] eq ""} { #https://wiki.tcl-lang.org/page/string+insert # Pure Tcl implementation of [string insert] command. proc ::tcl::string::insert {string index insertString} { # Convert end-relative and TIP 176 indexes to simple integers. if {[regexp -expanded { ^(end(?![\t\n\v\f\r ]) # "end" is never followed by whitespace |[\t\n\v\f\r ]*[+-]?\d+) # m, with optional leading whitespace (?:([+-]) # op, omitted when index is "end" ([+-]?\d+))? # n, omitted when index is "end" [\t\n\v\f\r ]*$ # optional whitespace (unless "end") } $index _ m op n]} { # Convert first index to an integer. switch $m { end {set index [string length $string]} default {scan $m %d index} } # Add or subtract second index, if provided. switch $op { + {set index [expr {$index + $n}]} - {set index [expr {$index - $n}]} } } elseif {![string is integer -strict $index]} { # Reject invalid indexes. return -code error "bad index \"$index\": must be\ integer?\[+-\]integer? or end?\[+-\]integer?" } # Concatenate the pre-insert, insertion, and post-insert strings. string cat [string range $string 0 [expr {$index - 1}]] $insertString\ [string range $string $index end] } # Bind [string insert] to [::tcl::string::insert]. namespace ensemble configure string -map [dict replace\ [namespace ensemble configure string -map]\ insert ::tcl::string::insert] } interp alias {} errortime {} punk::lib::errortime proc errortime {script groupsize {iters 2}} { #by use MAK from https://wiki.tcl-lang.org/page/How+to+Measure+Performance set i 0 set times {} if {$iters < 2} {set iters 2} for {set i 0} {$i < $iters} {incr i} { set result [uplevel [list time $script $groupsize]] lappend times [lindex $result 0] } set average 0.0 set s2 0.0 foreach time $times { set average [expr {$average + double($time)/$iters}] } foreach time $times { set s2 [expr {$s2 + (($time-$average)*($time-$average) / ($iters-1))}] } set sigma [expr {int(sqrt($s2))}] set average [expr int($average)] return "$average +/- $sigma microseconds per iteration" } #test function to use with show_jump_tables #todo - check if switch compilation to jump tables differs by Tcl version proc switch_char_test {c} { set dec [scan $c %c] foreach t [list 1 2 3] { switch -- $c { x { return [list $dec x $t] } y { return [list $dec y $t] } z { return [list $dec z $t] } } } #tcl 8.6/8.7 (at least) #curlies must be unescaped and unbraced to work as literals in switch and enable it to compile to jumpTable switch -- $c { a { return [list $dec a] } {"} { return [list $dec dquote] } {[} {return [list $dec lb]} {]} {return [list $dec rb]} "{" { return [list $dec lbrace] } "}" { return [list $dec rbrace] } default { return [list $dec $c] } } } #we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164) proc show_jump_tables {procname} { set data [tcl::unsupported::disassemble proc $procname] set result "" set in_jt 0 foreach ln [split $data \n] { set tln [string trim $ln] if {!$in_jt} { if {[string match *jumpTable* $ln]} { append result $ln \n set in_jt 1 } } else { if {[string match Command* $tln] || [string match "(*) *" $tln]} { set in_jt 0 } else { append result $ln \n } } } return $result } #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #todo - way to generate 'internal' docs separately? #*** !doctools #[section Internal] namespace eval punk::lib::system { #*** !doctools #[subsection {Namespace punk::lib::system}] #[para] Internal functions that are not part of the API #[list_begin definitions] proc mostFactorsBelow {n} { ##*** !doctools #[call [fun mostFactorsBelow] [arg n]] #[para]Find the number below $n which has the greatest number of factors #[para]This will get slow quickly as n increases (100K = 1s+ 2024) set most 0 set mostcount 0 for {set i 1} {$i < $n} {incr i} { set fc [llength [punk::lib::factors $i]] if {$fc > $mostcount} { set most $i set mostcount $fc } } return [list number $most numfactors $mostcount] } proc factorCountBelow_punk {n} { ##*** !doctools #[call [fun factorCountBelow] [arg n]] #[para]For numbers 1 to n - keep a tally of the total count of factors #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result #[para]and as a rudimentary performance comparison #[para]gets slow quickly! set tally 0 for {set i 1} {$i <= $n} {incr i} { incr tally [llength [punk::lib::factors $i]] } return $tally } proc factorCountBelow_numtheory {n} { ##*** !doctools #[call [fun factorCountBelow] [arg n]] #[para]For numbers 1 to n - keep a tally of the total count of factors #[para]This is not useful other than a quick and dirty check that different algorithms return *probably* the same result #[para]and as a rudimentary performance comparison #[para]gets slow quickly! (significantly slower than factorCountBelow_punk) package require math::numtheory set tally 0 for {set i 1} {$i <= $n} {incr i} { incr tally [llength [math::numtheory::factors $i]] } return $tally } proc factors2 {x} { ##*** !doctools #[call [fun factors2] [arg x]] #[para]Return a sorted list of factors of x #[para]A similar brute-force mechanism to factors - but keeps result ordering as we go. set smallfactors [list 1] set j 2 set max [expr {sqrt($x)}] while {$j < $max} { if {($x % $j) == 0} { lappend smallfactors $j lappend largefactors [expr {$x / $j}] } incr j } #handle sqrt outside loop so we don't have to sort/dedup or check list membership in main loop if {($x % $j) == 0} { if {$j == ($x / $j)} { lappend smallfactors $j } } return [concat $smallfactors [lreverse $largefactors] $x] } # incomplte - report which is the innermost bracket/quote etc awaiting completion for a Tcl command #important - used by punk::repl proc incomplete {partial} { #we can apparently get away without concatenating current innerpartial to previous in list - REVIEW. if {[info complete $partial]} { return [list] } set clist [split $partial ""] #puts stderr "-->$clist<--" set waiting [list ""] set innerpartials [list ""] set escaped 0 set i 0 foreach c $clist { if {$c eq "\\"} { set escaped [expr {!$escaped}] incr i continue } ;# set escaped 0 at end set p [lindex $innerpartials end] if {$escaped == 0} { #NOTE - curly braces as switch arm keys must be unescaped and balanced. (escapes stop byte-compilation to jumpTable for switch statements for tcl8.6/8.7 at least) switch -- $c { {"} { if {![info complete ${p}]} { lappend waiting {"} lappend innerpartials "" } else { if {[lindex $waiting end] eq {"}} { #this quote is endquote set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { if {![info complete ${p}$c]} { lappend waiting {"} lappend innerpartials "" } else { set p ${p}${c} lset innerpartials end $p } } } } {[} { if {![info complete ${p}$c]} { lappend waiting "\]" lappend innerpartials "" } else { set p ${p}${c} lset innerpartials end $p } } "{" { if {![info complete ${p}$c]} { lappend waiting "\}" lappend innerpartials "" } else { set p ${p}${c} lset innerpartials end $p } } "}" - default { set waitingfor [lindex $waiting end] if {$c eq "$waitingfor"} { set waiting [lrange $waiting 0 end-1] set innerpartials [lrange $innerpartials 0 end-1] } else { set p ${p}${c} lset innerpartials end $p } } } } else { set p ${p}${c} lset innerpartials end $p } set escaped 0 incr i } set incomplete [list] foreach w $waiting { #to be treated as literals - curly braces must be unescaped here - and balanced - hence the left-curly empty arm. switch -- $w { {"} { lappend incomplete $w } {]} { lappend incomplete "\[" } "{" {} "}" { lappend incomplete "\{" } } } set debug 0 if {$debug} { foreach w $waiting p $innerpartials { puts stderr "->awaiting:'$w' partial: $p" } } return $incomplete } #This only works for very simple cases will get confused with for example: # {set x "a["""} proc incomplete_naive {partial} { if {[info complete $partial]} { return [list] } set clist [split $partial ""] set waiting [list] set escaped 0 foreach c $clist { if {$c eq "\\"} { set escaped [expr {!$escaped}] continue } if {!$escaped} { if {$c eq {"}} { if {[lindex $waiting end] eq {"}} { set waiting [lrange $waiting 0 end-1] } else { lappend waiting {"} } } elseif {$c eq "\["} { lappend waiting "\]" } elseif {$c eq "\{"} { lappend waiting "\}" } else { set waitingfor [lindex $waiting end] if {$c eq "$waitingfor"} { set waiting [lrange $waiting 0 end-1] } } } } set incomplete [list] foreach w $waiting { if {$w eq {"}} { lappend incomplete $w } elseif {$w eq "\]"} { lappend incomplete "\[" } elseif {$w eq "\}"} { lappend incomplete "\{" } } return $incomplete } #*** !doctools #[list_end] [comment {--- end definitions namespace punk::lib::system ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::lib [namespace eval punk::lib { variable pkg punk::lib variable version set version 0.1.1 }] return #*** !doctools #[manpage_end]