# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-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 999999.0a1.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[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 --}]
#[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 <int> 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 <le>
#[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 <char>? <linelist>"
}
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 <cmdlist> 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 <options_dict> values <values_dict>
#[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 <int>, -maxvalues <int>, -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]
#assert - 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 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]